From: Stefano Zacchiroli Date: Fri, 3 Feb 2006 15:32:38 +0000 (+0000) Subject: - renamed ocaml/ to components/ X-Git-Tag: make_still_working~7647 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=55b82bd235d82ff7f0a40d980effe1efde1f5073;p=helm.git - renamed ocaml/ to components/ - moved components/ and matita/ below software/ --- diff --git a/helm/matita/.depend b/helm/matita/.depend deleted file mode 100644 index 06c32e01d..000000000 --- a/helm/matita/.depend +++ /dev/null @@ -1,59 +0,0 @@ -applyTransformation.cmo: applyTransformation.cmi -applyTransformation.cmx: applyTransformation.cmi -buildTimeConf.cmo: buildTimeConf.cmi -buildTimeConf.cmx: buildTimeConf.cmi -dump_moo.cmo: buildTimeConf.cmi -dump_moo.cmx: buildTimeConf.cmx -matitaclean.cmo: matitaInit.cmi matitaclean.cmi -matitaclean.cmx: matitaInit.cmx matitaclean.cmi -matitacLib.cmo: matitaInit.cmi matitaExcPp.cmi matitaEngine.cmi \ - buildTimeConf.cmi matitacLib.cmi -matitacLib.cmx: matitaInit.cmx matitaExcPp.cmx matitaEngine.cmx \ - buildTimeConf.cmx matitacLib.cmi -matitac.cmo: matitamake.cmo matitadep.cmi matitaclean.cmi matitacLib.cmi -matitac.cmx: matitamake.cmx matitadep.cmx matitaclean.cmx matitacLib.cmx -matitadep.cmo: matitaInit.cmi matitadep.cmi -matitadep.cmx: matitaInit.cmx matitadep.cmi -matitaEngine.cmo: matitaEngine.cmi -matitaEngine.cmx: matitaEngine.cmi -matitaExcPp.cmo: matitaExcPp.cmi -matitaExcPp.cmx: matitaExcPp.cmi -matitaGeneratedGui.cmo: matitaGeneratedGui.cmi -matitaGeneratedGui.cmx: matitaGeneratedGui.cmi -matitaGtkMisc.cmo: matitaTypes.cmi matitaGeneratedGui.cmi matitaGtkMisc.cmi -matitaGtkMisc.cmx: matitaTypes.cmx matitaGeneratedGui.cmx matitaGtkMisc.cmi -matitaGui.cmo: matitamakeLib.cmi matitaTypes.cmi matitaScript.cmi \ - matitaMisc.cmi matitaMathView.cmi matitaGtkMisc.cmi \ - matitaGeneratedGui.cmi matitaExcPp.cmi buildTimeConf.cmi matitaGui.cmi -matitaGui.cmx: matitamakeLib.cmx matitaTypes.cmx matitaScript.cmx \ - matitaMisc.cmx matitaMathView.cmx matitaGtkMisc.cmx \ - matitaGeneratedGui.cmx matitaExcPp.cmx buildTimeConf.cmx matitaGui.cmi -matitaInit.cmo: matitamakeLib.cmi buildTimeConf.cmi matitaInit.cmi -matitaInit.cmx: matitamakeLib.cmx buildTimeConf.cmx matitaInit.cmi -matitamakeLib.cmo: buildTimeConf.cmi matitamakeLib.cmi -matitamakeLib.cmx: buildTimeConf.cmx matitamakeLib.cmi -matitamake.cmo: matitamakeLib.cmi matitaInit.cmi -matitamake.cmx: matitamakeLib.cmx matitaInit.cmx -matitaMathView.cmo: matitaTypes.cmi matitaScript.cmi matitaMisc.cmi \ - matitaGuiTypes.cmi matitaGtkMisc.cmi matitaExcPp.cmi buildTimeConf.cmi \ - applyTransformation.cmi matitaMathView.cmi -matitaMathView.cmx: matitaTypes.cmx matitaScript.cmx matitaMisc.cmx \ - matitaGuiTypes.cmi matitaGtkMisc.cmx matitaExcPp.cmx buildTimeConf.cmx \ - applyTransformation.cmx matitaMathView.cmi -matitaMisc.cmo: buildTimeConf.cmi matitaMisc.cmi -matitaMisc.cmx: buildTimeConf.cmx matitaMisc.cmi -matita.cmo: matitaTypes.cmi matitaScript.cmi matitaMathView.cmi \ - matitaInit.cmi matitaGui.cmi matitaGtkMisc.cmi buildTimeConf.cmi -matita.cmx: matitaTypes.cmx matitaScript.cmx matitaMathView.cmx \ - matitaInit.cmx matitaGui.cmx matitaGtkMisc.cmx buildTimeConf.cmx -matitaScript.cmo: matitamakeLib.cmi matitaTypes.cmi matitaMisc.cmi \ - matitaEngine.cmi buildTimeConf.cmi matitaScript.cmi -matitaScript.cmx: matitamakeLib.cmx matitaTypes.cmx matitaMisc.cmx \ - matitaEngine.cmx buildTimeConf.cmx matitaScript.cmi -matitaTypes.cmo: matitaTypes.cmi -matitaTypes.cmx: matitaTypes.cmi -matitaGtkMisc.cmi: matitaGeneratedGui.cmi -matitaGui.cmi: matitaGuiTypes.cmi -matitaGuiTypes.cmi: matitaTypes.cmi matitaGeneratedGui.cmi -matitaMathView.cmi: matitaTypes.cmi matitaGuiTypes.cmi -matitaScript.cmi: matitaTypes.cmi diff --git a/helm/matita/.ocamlinit b/helm/matita/.ocamlinit deleted file mode 100644 index 1585f71b2..000000000 --- a/helm/matita/.ocamlinit +++ /dev/null @@ -1,44 +0,0 @@ -(* directories *) -#directory "../ocaml/cic" -#directory "../ocaml/cic_notation" -#directory "../ocaml/cic_omdoc" -#directory "../ocaml/cic_proof_checking" -#directory "../ocaml/cic_textual_parser2" -#directory "../ocaml/cic_transformations" -#directory "../ocaml/cic_unification" -#directory "../ocaml/getter" -#directory "../ocaml/hbugs" -#directory "../ocaml/mathql" -#directory "../ocaml/mathql_generator" -#directory "../ocaml/mathql_interpreter" -#directory "../ocaml/metadata" -#directory "../ocaml/paramodulation" -#directory "../ocaml/registry" -#directory "../ocaml/tactics" -#directory "../ocaml/thread" -#directory "../ocaml/urimanager" -#directory "../ocaml/xml" -#directory "../ocaml/xmldiff" - -(* custom printers *) -let fppuri ppf uri = - let s = UriManager.string_of_uri uri in - Format.pp_print_string ppf s -;; - -#install_printer CicMetaSubst.fppsubst;; -#install_printer CicMetaSubst.fppterm;; -#install_printer CicMetaSubst.fppmetasenv;; -#install_printer fppuri;; - -(* utility functions *) -let go = MatitacLib.interactive_loop;; - -(* let's go! *) -let _ = - at_exit (fun () -> MatitacLib.clean_exit None); - if Array.length Sys.argv > 1 then - MatitacLib.main `TOPLEVEL - else - MatitacLib.go () -;; diff --git a/helm/matita/AUTHORS b/helm/matita/AUTHORS deleted file mode 100644 index a2da427a5..000000000 --- a/helm/matita/AUTHORS +++ /dev/null @@ -1,5 +0,0 @@ -Andrea Asperti -Luca Padovani -Enrico Tassi -Claudio Sacerdoti Coen -Stefano Zacchiroli diff --git a/helm/matita/LICENSE b/helm/matita/LICENSE deleted file mode 100644 index 7665cd2ce..000000000 --- a/helm/matita/LICENSE +++ /dev/null @@ -1,23 +0,0 @@ -Copyright (C) 2000-2005, HELM Team. - -Matita 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/ diff --git a/helm/matita/Makefile b/helm/matita/Makefile deleted file mode 100644 index 75d878780..000000000 --- a/helm/matita/Makefile +++ /dev/null @@ -1,338 +0,0 @@ -export SHELL=/bin/bash - -include ../Makefile.defs - -NULL = -H=@ - -OCAML_FLAGS = -pp $(CAMLP4O) -PKGS = -package "$(MATITA_REQUIRES)" -CPKGS = -package "$(MATITA_CREQUIRES)" -OCAML_THREADS_FLAGS = -thread -OCAML_DEBUG_FLAGS = -g -OCAMLC_FLAGS = $(OCAML_FLAGS) $(OCAML_THREADS_FLAGS) -OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLC_FLAGS) $(OCAML_DEBUG_FLAGS) -OCAMLOPT = $(OCAMLFIND) opt $(OCAMLC_FLAGS) -OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAML_FLAGS) - -MATITA_FLAGS = -noprofile -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -# objects for matita (GTK GUI) -CMOS = \ - buildTimeConf.cmo \ - matitaTypes.cmo \ - matitaMisc.cmo \ - matitamakeLib.cmo \ - matitaInit.cmo \ - matitaExcPp.cmo \ - matitaEngine.cmo \ - matitacLib.cmo \ - matitaScript.cmo \ - matitaGeneratedGui.cmo \ - matitaGtkMisc.cmo \ - applyTransformation.cmo \ - matitaMathView.cmo \ - matitaGui.cmo \ - $(NULL) -# objects for matitac (batch compiler) -CCMOS = \ - buildTimeConf.cmo \ - matitaTypes.cmo \ - matitaMisc.cmo \ - matitamakeLib.cmo \ - matitaInit.cmo \ - matitaExcPp.cmo \ - matitaEngine.cmo \ - matitacLib.cmo \ - $(NULL) -MAINCMOS = \ - matitadep.cmo \ - matitaclean.cmo \ - matitamake.cmo \ - $(NULL) -PROGRAMS_BYTE = matita matitac cicbrowser matitadep matitaclean matitamake dump_moo -PROGRAMS = $(PROGRAMS_BYTE) matitatop -PROGRAMS_OPT = $(patsubst %,%.opt,$(PROGRAMS_BYTE)) - -.PHONY: all -all: $(PROGRAMS) -# all: matita.conf.xml $(PROGRAMS) coq.moo - -# matita.conf.xml: matita.conf.xml.sample -# @if diff matita.conf.xml.sample matita.conf.xml 1>/dev/null 2>/dev/null; then\ -# touch matita.conf.xml;\ -# else\ -# echo;\ -# echo "matita.conf.xml.sample is newer than matita.conf.xml";\ -# echo;\ -# echo "PLEASE update your configuration file!";\ -# echo "(copying matita.conf.xml.sample should work)";\ -# echo;\ -# false;\ -# fi - -# coq.moo: library/legacy/coq.ma matitac -# ./matitac $(MATITA_FLAGS) $< -# coq.moo.opt: library/legacy/coq.ma matitac.opt -# ./matitac.opt $(MATITA_FLAGS) $< - -ifeq ($(HAVE_OCAMLOPT),yes) - -CMXS = $(patsubst %.cmo,%.cmx,$(CMOS)) -CCMXS = $(patsubst %.cmo,%.cmx,$(CCMOS)) -MAINCMXS = $(patsubst %.cmo,%.cmx,$(MAINCMOS)) -LIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_REQUIRES)) -LIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_REQUIRES)) -CLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_CREQUIRES)) -CLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_CREQUIRES)) -.PHONY: opt -opt: $(PROGRAMS_OPT) coq.moo.opt -.PHONY: upx -upx: $(PROGRAMS_UPX) coq.moo.opt - -else - -opt: - @echo "Native code compilation is disabled" - -endif - -matita: matita.ml $(LIB_DEPS) $(CMOS) - @echo "OCAMLC $<" - $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ $(CMOS) matita.ml -matita.opt: matita.ml $(LIBX_DEPS) $(CMXS) - @echo "OCAMLOPT $<" - $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml - -dump_moo: dump_moo.ml buildTimeConf.cmo - @echo "OCAMLC $<" - $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ buildTimeConf.cmo $< -dump_moo.opt: dump_moo.ml buildTimeConf.cmx - @echo "OCAMLOPT $<" - $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ buildTimeConf.cmx $< - -matitac: matitac.ml $(CLIB_DEPS) $(CCMOS) $(MAINCMOS) - @echo "OCAMLC $<" - $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ $(CCMOS) $(MAINCMOS) matitac.ml -matitac.opt: matitac.ml $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) - @echo "OCAMLOPT $<" - $(H)$(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml - -matitatop: matitatop.ml $(CLIB_DEPS) $(CCMOS) - @echo "OCAMLC $<" - $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ toplevellib.cma $(CCMOS) $< - -matitadep: matitac - @test -f $@ || ln -s $< $@ -matitadep.opt: matitac.opt - @test -f $@ || ln -s $< $@ - -matitaclean: matitac - @test -f $@ || ln -s $< $@ -matitaclean.opt: matitac.opt - @test -f $@ || ln -s $< $@ - -matitamake: matitac - @test -f $@ || ln -s $< $@ -matitamake.opt: matitac.opt - @test -f $@ || ln -s $< $@ - -cicbrowser: matita - @test -f $@ || ln -s $< $@ -cicbrowser.opt: matita.opt - @test -f $@ || ln -s $< $@ - -matitaGeneratedGui.ml matitaGeneratedGui.mli: matita.glade - $(LABLGLADECC) -embed $< > matitaGeneratedGui.ml - $(OCAMLC) $(PKGS) -i matitaGeneratedGui.ml > matitaGeneratedGui.mli - -.PHONY: clean -clean: - rm -rf *.cma *.cmo *.cmi *.cmx *.cmxa *.a *.o \ - $(PROGRAMS) \ - $(PROGRAMS_OPT) \ - $(PROGRAMS_STATIC) \ - $(PROGRAMS_UPX) \ - $(NULL) - -TEST_DIRS = \ - library \ - tests \ - tests/bad_tests \ - contribs/LAMBDA-TYPES \ - contribs/PREDICATIVE-TOPOLOGY \ - $(NULL) - -.PHONY: tests tests.opt cleantests cleantests.opt -tests: $(foreach d,$(TEST_DIRS),$(d)-test) -tests.opt: $(foreach d,$(TEST_DIRS),$(d)-test-opt) -cleantests: $(foreach d,$(TEST_DIRS),$(d)-cleantests) -cleantests.opt: $(foreach d,$(TEST_DIRS),$(d)-cleantests-opt) - -%-test: matitac matitadep matitaclean coq.moo - -cd $* && make -k clean all -%-test-opt: matitac.opt matitadep.opt matitaclean.opt coq.moo.opt - -cd $* && make -k clean.opt opt -%-cleantests: matitaclean - -cd $* && make clean -%-cleantests-opt: matitaclean.opt - -cd $* && make clean.opt - -# {{{ Distribution stuff - -ifeq ($(wildcard matitac.opt),matitac.opt) -BEST=opt -else -BEST=all -endif - -stdlib: - MATITA_RT_BASE_DIR=`pwd` \ - MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" \ - ./matitamake -init build_stdlib - -# MATITA_RT_BASE_DIR=`pwd` \ - $(MAKE) MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" -C library/ $(BEST) - -DEST = @RT_BASE_DIR@ -INSTALL_STUFF = \ - icons/ \ - matita.gtkrc \ - matita.lang \ - matita.ma.templ \ - core_notation.moo \ - matita.conf.xml \ - closed.xml \ - gtkmathview.matita.conf.xml \ - template_makefile.in \ - library/ \ - $(PROGRAMS_BYTE) \ - $(NULL) -ifeq ($(HAVE_OCAMLOPT),yes) -INSTALL_STUFF += $(PROGRAMS_OPT) -endif - -install: - install -d $(DEST) - cp -a .matita/ - cp -a $(INSTALL_STUFF) $(DEST) -uninstall: - -STATIC_LINK = dist/static_link/static_link -# for matita -STATIC_LIBS = \ - t1 t1x \ - gtkmathview_gmetadom mathview mathview_backend_gtk mathview_frontend_gmetadom \ - gtksourceview-1.0 \ - gdome gmetadom_gdome_cpp_smart \ - stdc++ \ - mysqlclient \ - expat \ - $(NULL) -STATIC_EXTRA_LIBS = -cclib -lt1x -cclib -lstdc++ -# for matitac & co -STATIC_CLIBS = \ - gdome \ - mysqlclient \ - $(NULL) -STATIC_EXTRA_CLIBS = -PROGRAMS_STATIC = $(patsubst %,%.static,$(PROGRAMS_OPT)) -PROGRAMS_UPX = $(patsubst %,%.upx,$(PROGRAMS_STATIC)) - -ifeq ($(HAVE_OCAMLOPT),yes) -static: $(STATIC_LINK) $(PROGRAMS_STATIC) coq.moo.opt -else -upx: - @echo "Native code compilation is disabled" -static: - @echo "Native code compilation is disabled" -endif - -$(STATIC_LINK): - $(MAKE) -C dist/ $(STATIC_LINK) - -matita.opt.static: $(STATIC_LINK) $(LIBX_DEPS) $(CMXS) matita.ml - $(STATIC_LINK) $(STATIC_LIBS) -- \ - $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml \ - $(STATIC_EXTRA_LIBS) - strip $@ -dump_moo.opt.static: $(STATIC_LINK) buildTimeConf.cmx dump_moo.ml - $(STATIC_LINK) $(STATIC_CLIBS) -- \ - $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $^ \ - $(STATIC_EXTRA_CLIBS) - strip $@ -matitac.opt.static: $(STATIC_LINK) $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) matitac.ml - $(STATIC_LINK) $(STATIC_CLIBS) -- \ - $(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml \ - $(STATIC_EXTRA_CLIBS) - strip $@ -matitadep.opt.static: matitac.opt.static - @test -f $@ || ln -s $< $@ -matitaclean.opt.static: matitac.opt.static - @test -f $@ || ln -s $< $@ -matitamake.opt.static: matitac.opt.static - @test -f $@ || ln -s $< $@ -cicbrowser.opt.static: matita.opt.static - @test -f $@ || ln -s $< $@ -cicbrowser.opt.static.upx: matita.opt.static.upx - @test -f $@ || ln -s $< $@ - -.PHONY: distclean -distclean: clean - $(MAKE) -C dist/ clean - rm -f matitaGeneratedGui.ml matitaGeneratedGui.mli - rm -f buildTimeConf.ml - rm -f matita.glade.bak matita.gladep.bak - rm -f matita.conf.xml.sample - -%.upx: % - cp $< $@ - strip $@ - upx $@ - -# }}} End of distribution stuff - -tags: TAGS -.PHONY: TAGS -TAGS: - cd ..; otags -vi -r ocaml/ matita/ - -#.depend: matitaGeneratedGui.ml matitaGeneratedGui.mli *.ml *.mli - -.PHONY: depend -depend: - $(OCAMLDEP) *.ml *.mli > .depend - -include .depend - -%.cmi: %.mli - @echo "OCAMLC $<" - $(H)$(OCAMLC) $(PKGS) -c $< -%.cmo %.cmi: %.ml - @echo "OCAMLC $<" - $(H)$(OCAMLC) $(PKGS) -c $< -%.cmx: %.ml - @echo "OCAMLOPT $<" - $(H)$(OCAMLOPT) $(PKGS) -c $< -%.annot: %.ml - @echo "OCAMLC -dtypes $<" - $(H)$(OCAMLC) -dtypes $(PKGS) -c $< - -$(CMOS): $(LIB_DEPS) -$(CMOS:%.cmo=%.cmx): $(LIBX_DEPS) - -ifeq ($(MAKECMDGOALS),all) - $(CMOS:%.cmo=%.cmi): $(LIB_DEPS) -endif -ifeq ($(MAKECMDGOALS),) - $(CMOS:%.cmo=%.cmi): $(LIB_DEPS) -endif -ifeq ($(MAKECMDGOALS),opt) - $(CMOS:%.cmo=%.cmi): $(LIBX_DEPS) -endif - -# vim: set foldmethod=marker: diff --git a/helm/matita/applyTransformation.ml b/helm/matita/applyTransformation.ml deleted file mode 100644 index 83e5f3c18..000000000 --- a/helm/matita/applyTransformation.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 21/11/2003 *) -(* *) -(* *) -(***************************************************************************) - -(* $Id$ *) - -let mpres_document pres_box = - Xml.add_xml_declaration (CicNotationPres.print_box pres_box) - -let mml_of_cic_sequent metasenv sequent = - let unsh_sequent,(asequent,ids_to_terms, - ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses) - = - Cic2acic.asequent_of_sequent metasenv sequent - in - let content_sequent = Acic2content.map_sequent asequent in - let pres_sequent = - (Sequent2pres.sequent2pres ~ids_to_inner_sorts content_sequent) - in - let xmlpres = mpres_document pres_sequent in - (Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres, - unsh_sequent, - (asequent, - (ids_to_terms,ids_to_father_ids,ids_to_hypotheses,ids_to_inner_sorts))) - -let mml_of_cic_object obj = - let (annobj, 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 content = - Acic2content.annobj2content ~ids_to_inner_sorts ~ids_to_inner_types annobj - in - let pres = Content2pres.content2pres ~ids_to_inner_sorts content in - let xmlpres = mpres_document pres in - let mathml = Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres in - (mathml,(annobj, - (ids_to_terms, ids_to_father_ids, ids_to_conjectures, ids_to_hypotheses, - ids_to_inner_sorts,ids_to_inner_types))) - diff --git a/helm/matita/applyTransformation.mli b/helm/matita/applyTransformation.mli deleted file mode 100644 index 8e023aea6..000000000 --- a/helm/matita/applyTransformation.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 21/11/2003 *) -(* *) -(* *) -(***************************************************************************) - -val mml_of_cic_sequent: - Cic.metasenv -> (* metasenv *) - Cic.conjecture -> (* sequent *) - Gdome.document * (* Math ML *) - Cic.conjecture * (* unshared sequent *) - (Cic.annconjecture * (* annsequent *) - ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) - (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) - (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) - (Cic.id, Cic2acic.sort_kind) Hashtbl.t)) (* ids_to_inner_sorts *) - -val mml_of_cic_object: - Cic.obj -> (* object *) - Gdome.document * (* Math ML *) - (Cic.annobj * (* annobj *) - ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) - (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) - (Cic.id, Cic.conjecture) Hashtbl.t * (* id -> conjecture *) - (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) - (Cic.id, Cic2acic.sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, Cic2acic.anntypes) Hashtbl.t)) (* ids_to_inner_types *) - diff --git a/helm/matita/buildTimeConf.ml.in b/helm/matita/buildTimeConf.ml.in deleted file mode 100644 index 8ea2c7b86..000000000 --- a/helm/matita/buildTimeConf.ml.in +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -let debug = @DEBUG@;; -let version = "@MATITA_VERSION@";; -let undo_history_size = 10;; -let console_history_size = 100;; -let browser_history_size = 100;; -let base_uri = "cic:/matita";; -let phrase_sep = ".";; -let blank_uri = "about:blank";; -let current_proof_uri = "about:current_proof";; -let default_font_size = 10;; -let script_font = "Monospace";; - - (** may be overridden with MATITA_RT_BASE_DIR environment variable, useful for - * binary distribution installed in user home directories *) -let runtime_base_dir = - try - Sys.getenv "MATITA_RT_BASE_DIR" - with Not_found -> "@RT_BASE_DIR@";; - -let images_dir = runtime_base_dir ^ "/icons" -let gtkrc_file = runtime_base_dir ^ "/matita.gtkrc" -let lang_file = runtime_base_dir ^ "/matita.lang" -let script_template = runtime_base_dir ^ "/matita.ma.templ" -let core_notation_script = runtime_base_dir ^ "/core_notation.moo" -let matita_conf = runtime_base_dir ^ "/matita.conf.xml" -let closed_xml = runtime_base_dir ^ "/closed.xml" -let gtkmathview_conf = runtime_base_dir ^ "/gtkmathview.matita.conf.xml" -let matitamake_makefile_template = runtime_base_dir ^ "/template_makefile.in" -let stdlib_dir = runtime_base_dir ^ "/library" - diff --git a/helm/matita/buildTimeConf.mli b/helm/matita/buildTimeConf.mli deleted file mode 100644 index 09a927fc6..000000000 --- a/helm/matita/buildTimeConf.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* Copyright (C) 2006, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -val base_uri : string -val blank_uri : string -val browser_history_size : int -val closed_xml : string -val console_history_size : int -val core_notation_script : string -val current_proof_uri : string -val debug : bool -val default_font_size : int -val gtkmathview_conf : string -val gtkrc_file : string -val images_dir : string -val lang_file : string -val matita_conf : string -val matitamake_makefile_template : string -val phrase_sep : string -val runtime_base_dir : string -val script_font : string -val script_template : string -val stdlib_dir : string -val undo_history_size : int -val version : string - diff --git a/helm/matita/closed.xml b/helm/matita/closed.xml deleted file mode 100644 index d3125efb7..000000000 --- a/helm/matita/closed.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - - - - - - - This goal has already been closed. - Use the "skip" command to throw it away. - - - - diff --git a/helm/matita/contribs/LAMBDA-TYPES/Makefile b/helm/matita/contribs/LAMBDA-TYPES/Makefile deleted file mode 100644 index 5b2b2fa40..000000000 --- a/helm/matita/contribs/LAMBDA-TYPES/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -SRC=$(shell find . -name "*.ma" -a -type f) - -MATITA_FLAGS = -I ../.. -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -MATITAC=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac $(MATITA_FLAGS)" "../../matitaclean $(MATITA_FLAGS)" /dev/null OK -MATITACOPT=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac.opt $(MATITA_FLAGS)" "../../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK -VERBOSEMATITAC=../../matitac $(MATITA_FLAGS) -VERBOSEMATITACOPT=../../matitac.opt $(MATITA_FLAGS) - -MATITACLEAN=../../matitaclean $(MATITA_FLAGS) -MATITACLEANOPT=../../matitaclean.opt $(MATITA_FLAGS) - -MATITADEP=../../matitadep $(MATITA_FLAGS) -MATITADEPOPT=../../matitadep.opt $(MATITA_FLAGS) - -DEPEND_NAME=.depend - -H=@ - -all: $(SRC:%.ma=%.mo) - -opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all - -verbose: - $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all - -%.opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) - -clean_: - $(H)rm -f __*not_for_matita - -clean: clean_ - $(H)$(MATITACLEAN) $(SRC) - -cleanall: clean_ - $(H)rm -f $(SRC:%.ma=%.moo) - $(H)$(MATITACLEAN) all - -depend: - $(H)rm -f $(DEPEND_NAME) - $(H)$(MAKE) $(DEPEND_NAME) -.PHONY: depend - -%.moo: - $(H)$(MATITAC) $< - -$(DEPEND_NAME): $(SRC) - $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ - -#include $(DEPEND_NAME) -include .depend diff --git a/helm/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma b/helm/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma deleted file mode 100644 index 572618808..000000000 --- a/helm/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/LAMBDA-TYPES/lref_map_defs". - -include "terms_defs.ma". - -inductive tlref_map (A: Set) (N: Set) (map: nat \to nat): nat \to (T A N) \to (T A N) \to Prop \def - | tlref_map_sort: \forall i. \forall k. \forall y. (tlref_map A N map i (TSort A N y k) (TSort A N y k)) - | tlref_map_lref_lt: \forall j. \forall i. \forall y. j < i \to (tlref_map A N map i (TLRef A N y j) (TLRef A N y j)) - | tlref_map_lref_ge: \forall j. \forall i. \forall y. i \le j \to (tlref_map A N map i (TLRef A N y j) (TLRef A N y (map j))). diff --git a/helm/matita/contribs/LAMBDA-TYPES/terms_defs.ma b/helm/matita/contribs/LAMBDA-TYPES/terms_defs.ma deleted file mode 100644 index cf7848abe..000000000 --- a/helm/matita/contribs/LAMBDA-TYPES/terms_defs.ma +++ /dev/null @@ -1,47 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/LAMBDA-TYPES/terms_defs". - -include "legacy/coq.ma". - -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -alias id "plus" = "cic:/Coq/Init/Peano/plus.con". -alias id "lt" = "cic:/Coq/Init/Peano/lt.con". -alias id "le" = "cic:/Coq/Init/Peano/le.ind#xpointer(1/1)". - -inductive B : Set \def - | Void: B - | Abbr: B - | Abst: B. - -inductive F : Set \def - | Appl: F - | Cast: F. - -inductive W : Set \def - | Bind: B \to W - | Flat: F \to W. - -inductive T (A:Set) (N:Set) : Set \def - | TSort: A \to nat \to (T A N) - | TLRef: A \to nat \to (T A N) - | TWag : A \to W \to (T A N) \to (T A N) \to (T A N) - | TGRef: A \to N \to (T A N). - -record X (A:Set) (N:Set) : Type \def { - get_gref: N \to B \to (T A N) \to Prop -}. diff --git a/helm/matita/contribs/LAMBDA-TYPES/tlt_defs.ma b/helm/matita/contribs/LAMBDA-TYPES/tlt_defs.ma deleted file mode 100644 index 390c067cc..000000000 --- a/helm/matita/contribs/LAMBDA-TYPES/tlt_defs.ma +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/LAMBDA-TYPES/tlt_defs". - -include "terms_defs.ma". - -definition wadd: (nat \to nat) \to nat \to (nat \to nat) \def - \lambda map,w,n. - match n with [ - O \Rightarrow w - | (S m) \Rightarrow (map m) - ]. - -let rec weight_map (A:Set) (N:Set) (map:nat \to nat) (t:T A N) on t : nat \def - match t with [ - (TSort y k) \Rightarrow O - | (TLRef y i) \Rightarrow (map i) - | (TWag y z w u) \Rightarrow - match z with [ - (Bind b) \Rightarrow - match b with [ - Abbr \Rightarrow - (S ((weight_map A N map w) + (weight_map A N (wadd map (S (weight_map A N map w))) u))) - | Abst \Rightarrow - (S ((weight_map A N map w) + (weight_map A N (wadd map O) u))) - | Void \Rightarrow - (S ((weight_map A N map w) + (weight_map A N (wadd map O) u))) - ] - | (Flat a) \Rightarrow - (S ((weight_map A N map w) + (weight_map A N map u))) - ] - | (TGRef y n) \Rightarrow O - ]. - -definition weight: \forall A,N. T A N \to nat \def - \lambda A,N. - (weight_map A N (\lambda _.O)). - -definition tlt: \forall A,N. T A N \to T A N \to Prop \def - \lambda A,N,t1,t2. - weight A N t1 < weight A N t2. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile deleted file mode 100644 index 489b2c135..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -SRC=$(shell find . -name "*.ma" -a -type f) - -MATITA_FLAGS = -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -MATITAC=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac $(MATITA_FLAGS)" "../../matitaclean $(MATITA_FLAGS)" /dev/null OK -MATITACOPT=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac.opt $(MATITA_FLAGS)" "../../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK -VERBOSEMATITAC=../../matitac $(MATITA_FLAGS) -VERBOSEMATITACOPT=../../matitac.opt $(MATITA_FLAGS) - -MATITACLEAN=../../matitaclean $(MATITA_FLAGS) -MATITACLEANOPT=../../matitaclean.opt $(MATITA_FLAGS) - -MATITADEP=../../matitadep $(MATITA_FLAGS) -MATITADEPOPT=../../matitadep.opt $(MATITA_FLAGS) - -DEPEND_NAME=.depend - -H=@ - -all: $(SRC:%.ma=%.mo) - -opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all - -verbose: - $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all - -%.opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) - -clean_: - $(H)rm -f __*not_for_matita - -clean: clean_ - $(H)$(MATITACLEAN) $(SRC) - -cleanall: clean_ - $(H)rm -f $(SRC:%.ma=%.moo) - $(H)$(MATITACLEAN) all - -depend: - $(H)rm -f $(DEPEND_NAME) - $(H)$(MAKE) $(DEPEND_NAME) -.PHONY: depend - -%.moo: - $(H)$(MATITAC) $< - -$(DEPEND_NAME): $(SRC) - $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ - -#include $(DEPEND_NAME) -include .depend diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma deleted file mode 100644 index 17a53f64f..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma +++ /dev/null @@ -1,51 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -(* Project started Wed Oct 12, 2005 ***************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/class_defs". - -include "../../library/logic/connectives.ma". - -(* ACZEL CATEGORIES: - - We use typoids with a compatible membership relation - - The category is intended to be the domain of the membership relation - - The membership relation is necessary because we need to regard the - domain of a propositional function (ie a predicative subset) as a - quantification domain and therefore as a category, but there is no - type in CIC representing the domain of a propositional function - - We set up a single equality predicate, parametric on the category, - defined as the reflexive, symmetic, transitive and compatible closure - of the cle1 predicate given inside the category. Then we prove the - properties of the equality that usually are axiomatized inside the - category structure. This makes categories easier to use -*) - -definition true_f \def \lambda (X:Type). \lambda (_:X). True. - -definition false_f \def \lambda (X:Type). \lambda (_:X). False. - -record Class: Type \def { - class:> Type; - cin: class \to Prop; - cle1: class \to class \to Prop -}. - -inductive cle (C:Class) (c1:C): C \to Prop \def - | cle_refl: cin ? c1 \to cle ? c1 c1 - | ceq_sing: \forall c2,c3. - cle ? c1 c2 \to cin ? c3 \to cle1 ? c2 c3 \to cle ? c1 c3. - -inductive ceq (C:Class) (c1:C) (c2:C): Prop \def - | ceq_intro: cle ? c1 c2 \to cle ? c2 c1 \to ceq ? c1 c2. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma deleted file mode 100644 index cfcb57293..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/class_eq". - -include "class_le.ma". - -theorem ceq_cl: \forall C,c1,c2. ceq ? c1 c2 \to cin C c1 \land cin C c2. -intros; elim H; clear H. -lapply cle_cl to H1 using H; clear H1; decompose H; -lapply cle_cl to H2 using H; clear H2; decompose H. -auto. -qed. - -theorem ceq_refl: \forall C,c. cin C c \to ceq ? c c. -intros; apply ceq_intro; auto. -qed. - -theorem ceq_trans: \forall C,c2,c1,c3. - ceq C c2 c3 \to ceq ? c1 c2 \to ceq ? c1 c3. -intros; elim H; elim H1; clear H; clear H1. -apply ceq_intro; apply cle_trans; [|auto|auto||auto|auto]. -qed. - -theorem ceq_sym: \forall C,c1,c2. ceq C c1 c2 \to ceq C c2 c1. -intros; elim H; clear H.; auto. -qed. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma deleted file mode 100644 index a688ec63b..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/class_le". - -include "class_defs.ma". - -theorem cle_cl: \forall C,c1,c2. cle ? c1 c2 \to cin C c1 \land cin C c2. -intros; elim H; clear H; clear c2; - [| decompose H2 ]; auto. -qed. - -theorem cle_trans: \forall C,c1,c2. cle C c1 c2 \to - \forall c3. cle ? c3 c1 \to cle ? c3 c2. -intros 4; elim H; clear H; clear c2; - [| apply ceq_sing; [||| apply H4 ]]; auto. -qed. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma deleted file mode 100644 index c840fbdaf..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma +++ /dev/null @@ -1,61 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/coa_defs". - -include "iff.ma". -include "domain_data.ma". - -(* COMPLETE OVERLAP ALGEBRAS -*) - -record COA: Type \def { - coa:> Class; (* carrier *) - le: coa \to coa \to Prop; (* inclusion *) - ov: coa \to coa \to Prop; (* overlap *) - sup: \forall (D:Domain). (D \to coa) \to coa; (* supremum *) - inf: \forall (D:Domain). (D \to coa) \to coa; (* infimum *) - le_refl: \forall p. le p p; - le_trans: \forall p,r. le p r \to \forall q. le r q \to le p q; - le_antysym: \forall q,p. le q p \to le p q \to ceq ? p q; - ov_sym: \forall q,p. ov q p \to ov p q; - sup_le: \forall D,ps,q. le (sup D ps) q \liff \iforall d. le (ps d) q; - inf_le: \forall D,p,qs. le p (inf D qs) \liff \iforall d. le p (qs d); - sup_ov: \forall D,ps,q. ov (sup D ps) q \liff \iexists d. ov (ps d) q; - density: \forall p,q. (\forall r. ov p r \to ov q r) \to le p q -}. - -definition zero: \forall (P:COA). P \def - \lambda (P:COA). inf P ? (dvoid_ixfam P). - -definition one: \forall (P:COA). P \def - \lambda (P:COA). sup P ? (dvoid_ixfam P). - -definition binf: \forall (P:COA). P \to P \to P \def - \lambda (P:COA). \lambda p0,p1. - inf P ? (dbool_ixfam P p0 p1). - -definition bsup: \forall (P:COA). P \to P \to P \def - \lambda (P:COA). \lambda p0,p1. - sup P ? (dbool_ixfam P p0 p1). - -(* - inf_ov: forall p q, ov p q -> ov p (inf QDBool (bool_family _ p q)) - properness: ov zero zero -> False; - distributivity: forall I p q, id _ (inf QDBool (bool_family _ (sup I p) q)) (sup I (fun i => (inf QDBool (bool_family _ (p i) q)))); -*) - -inductive pippo : Prop \def - | Pippo: let x \def zero in zero = x \to pippo. - \ No newline at end of file diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma deleted file mode 100644 index 6c004073e..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/coa_props". - -include "coa_defs.ma". - -inductive True:Prop \def T:True. - -theorem zero_le: - \forall (P:COA). \forall (p:P). (le ? (zero P) p) \to True. - intros. - exact T. -qed. - - - - diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma deleted file mode 100644 index ed0afab4f..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/domain_data". - -include "../../library/datatypes/constructors.ma". -include "../../library/datatypes/bool.ma". -include "domain_defs.ma". - -(* QUANTIFICATION DOMAINS - - Here we define some useful domains based on data types -*) - -definition DBool : Domain \def - mk_Domain (mk_Class bool (true_f ?) (eq ?)). - -definition dbool_ixfam : \forall (C:Class). C \to C \to (DBool \to C) \def - \lambda C,c0,c1,b. - match b in bool with - [ false \Rightarrow c0 - | true \Rightarrow c1 - ]. - -definition DVoid : Domain \def - mk_Domain (mk_Class void (true_f ?) (eq ?)). - -definition dvoid_ixfam : \forall (C:Class). (DVoid \to C) \def - \lambda C,v. - match v in void with []. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma deleted file mode 100644 index 68cbd01fa..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/domain_defs". - -include "class_defs.ma". - -(* QUANTIFICATION DOMAINS - - These are the categories on which we allow quantification - - We set up single quantifiers, parametric on the domain, so they - already have the properties that usually are axiomatized inside the - domain structure. This makes domains easier to use -*) - -record Domain: Type \def { - qd:> Class -}. - -(* internal universal quantification *) -inductive dall (D:Domain) (P:D \to Prop) : Prop \def - | dall_intro: (\forall d:D. cin D d \to P d) \to dall D P. - -(* internal existential quantification *) -inductive dex (D:Domain) (P:D \to Prop) : Prop \def - | dex_intro: \forall d:D. cin D d \land P d \to dex D P. - -(* notations **************************************************************) - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "internal for all" 'iforall \eta.x = - (cic:/matita/PREDICATIVE-TOPOLOGY/domain_defs/dall.ind#xpointer(1/1) _ x). - -notation > "hvbox(\iforall ident i opt (: ty) break . p)" - right associative with precedence 20 -for @{ 'iforall ${default - @{\lambda ${ident i} : $ty. $p)} - @{\lambda ${ident i} . $p}}}. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "internal exists" 'dexists \eta.x = - (cic:/matita/PREDICATIVE-TOPOLOGY/domain_defs/dex.ind#xpointer(1/1) _ x). - -notation > "hvbox(\iexists ident i opt (: ty) break . p)" - right associative with precedence 20 -for @{ 'dexists ${default - @{\lambda ${ident i} : $ty. $p)} - @{\lambda ${ident i} . $p}}}. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma deleted file mode 100644 index 9a9491923..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma +++ /dev/null @@ -1,31 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/logic/iff". - -include "../../library/logic/connectives.ma". - -definition Iff : Prop \to Prop \to Prop \def - \lambda A,B. (A \to B) \land (B \to A). - - (*CSC: the URI must disappear: there is a bug now *) -interpretation "logical iff" 'iff x y = (cic:/matita/logic/iff/Iff.con x y). - -notation > "hvbox(a break \liff b)" - left associative with precedence 25 -for @{ 'iff $a $b }. - -notation < "hvbox(a break \leftrightarrow b)" - left associative with precedence 25 -for @{ 'iff $a $b }. diff --git a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma deleted file mode 100644 index 5d872040a..000000000 --- a/helm/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma +++ /dev/null @@ -1,66 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/subset_defs". - -include "domain_defs.ma". - -(* SUBSETS - - We use predicative subsets coded as propositional functions - according to G.Sambin and S.Valentini "Toolbox" -*) - -definition Subset \def \lambda (D:Domain). D \to Prop. - -(* subset membership (epsilon) *) -definition sin : \forall D. Subset D \to D \to Prop \def - \lambda (D:Domain). \lambda U,d. cin D d \and U d. - -(* subset top (full subset) *) -definition stop \def \lambda (D:Domain). true_f D. - -(* subset bottom (empty subset) *) -definition sbot \def \lambda (D:Domain). false_f D. - -(* subset and (binary intersection) *) -definition sand: \forall D. Subset D \to Subset D \to Subset D \def - \lambda D,U1,U2,d. U1 d \land U2 d. - -(* subset or (binary union) *) -definition sor: \forall D. Subset D \to Subset D \to Subset D \def - \lambda D,U1,U2,d. U1 d \lor U2 d. - -(* subset less or equal (inclusion) *) -definition sle: \forall D. Subset D \to Subset D \to Prop \def - \lambda D,U1,U2. \iforall d. U1 d \to U2 d. - -(* subset overlap *) -definition sover: \forall D. Subset D \to Subset D \to Prop \def - \lambda D,U1,U2. \iexists d. U1 d \land U2 d. - -(* coercions **************************************************************) - -(* -(* the class of the subsets of a domain (not an implicit coercion) *) -definition class_of_subsets_of \def - \lambda D. mk_Class (Subset D) (true_f ?) (sle ?). -*) - -(* the domain built upon a subset (not an implicit coercion) *) -definition domain_of_subset: \forall D. Subset D \to Domain \def - \lambda (D:Domain). \lambda U. - mk_Domain (mk_Class D (sin D U) (cle1 D)). - -(* the full subset of a domain *) -coercion stop. diff --git a/helm/matita/core_notation.moo b/helm/matita/core_notation.moo deleted file mode 100644 index c30e5142c..000000000 --- a/helm/matita/core_notation.moo +++ /dev/null @@ -1,115 +0,0 @@ -notation "hvbox(a break \to b)" - right associative with precedence 20 -for @{ \forall $_:$a.$b }. - -notation < "hvbox(a break \to b)" - right associative with precedence 20 -for @{ \Pi $_:$a.$b }. - -notation "hvbox(a break = b)" - non associative with precedence 45 -for @{ 'eq $a $b }. - -notation "hvbox(a break \leq b)" - non associative with precedence 45 -for @{ 'leq $a $b }. - -notation "hvbox(a break \geq b)" - non associative with precedence 45 -for @{ 'geq $a $b }. - -notation "hvbox(a break \lt b)" - non associative with precedence 45 -for @{ 'lt $a $b }. - -notation "hvbox(a break \gt b)" - non associative with precedence 45 -for @{ 'gt $a $b }. - -notation "hvbox(a break \neq b)" - non associative with precedence 45 -for @{ 'neq $a $b }. - -notation "hvbox(a break \nleq b)" - non associative with precedence 45 -for @{ 'nleq $a $b }. - -notation "hvbox(a break \ngeq b)" - non associative with precedence 45 -for @{ 'ngeq $a $b }. - -notation "hvbox(a break \nless b)" - non associative with precedence 45 -for @{ 'nless $a $b }. - -notation "hvbox(a break \ngtr b)" - non associative with precedence 45 -for @{ 'ngtr $a $b }. - -notation "hvbox(a break \divides b)" - non associative with precedence 45 -for @{ 'divides $a $b }. - -notation "hvbox(a break \ndivides b)" - non associative with precedence 45 -for @{ 'ndivides $a $b }. - -notation "hvbox(a break + b)" - left associative with precedence 50 -for @{ 'plus $a $b }. - -notation "hvbox(a break - b)" - left associative with precedence 50 -for @{ 'minus $a $b }. - -notation "hvbox(a break * b)" - left associative with precedence 55 -for @{ 'times $a $b }. - -notation "hvbox(a break \mod b)" - left associative with precedence 55 -for @{ 'module $a $b }. - -notation "\frac a b" - non associative with precedence 90 -for @{ 'divide $a $b }. - -notation "a \over b" - left associative with precedence 55 -for @{ 'divide $a $b }. - -notation "hvbox(a break / b)" - left associative with precedence 55 -for @{ 'divide $a $b }. - -notation > "- a" - right associative with precedence 60 -for @{ 'uminus $a }. - -notation < "- a" - right associative with precedence 75 -for @{ 'uminus $a }. - -notation "a !" - non associative with precedence 80 -for @{ 'fact $a }. - -notation "(a \sup b)" - right associative with precedence 65 -for @{ 'exp $a $b}. - -notation "\sqrt a" - non associative with precedence 60 -for @{ 'sqrt $a }. - -notation "hvbox(a break \lor b)" - left associative with precedence 30 -for @{ 'or $a $b }. - -notation "hvbox(a break \land b)" - left associative with precedence 35 -for @{ 'and $a $b }. - -notation "hvbox(\lnot a)" - left associative with precedence 40 -for @{ 'not $a }. diff --git a/helm/matita/dictionary-matita.xml b/helm/matita/dictionary-matita.xml deleted file mode 100644 index 35903486b..000000000 --- a/helm/matita/dictionary-matita.xml +++ /dev/null @@ -1,15 +0,0 @@ - - - - - - - - - - - - - - - diff --git a/helm/matita/dist/Makefile b/helm/matita/dist/Makefile deleted file mode 100644 index 669137bf2..000000000 --- a/helm/matita/dist/Makefile +++ /dev/null @@ -1,17 +0,0 @@ -MYSQL_FLAGS = --extended_insert --lock-tables=off --no-create-info -DB = -u helm -h mowgli.cs.unibo.it matita -TABLE_CREATOR = ../../ocaml/metadata/table_creator/table_creator -TABLES := $(shell $(TABLE_CREATOR) list all) -all: static_link -clean: static_link_clean -.PHONY: static_link -static_link: - $(MAKE) -C static_link/ -static_link_clean: - $(MAKE) -C static_link/ clean -dist: matita_stdlib.sql.gz -.PHONY: matita_stdlib.sql -matita_stdlib.sql: - mysqldump $(MYSQL_FLAGS) $(DB) $(TABLES) > $@ -%.gz: % - gzip -c $< > $@ diff --git a/helm/matita/dist/fill_db.sh b/helm/matita/dist/fill_db.sh deleted file mode 100755 index 1ae28d336..000000000 --- a/helm/matita/dist/fill_db.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/bin/bash -set -e - -MYSQL="mysql" -DBHOST="localhost" -DBNAME="matita" -DBUSER="helm" -DBPASS="" - -TABLE_CREATOR="../../ocaml/metadata/table_creator/table_creator" - -SQL="matita_db.sql" -STDLIB_DATA="matita_stdlib.sql.gz" - -grant_sql="GRANT ALL PRIVILEGES ON $DBNAME.* TO $DBUSER@$DBHOST" -create_sql="CREATE DATABASE $DBNAME" -drop_sql="DROP DATABASE $DBNAME" - -function appendsql() -{ - echo "$1" >> $SQL -} - -echo "Step 0." -echo " Dropping old databases, if any." -echo " You can ignore errors output by this step" -echo "$drop_sql" | $MYSQL -f -echo "Step 1." -echo " Creating database and users." -echo "# SQL statements to create Matita DB and users" > $SQL -appendsql "$create_sql;" -if [ -z "$DBPASS" ]; then - appendsql "$grant_sql;" -else - appendsql "$grant_sql IDENTIFIED BY '$DBPASS';" -fi -$MYSQL < $SQL -echo "Step 2." -echo " Creating database structure." -echo "# SQL statements to create Matita DB structure" > $SQL -creator_args="table fill index" -for arg in $creator_args; do - appendsql "`$TABLE_CREATOR $arg all`" -done -$MYSQL $DBNAME < $SQL -echo "Step 3." -echo " Filling database with standard library metadata." -if [ -f "$STDLIB_DATA" ]; then - gunzip -c "$STDLIB_DATA" | $MYSQL $DBNAME -else - echo " Standard library metadata file $STDLIB_DATA not found, skipping this step." -fi - diff --git a/helm/matita/dist/static_link/Makefile b/helm/matita/dist/static_link/Makefile deleted file mode 100644 index 5a02bb3b7..000000000 --- a/helm/matita/dist/static_link/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -all: static_link -static_link: static_link.ml - ocamlfind ocamlc -package unix,str -linkpkg -o $@ $< -clean: - rm -f static_link.cm* static_link diff --git a/helm/matita/dist/static_link/static_link.ml b/helm/matita/dist/static_link/static_link.ml deleted file mode 100644 index 8b1d57668..000000000 --- a/helm/matita/dist/static_link/static_link.ml +++ /dev/null @@ -1,162 +0,0 @@ - -open Printf - -exception Found of string list - -let ocamlobjinfo = "ocamlobjinfo" -let noautolink = "-noautolink" -let dummy_opt_cmd = "dummy_ocamlopt" -let opt_cmd = "ocamlopt" -let libdirs = [ "/lib"; "/usr/lib"; "/usr/lib/gcc/i486-linux-gnu/4.0.2" ] -let exceptions = [ "threads.cma", [ "-lthreads", "-lthreadsnat" ] ] - -let blanks_RE = Str.regexp "[ \t\r\n]+" -let cmxa_RE = Str.regexp "\\.cmxa$" -let extra_cfiles_RE = Str.regexp "^.*Extra +C +object +files:\\(.*\\)$" -let extra_copts_RE = Str.regexp "^.*Extra +C +options:\\(.*\\)$" -let lib_RE = Str.regexp "^lib" -let l_RE = Str.regexp "^-l" -let opt_line_RE = Str.regexp (sprintf "^\\+ +%s +\\(.*\\)$" dummy_opt_cmd) -let trailing_cmxa_RE = Str.regexp ".*\\.cmxa$" - -let message s = prerr_endline ("STATIC_LINK: " ^ s) -let warning s = message ("WARNING: " ^ s) - -let handle_exceptions ~cma cflag = - try - let cma_exns = List.assoc (Filename.basename cma) exceptions in - let cflag' = List.assoc cflag cma_exns in - message (sprintf "using %s exception %s -> %s" cma cflag cflag'); - cflag' - with Not_found -> cflag - -let parse_cmdline () = - let mine, rest = ref [], ref [] in - let is_mine = ref true in - Array.iter - (function - | "--" -> is_mine := false - | s when !is_mine -> - if Str.string_match lib_RE s 0 then - warning (sprintf - ("libraries to be statically linked must be specified " - ^^ "without heading \"lib\", \"%s\" argument may be wrong") s); - mine := s :: !mine - | s -> rest := s :: !rest) - Sys.argv; - if !rest = [] then begin - prerr_endline "Usage: static_link [ CLIB .. ] -- COMMAND [ ARG .. ]"; - prerr_endline ("Example: static_link pcre expat --" - ^ " ocamlfind opt -package pcre,expat -linkpkg -o foo foo.ml"); - exit 0 - end; - List.tl (List.rev !mine), List.rev !rest - -let extract_opt_flags cmd = - let ic = Unix.open_process_in cmd in - (try - while true do - let l = input_line ic in - if Str.string_match opt_line_RE l 0 then begin - message ("got ocamlopt line: " ^ l); - raise (Found (Str.split blanks_RE (Str.matched_group 1 l))); - end - done; - [] (* dummy value *) - with - | End_of_file -> failwith "compiler command not found" - | Found flags -> - close_in ic; - flags) - -let cma_of_cmxa = Str.replace_first cmxa_RE ".cma" - -let find_clib libname = - let rec aux = - function - | [] -> raise Not_found - | libdir :: tl -> - let fname = sprintf "%s/lib%s.a" libdir libname in - if Sys.file_exists fname then fname else aux tl - in - aux libdirs - -let a_of_cflag cflag = (* "-lfoo" -> "/usr/lib/libfoo.a" *) - let libname = Str.replace_first l_RE "" cflag in - find_clib libname - -let cflags_of_cma fname = - let ic = Unix.open_process_in (sprintf "%s %s" ocamlobjinfo fname) in - let extra_copts = ref "" in - let extra_cfiles = ref "" in - (try - while true do - match input_line ic with - | s when Str.string_match extra_copts_RE s 0 -> - extra_copts := Str.matched_group 1 s - | s when Str.string_match extra_cfiles_RE s 0 -> - extra_cfiles := Str.matched_group 1 s - | _ -> () - done - with End_of_file -> ()); - close_in ic; - let extra_cfiles = List.rev (Str.split blanks_RE !extra_cfiles) in - let extra_copts = Str.split blanks_RE !extra_copts in - extra_copts @ extra_cfiles - -let staticize static_libs flags = - let static_flags = List.map ((^) "-l") static_libs in - let aux ~add_cclib ~cma cflag = - let cflag = - if List.mem cflag static_flags - then - (try - let a = a_of_cflag cflag in - message (sprintf "using static %s instead of shared %s" a cflag); - a - with Not_found -> warning ("can't find lib for " ^ cflag); cflag) - else (handle_exceptions ~cma cflag) - in - if add_cclib then [ "-cclib"; cflag ] else [ cflag ] - in - List.fold_right - (fun flag acc -> - let cma = cma_of_cmxa flag in - if Str.string_match trailing_cmxa_RE flag 0 then begin - message ("processing native archive: " ^ flag); - let cflags = cflags_of_cma cma in - let cflags' = - List.fold_right - (fun cflag acc -> (aux ~add_cclib:true ~cma cflag) @ acc) - cflags [] - in - flag :: (cflags' @ acc) - end else - (aux ~add_cclib:false ~cma flag) @ acc) - flags [] - -let quote_if_needed s = - try - ignore (Str.search_forward blanks_RE s 0); - "\"" ^ s ^ "\"" - with Not_found -> s - -let main () = - let static_libs, args = parse_cmdline () in - printf "C libraries to be linked-in: %s\n" (String.concat " " static_libs); - flush stdout; - let verbose_cmd = - sprintf "OCAMLFIND_COMMANDS='ocamlopt=%s' %s -verbose 2>&1" dummy_opt_cmd - (String.concat " " (List.map quote_if_needed args)) - in - let orig_opt_flags = extract_opt_flags verbose_cmd in - message ("original ocamlopt flags: " ^ String.concat " " orig_opt_flags); - let opt_flags = staticize static_libs orig_opt_flags in - message ("new ocamlopt flags: " ^ String.concat " " opt_flags); - let flags = noautolink :: opt_flags in - let cmd = String.concat " " (opt_cmd :: flags) in - message ("executing command: " ^ cmd); - exit (Sys.command cmd) - -let _ = main () - diff --git a/helm/matita/dump_moo.ml b/helm/matita/dump_moo.ml deleted file mode 100644 index 05c21d40d..000000000 --- a/helm/matita/dump_moo.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let arg_spec = - let std_arg_spec = [] in - let debug_arg_spec = [] in - std_arg_spec @ debug_arg_spec - -let usage = - sprintf "MatitaC v%s\nUsage: dump_moo [option ...] file.moo\nOptions:" - BuildTimeConf.version - -let _ = - let moos = ref [] in - let add_moo fname = moos := fname :: !moos in - Arg.parse arg_spec add_moo usage; - if !moos = [] then begin print_endline usage; exit 1 end; - List.iter - (fun fname -> - if not (Sys.file_exists fname) then - HLog.error (sprintf "Can't find moo '%s', skipping it." fname) - else begin - printf "%s:\n" fname; flush stdout; - let commands = GrafiteMarshal.load_moo ~fname in - List.iter - (fun cmd -> - printf " %s\n%!" - (GrafiteAstPp.pp_command ~obj_pp:(fun _ -> assert false) cmd)) - commands; - end) - (List.rev !moos) - diff --git a/helm/matita/gtkmathview.matita.conf.xml.in b/helm/matita/gtkmathview.matita.conf.xml.in deleted file mode 100644 index 704ca13ef..000000000 --- a/helm/matita/gtkmathview.matita.conf.xml.in +++ /dev/null @@ -1,17 +0,0 @@ - - -
- @RT_BASE_DIR@/dictionary-matita.xml -
- - diff --git a/helm/matita/icons/matita-bulb-high.png b/helm/matita/icons/matita-bulb-high.png deleted file mode 100644 index 03b6e7f86..000000000 Binary files a/helm/matita/icons/matita-bulb-high.png and /dev/null differ diff --git a/helm/matita/icons/matita-bulb-low.png b/helm/matita/icons/matita-bulb-low.png deleted file mode 100644 index f97302e48..000000000 Binary files a/helm/matita/icons/matita-bulb-low.png and /dev/null differ diff --git a/helm/matita/icons/matita-bulb-medium.png b/helm/matita/icons/matita-bulb-medium.png deleted file mode 100644 index d3d449f93..000000000 Binary files a/helm/matita/icons/matita-bulb-medium.png and /dev/null differ diff --git a/helm/matita/icons/matita-folder.png b/helm/matita/icons/matita-folder.png deleted file mode 100644 index ec0cc0839..000000000 Binary files a/helm/matita/icons/matita-folder.png and /dev/null differ diff --git a/helm/matita/icons/matita-object.png b/helm/matita/icons/matita-object.png deleted file mode 100644 index fe89a30e8..000000000 Binary files a/helm/matita/icons/matita-object.png and /dev/null differ diff --git a/helm/matita/icons/matita-theory.png b/helm/matita/icons/matita-theory.png deleted file mode 100644 index 389152ef3..000000000 Binary files a/helm/matita/icons/matita-theory.png and /dev/null differ diff --git a/helm/matita/icons/matita.png b/helm/matita/icons/matita.png deleted file mode 100644 index 342bcb44c..000000000 Binary files a/helm/matita/icons/matita.png and /dev/null differ diff --git a/helm/matita/icons/matita_medium.png b/helm/matita/icons/matita_medium.png deleted file mode 100644 index 335688af2..000000000 Binary files a/helm/matita/icons/matita_medium.png and /dev/null differ diff --git a/helm/matita/icons/matita_small.png b/helm/matita/icons/matita_small.png deleted file mode 100644 index cfb017b0f..000000000 Binary files a/helm/matita/icons/matita_small.png and /dev/null differ diff --git a/helm/matita/icons/matita_very_small.png b/helm/matita/icons/matita_very_small.png deleted file mode 100644 index 5a6807126..000000000 Binary files a/helm/matita/icons/matita_very_small.png and /dev/null differ diff --git a/helm/matita/icons/meegg.png b/helm/matita/icons/meegg.png deleted file mode 100644 index 4c2be73fb..000000000 Binary files a/helm/matita/icons/meegg.png and /dev/null differ diff --git a/helm/matita/icons/whelp.png b/helm/matita/icons/whelp.png deleted file mode 100644 index f67ea8b55..000000000 Binary files a/helm/matita/icons/whelp.png and /dev/null differ diff --git a/helm/matita/icons/whelp.svg b/helm/matita/icons/whelp.svg deleted file mode 100644 index c1da66f6d..000000000 --- a/helm/matita/icons/whelp.svg +++ /dev/null @@ -1,221 +0,0 @@ - - - - - - - - - image/svg+xml - - - - - - - - - - - - - - - h - - e - - l - - p - - W - - - diff --git a/helm/matita/library/Makefile b/helm/matita/library/Makefile deleted file mode 100644 index fd278eb40..000000000 --- a/helm/matita/library/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -SRC=$(shell find . -name "*.ma" -a -type f) - -MATITA_FLAGS = -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -MATITAC=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac $(MATITA_FLAGS)" "../matitaclean $(MATITA_FLAGS)" /dev/null OK -MATITACOPT=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac.opt $(MATITA_FLAGS)" "../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK -VERBOSEMATITAC=../matitac $(MATITA_FLAGS) -VERBOSEMATITACOPT=../matitac.opt $(MATITA_FLAGS) - -MATITACLEAN=../matitaclean $(MATITA_FLAGS) -MATITACLEANOPT=../matitaclean.opt $(MATITA_FLAGS) - -MATITADEP=../matitadep $(MATITA_FLAGS) -MATITADEPOPT=../matitadep.opt $(MATITA_FLAGS) - -DEPEND_NAME=.depend - -H=@ - -all: $(SRC:%.ma=%.mo) - -opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all - -verbose: - $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all - -%.opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) - -clean_: - $(H)rm -f __*not_for_matita - -clean: clean_ - $(H)$(MATITACLEAN) $(SRC) - -cleanall: - $(H)rm -f $(SRC:%.ma=%.moo) - $(H)$(MATITACLEAN) all - -depend: - $(H)rm -f $(DEPEND_NAME) - $(H)$(MAKE) $(DEPEND_NAME) -.PHONY: depend - -%.moo: - $(H)$(MATITAC) $< - -$(DEPEND_NAME): $(SRC) - $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ - -#include $(DEPEND_NAME) -include .depend diff --git a/helm/matita/library/Q/q.ma b/helm/matita/library/Q/q.ma deleted file mode 100644 index 340154979..000000000 --- a/helm/matita/library/Q/q.ma +++ /dev/null @@ -1,320 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/Q/q". - -include "Z/compare.ma". -include "Z/plus.ma". - -(* a fraction is a list of Z-coefficients for primes, in natural -order. The last coefficient must eventually be different from 0 *) - -inductive fraction : Set \def - pp : nat \to fraction -| nn: nat \to fraction -| cons : Z \to fraction \to fraction. - -inductive ratio : Set \def - one : ratio - | frac : fraction \to ratio. - -(* a rational number is either O or a ratio with a sign *) -inductive Q : Set \def - OQ : Q - | Qpos : ratio \to Q - | Qneg : ratio \to Q. - -(* double elimination principles *) -theorem fraction_elim2: -\forall R:fraction \to fraction \to Prop. -(\forall n:nat.\forall g:fraction.R (pp n) g) \to -(\forall n:nat.\forall g:fraction.R (nn n) g) \to -(\forall x:Z.\forall f:fraction.\forall m:nat.R (cons x f) (pp m)) \to -(\forall x:Z.\forall f:fraction.\forall m:nat.R (cons x f) (nn m)) \to -(\forall x,y:Z.\forall f,g:fraction.R f g \to R (cons x f) (cons y g)) \to -\forall f,g:fraction. R f g. -intros 7.elim f. - apply H. - apply H1. - elim g. - apply H2. - apply H3. - apply H4.apply H5. -qed. - -(* boolean equality *) -let rec eqfb f g \def -match f with -[ (pp n) \Rightarrow - match g with - [ (pp m) \Rightarrow eqb n m - | (nn m) \Rightarrow false - | (cons y g1) \Rightarrow false] -| (nn n) \Rightarrow - match g with - [ (pp m) \Rightarrow false - | (nn m) \Rightarrow eqb n m - | (cons y g1) \Rightarrow false] -| (cons x f1) \Rightarrow - match g with - [ (pp m) \Rightarrow false - | (nn m) \Rightarrow false - | (cons y g1) \Rightarrow andb (eqZb x y) (eqfb f1 g1)]]. - -(* discrimination *) -definition aux \def - \lambda f. match f with - [ (pp n) \Rightarrow n - | (nn n) \Rightarrow n - | (cons x f) \Rightarrow O]. - -definition fhd \def -\lambda f. match f with - [ (pp n) \Rightarrow (pos n) - | (nn n) \Rightarrow (neg n) - | (cons x f) \Rightarrow x]. - -definition ftl \def -\lambda f. match f with - [ (pp n) \Rightarrow (pp n) - | (nn n) \Rightarrow (nn n) - | (cons x f) \Rightarrow f]. - -theorem injective_pp : injective nat fraction pp. -unfold injective.intros. -change with ((aux (pp x)) = (aux (pp y))). -apply eq_f.assumption. -qed. - -theorem injective_nn : injective nat fraction nn. -unfold injective.intros. -change with ((aux (nn x)) = (aux (nn y))). -apply eq_f.assumption. -qed. - -theorem eq_cons_to_eq1: \forall f,g:fraction.\forall x,y:Z. -(cons x f) = (cons y g) \to x = y. -intros. -change with ((fhd (cons x f)) = (fhd (cons y g))). -apply eq_f.assumption. -qed. - -theorem eq_cons_to_eq2: \forall x,y:Z.\forall f,g:fraction. -(cons x f) = (cons y g) \to f = g. -intros. -change with ((ftl (cons x f)) = (ftl (cons y g))). -apply eq_f.assumption. -qed. - -theorem not_eq_pp_nn: \forall n,m:nat. pp n \neq nn m. -intros.unfold Not. intro. -change with match (pp n) with -[ (pp n) \Rightarrow False -| (nn n) \Rightarrow True -| (cons x f) \Rightarrow True]. -rewrite > H. -simplify.exact I. -qed. - -theorem not_eq_pp_cons: -\forall n:nat.\forall x:Z. \forall f:fraction. -pp n \neq cons x f. -intros.unfold Not. intro. -change with match (pp n) with -[ (pp n) \Rightarrow False -| (nn n) \Rightarrow True -| (cons x f) \Rightarrow True]. -rewrite > H. -simplify.exact I. -qed. - -theorem not_eq_nn_cons: -\forall n:nat.\forall x:Z. \forall f:fraction. -nn n \neq cons x f. -intros.unfold Not. intro. -change with match (nn n) with -[ (pp n) \Rightarrow True -| (nn n) \Rightarrow False -| (cons x f) \Rightarrow True]. -rewrite > H. -simplify.exact I. -qed. - -theorem decidable_eq_fraction: \forall f,g:fraction. -decidable (f = g). -intros.unfold decidable. -apply (fraction_elim2 (\lambda f,g. f=g \lor (f=g \to False))). - intros.elim g1. - elim ((decidable_eq_nat n n1) : n=n1 \lor (n=n1 \to False)). - left.apply eq_f. assumption. - right.intro.apply H.apply injective_pp.assumption. - right.apply not_eq_pp_nn. - right.apply not_eq_pp_cons. - intros. elim g1. - right.intro.apply (not_eq_pp_nn n1 n).apply sym_eq. assumption. - elim ((decidable_eq_nat n n1) : n=n1 \lor (n=n1 \to False)). - left. apply eq_f. assumption. - right.intro.apply H.apply injective_nn.assumption. - right.apply not_eq_nn_cons. - intros.right.intro.apply (not_eq_pp_cons m x f1).apply sym_eq.assumption. - intros.right.intro.apply (not_eq_nn_cons m x f1).apply sym_eq.assumption. - intros.elim H. - elim ((decidable_eq_Z x y) : x=y \lor (x=y \to False)). - left.apply eq_f2.assumption. - assumption. - right.intro.apply H2.apply (eq_cons_to_eq1 f1 g1).assumption. - right.intro.apply H1.apply (eq_cons_to_eq2 x y f1 g1).assumption. -qed. - -theorem eqfb_to_Prop: \forall f,g:fraction. -match (eqfb f g) with -[true \Rightarrow f=g -|false \Rightarrow f \neq g]. -intros.apply (fraction_elim2 -(\lambda f,g.match (eqfb f g) with -[true \Rightarrow f=g -|false \Rightarrow f \neq g])). - intros.elim g1. - simplify.apply eqb_elim. - intro.simplify.apply eq_f.assumption. - intro.simplify.unfold Not.intro.apply H.apply injective_pp.assumption. - simplify.apply not_eq_pp_nn. - simplify.apply not_eq_pp_cons. - intros.elim g1. - simplify.unfold Not.intro.apply (not_eq_pp_nn n1 n).apply sym_eq. assumption. - simplify.apply eqb_elim.intro.simplify.apply eq_f.assumption. - intro.simplify.unfold Not.intro.apply H.apply injective_nn.assumption. - simplify.apply not_eq_nn_cons. - intros.simplify.unfold Not.intro.apply (not_eq_pp_cons m x f1).apply sym_eq. assumption. - intros.simplify.unfold Not.intro.apply (not_eq_nn_cons m x f1).apply sym_eq. assumption. - intros. - change in match (eqfb (cons x f1) (cons y g1)) - with (andb (eqZb x y) (eqfb f1 g1)). - apply eqZb_elim. - intro.generalize in match H.elim (eqfb f1 g1). - simplify.apply eq_f2.assumption. - apply H2. - simplify.unfold Not.intro.apply H2.apply (eq_cons_to_eq2 x y).assumption. - intro.simplify.unfold Not.intro.apply H1.apply (eq_cons_to_eq1 f1 g1).assumption. -qed. - -let rec finv f \def - match f with - [ (pp n) \Rightarrow (nn n) - | (nn n) \Rightarrow (pp n) - | (cons x g) \Rightarrow (cons (Zopp x) (finv g))]. - -definition Z_to_ratio :Z \to ratio \def -\lambda x:Z. match x with -[ OZ \Rightarrow one -| (pos n) \Rightarrow frac (pp n) -| (neg n) \Rightarrow frac (nn n)]. - -let rec ftimes f g \def - match f with - [ (pp n) \Rightarrow - match g with - [(pp m) \Rightarrow Z_to_ratio (pos n + pos m) - | (nn m) \Rightarrow Z_to_ratio (pos n + neg m) - | (cons y g1) \Rightarrow frac (cons (pos n + y) g1)] - | (nn n) \Rightarrow - match g with - [(pp m) \Rightarrow Z_to_ratio (neg n + pos m) - | (nn m) \Rightarrow Z_to_ratio (neg n + neg m) - | (cons y g1) \Rightarrow frac (cons (neg n + y) g1)] - | (cons x f1) \Rightarrow - match g with - [ (pp m) \Rightarrow frac (cons (x + pos m) f1) - | (nn m) \Rightarrow frac (cons (x + neg m) f1) - | (cons y g1) \Rightarrow - match ftimes f1 g1 with - [ one \Rightarrow Z_to_ratio (x + y) - | (frac h) \Rightarrow frac (cons (x + y) h)]]]. - -theorem symmetric2_ftimes: symmetric2 fraction ratio ftimes. -unfold symmetric2. intros.apply (fraction_elim2 (\lambda f,g.ftimes f g = ftimes g f)). - intros.elim g. - change with (Z_to_ratio (pos n + pos n1) = Z_to_ratio (pos n1 + pos n)). - apply eq_f.apply sym_Zplus. - change with (Z_to_ratio (pos n + neg n1) = Z_to_ratio (neg n1 + pos n)). - apply eq_f.apply sym_Zplus. - change with (frac (cons (pos n + z) f) = frac (cons (z + pos n) f)). - rewrite < sym_Zplus.reflexivity. - intros.elim g. - change with (Z_to_ratio (neg n + pos n1) = Z_to_ratio (pos n1 + neg n)). - apply eq_f.apply sym_Zplus. - change with (Z_to_ratio (neg n + neg n1) = Z_to_ratio (neg n1 + neg n)). - apply eq_f.apply sym_Zplus. - change with (frac (cons (neg n + z) f) = frac (cons (z + neg n) f)). - rewrite < sym_Zplus.reflexivity. - intros.change with (frac (cons (x1 + pos m) f) = frac (cons (pos m + x1) f)). - rewrite < sym_Zplus.reflexivity. - intros.change with (frac (cons (x1 + neg m) f) = frac (cons (neg m + x1) f)). - rewrite < sym_Zplus.reflexivity. - intros. - change with - (match ftimes f g with - [ one \Rightarrow Z_to_ratio (x1 + y1) - | (frac h) \Rightarrow frac (cons (x1 + y1) h)] = - match ftimes g f with - [ one \Rightarrow Z_to_ratio (y1 + x1) - | (frac h) \Rightarrow frac (cons (y1 + x1) h)]). - rewrite < H.rewrite < sym_Zplus.reflexivity. -qed. - -theorem ftimes_finv : \forall f:fraction. ftimes f (finv f) = one. -intro.elim f. - change with (Z_to_ratio (pos n + - (pos n)) = one). - rewrite > Zplus_Zopp.reflexivity. - change with (Z_to_ratio (neg n + - (neg n)) = one). - rewrite > Zplus_Zopp.reflexivity. -(* again: we would need something to help finding the right change *) - change with - (match ftimes f1 (finv f1) with - [ one \Rightarrow Z_to_ratio (z + - z) - | (frac h) \Rightarrow frac (cons (z + - z) h)] = one). - rewrite > H.rewrite > Zplus_Zopp.reflexivity. -qed. - -definition rtimes : ratio \to ratio \to ratio \def -\lambda r,s:ratio. - match r with - [one \Rightarrow s - | (frac f) \Rightarrow - match s with - [one \Rightarrow frac f - | (frac g) \Rightarrow ftimes f g]]. - -theorem symmetric_rtimes : symmetric ratio rtimes. -change with (\forall r,s:ratio. rtimes r s = rtimes s r). -intros. -elim r. elim s. -reflexivity. -reflexivity. -elim s. -reflexivity. -simplify.apply symmetric2_ftimes. -qed. - -definition rinv : ratio \to ratio \def -\lambda r:ratio. - match r with - [one \Rightarrow one - | (frac f) \Rightarrow frac (finv f)]. - -theorem rtimes_rinv: \forall r:ratio. rtimes r (rinv r) = one. -intro.elim r. -reflexivity. -simplify.apply ftimes_finv. -qed. diff --git a/helm/matita/library/Z/compare.ma b/helm/matita/library/Z/compare.ma deleted file mode 100644 index 4a5025975..000000000 --- a/helm/matita/library/Z/compare.ma +++ /dev/null @@ -1,143 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/Z/compare". - -include "Z/orders.ma". -include "nat/compare.ma". - -(* boolean equality *) -definition eqZb : Z \to Z \to bool \def -\lambda x,y:Z. - match x with - [ OZ \Rightarrow - match y with - [ OZ \Rightarrow true - | (pos q) \Rightarrow false - | (neg q) \Rightarrow false] - | (pos p) \Rightarrow - match y with - [ OZ \Rightarrow false - | (pos q) \Rightarrow eqb p q - | (neg q) \Rightarrow false] - | (neg p) \Rightarrow - match y with - [ OZ \Rightarrow false - | (pos q) \Rightarrow false - | (neg q) \Rightarrow eqb p q]]. - -theorem eqZb_to_Prop: -\forall x,y:Z. -match eqZb x y with -[ true \Rightarrow x=y -| false \Rightarrow x \neq y]. -intros. -elim x. - elim y. - simplify.reflexivity. - simplify.apply not_eq_OZ_pos. - simplify.apply not_eq_OZ_neg. - elim y. - simplify.unfold Not.intro.apply (not_eq_OZ_pos n).apply sym_eq.assumption. - simplify.apply eqb_elim. - intro.simplify.apply eq_f.assumption. - intro.simplify.unfold Not.intro.apply H.apply inj_pos.assumption. - simplify.apply not_eq_pos_neg. - elim y. - simplify.unfold Not.intro.apply (not_eq_OZ_neg n).apply sym_eq.assumption. - simplify.unfold Not.intro.apply (not_eq_pos_neg n1 n).apply sym_eq.assumption. - simplify.apply eqb_elim. - intro.simplify.apply eq_f.assumption. - intro.simplify.unfold Not.intro.apply H.apply inj_neg.assumption. -qed. - -theorem eqZb_elim: \forall x,y:Z.\forall P:bool \to Prop. -(x=y \to (P true)) \to (x \neq y \to (P false)) \to P (eqZb x y). -intros. -cut -(match (eqZb x y) with -[ true \Rightarrow x=y -| false \Rightarrow x \neq y] \to P (eqZb x y)). -apply Hcut. -apply eqZb_to_Prop. -elim (eqZb). -apply (H H2). -apply (H1 H2). -qed. - -definition Z_compare : Z \to Z \to compare \def -\lambda x,y:Z. - match x with - [ OZ \Rightarrow - match y with - [ OZ \Rightarrow EQ - | (pos m) \Rightarrow LT - | (neg m) \Rightarrow GT ] - | (pos n) \Rightarrow - match y with - [ OZ \Rightarrow GT - | (pos m) \Rightarrow (nat_compare n m) - | (neg m) \Rightarrow GT] - | (neg n) \Rightarrow - match y with - [ OZ \Rightarrow LT - | (pos m) \Rightarrow LT - | (neg m) \Rightarrow nat_compare m n ]]. - -theorem Z_compare_to_Prop : -\forall x,y:Z. match (Z_compare x y) with -[ LT \Rightarrow x < y -| EQ \Rightarrow x=y -| GT \Rightarrow y < x]. -intros. -elim x. - elim y. - simplify.apply refl_eq. - simplify.exact I. - simplify.exact I. - elim y. - simplify.exact I. - simplify. - cut (match (nat_compare n n1) with - [ LT \Rightarrow n Zplus_z_OZ.reflexivity. -elim y.simplify.reflexivity. -simplify. -rewrite < plus_n_Sm. rewrite < plus_n_Sm.rewrite < sym_plus.reflexivity. -simplify. -rewrite > nat_compare_n_m_m_n. -simplify.elim nat_compare.simplify.reflexivity. -simplify. reflexivity. -simplify. reflexivity. -elim y.simplify.reflexivity. -simplify.rewrite > nat_compare_n_m_m_n. -simplify.elim nat_compare.simplify.reflexivity. -simplify. reflexivity. -simplify. reflexivity. -simplify.rewrite < plus_n_Sm. rewrite < plus_n_Sm.rewrite < sym_plus.reflexivity. -qed. - -theorem Zpred_Zplus_neg_O : \forall z:Z. Zpred z = (neg O)+z. -intros.elim z. - simplify.reflexivity. - elim n. - simplify.reflexivity. - simplify.reflexivity. - simplify.reflexivity. -qed. - -theorem Zsucc_Zplus_pos_O : \forall z:Z. Zsucc z = (pos O)+z. -intros.elim z. - simplify.reflexivity. - simplify.reflexivity. - elim n. - simplify.reflexivity. - simplify.reflexivity. -qed. - -theorem Zplus_pos_pos: -\forall n,m. (pos n)+(pos m) = (Zsucc (pos n))+(Zpred (pos m)). -intros. -elim n.elim m. -simplify.reflexivity. -simplify.reflexivity. -elim m. -simplify.rewrite < plus_n_Sm. -rewrite < plus_n_O.reflexivity. -simplify.rewrite < plus_n_Sm. -rewrite < plus_n_Sm.reflexivity. -qed. - -theorem Zplus_pos_neg: -\forall n,m. (pos n)+(neg m) = (Zsucc (pos n))+(Zpred (neg m)). -intros.reflexivity. -qed. - -theorem Zplus_neg_pos : -\forall n,m. (neg n)+(pos m) = (Zsucc (neg n))+(Zpred (pos m)). -intros. -elim n.elim m. -simplify.reflexivity. -simplify.reflexivity. -elim m. -simplify.reflexivity. -simplify.reflexivity. -qed. - -theorem Zplus_neg_neg: -\forall n,m. (neg n)+(neg m) = (Zsucc (neg n))+(Zpred (neg m)). -intros. -elim n.elim m. -simplify.reflexivity. -simplify.reflexivity. -elim m. -simplify.rewrite > plus_n_Sm.reflexivity. -simplify.rewrite > plus_n_Sm.reflexivity. -qed. - -theorem Zplus_Zsucc_Zpred: -\forall x,y. x+y = (Zsucc x)+(Zpred y). -intros.elim x. - elim y. - simplify.reflexivity. - rewrite < Zsucc_Zplus_pos_O.rewrite > Zsucc_Zpred.reflexivity. - simplify.reflexivity. - elim y. - simplify.reflexivity. - apply Zplus_pos_pos. - apply Zplus_pos_neg. - elim y. - rewrite < sym_Zplus.rewrite < (sym_Zplus (Zpred OZ)). - rewrite < Zpred_Zplus_neg_O.rewrite > Zpred_Zsucc.simplify.reflexivity. - apply Zplus_neg_pos. - rewrite < Zplus_neg_neg.reflexivity. -qed. - -theorem Zplus_Zsucc_pos_pos : -\forall n,m. (Zsucc (pos n))+(pos m) = Zsucc ((pos n)+(pos m)). -intros.reflexivity. -qed. - -theorem Zplus_Zsucc_pos_neg: -\forall n,m. (Zsucc (pos n))+(neg m) = (Zsucc ((pos n)+(neg m))). -intros. -apply (nat_elim2 -(\lambda n,m. (Zsucc (pos n))+(neg m) = (Zsucc ((pos n)+(neg m))))).intro. -intros.elim n1. -simplify. reflexivity. -elim n2.simplify. reflexivity. -simplify. reflexivity. -intros. elim n1. -simplify. reflexivity. -simplify.reflexivity. -intros. -rewrite < (Zplus_pos_neg ? m1). -elim H.reflexivity. -qed. - -theorem Zplus_Zsucc_neg_neg : -\forall n,m. Zsucc (neg n) + neg m = Zsucc (neg n + neg m). -intros. -apply (nat_elim2 -(\lambda n,m. Zsucc (neg n) + neg m = Zsucc (neg n + neg m))).intro. -intros.elim n1. -simplify. reflexivity. -elim n2.simplify. reflexivity. -simplify. reflexivity. -intros. elim n1. -simplify. reflexivity. -simplify.reflexivity. -intros. -rewrite < (Zplus_neg_neg ? m1). -reflexivity. -qed. - -theorem Zplus_Zsucc_neg_pos: -\forall n,m. Zsucc (neg n)+(pos m) = Zsucc ((neg n)+(pos m)). -intros. -apply (nat_elim2 -(\lambda n,m. Zsucc (neg n) + (pos m) = Zsucc (neg n + pos m))). -intros.elim n1. -simplify. reflexivity. -elim n2.simplify. reflexivity. -simplify. reflexivity. -intros. elim n1. -simplify. reflexivity. -simplify.reflexivity. -intros. -rewrite < H. -rewrite < (Zplus_neg_pos ? (S m1)). -reflexivity. -qed. - -theorem Zplus_Zsucc : \forall x,y:Z. (Zsucc x)+y = Zsucc (x+y). -intros.elim x. - elim y. - simplify. reflexivity. - simplify.reflexivity. - rewrite < Zsucc_Zplus_pos_O.reflexivity. - elim y. - rewrite < (sym_Zplus OZ).reflexivity. - apply Zplus_Zsucc_pos_pos. - apply Zplus_Zsucc_pos_neg. - elim y. - rewrite < sym_Zplus.rewrite < (sym_Zplus OZ).simplify.reflexivity. - apply Zplus_Zsucc_neg_pos. - apply Zplus_Zsucc_neg_neg. -qed. - -theorem Zplus_Zpred: \forall x,y:Z. (Zpred x)+y = Zpred (x+y). -intros. -cut (Zpred (x+y) = Zpred ((Zsucc (Zpred x))+y)). -rewrite > Hcut. -rewrite > Zplus_Zsucc. -rewrite > Zpred_Zsucc. -reflexivity. -rewrite > Zsucc_Zpred. -reflexivity. -qed. - - -theorem associative_Zplus: associative Z Zplus. -change with (\forall x,y,z:Z. (x + y) + z = x + (y + z)). -(* simplify. *) -intros.elim x. - simplify.reflexivity. - elim n. - rewrite < Zsucc_Zplus_pos_O.rewrite < Zsucc_Zplus_pos_O. - rewrite > Zplus_Zsucc.reflexivity. - rewrite > (Zplus_Zsucc (pos n1)).rewrite > (Zplus_Zsucc (pos n1)). - rewrite > (Zplus_Zsucc ((pos n1)+y)).apply eq_f.assumption. - elim n. - rewrite < (Zpred_Zplus_neg_O (y+z)).rewrite < (Zpred_Zplus_neg_O y). - rewrite < Zplus_Zpred.reflexivity. - rewrite > (Zplus_Zpred (neg n1)).rewrite > (Zplus_Zpred (neg n1)). - rewrite > (Zplus_Zpred ((neg n1)+y)).apply eq_f.assumption. -qed. - -variant assoc_Zplus : \forall x,y,z:Z. (x+y)+z = x+(y+z) -\def associative_Zplus. - -(* Zopp *) -definition Zopp : Z \to Z \def -\lambda x:Z. match x with -[ OZ \Rightarrow OZ -| (pos n) \Rightarrow (neg n) -| (neg n) \Rightarrow (pos n) ]. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "integer unary minus" 'uminus x = (cic:/matita/Z/plus/Zopp.con x). - -theorem Zopp_Zplus: \forall x,y:Z. -(x+y) = -x + -y. -intros. -elim x.elim y. -simplify. reflexivity. -simplify. reflexivity. -simplify. reflexivity. -elim y. -simplify. reflexivity. -simplify. reflexivity. -simplify. apply nat_compare_elim. -intro.simplify.reflexivity. -intro.simplify.reflexivity. -intro.simplify.reflexivity. -elim y. -simplify. reflexivity. -simplify. apply nat_compare_elim. -intro.simplify.reflexivity. -intro.simplify.reflexivity. -intro.simplify.reflexivity. -simplify.reflexivity. -qed. - -theorem Zopp_Zopp: \forall x:Z. --x = x. -intro. elim x. -reflexivity.reflexivity.reflexivity. -qed. - -theorem Zplus_Zopp: \forall x:Z. x+ -x = OZ. -intro.elim x. -apply refl_eq. -simplify. -rewrite > nat_compare_n_n. -simplify.apply refl_eq. -simplify. -rewrite > nat_compare_n_n. -simplify.apply refl_eq. -qed. - diff --git a/helm/matita/library/Z/times.ma b/helm/matita/library/Z/times.ma deleted file mode 100644 index e5e1cdb45..000000000 --- a/helm/matita/library/Z/times.ma +++ /dev/null @@ -1,235 +0,0 @@ -(**************************************************************************) -(* __ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/Z/times". - -include "nat/lt_arith.ma". -include "Z/plus.ma". - -definition Ztimes :Z \to Z \to Z \def -\lambda x,y. - match x with - [ OZ \Rightarrow OZ - | (pos m) \Rightarrow - match y with - [ OZ \Rightarrow OZ - | (pos n) \Rightarrow (pos (pred ((S m) * (S n)))) - | (neg n) \Rightarrow (neg (pred ((S m) * (S n))))] - | (neg m) \Rightarrow - match y with - [ OZ \Rightarrow OZ - | (pos n) \Rightarrow (neg (pred ((S m) * (S n)))) - | (neg n) \Rightarrow (pos (pred ((S m) * (S n))))]]. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "integer times" 'times x y = (cic:/matita/Z/times/Ztimes.con x y). - -theorem Ztimes_z_OZ: \forall z:Z. z*OZ = OZ. -intro.elim z. -simplify.reflexivity. -simplify.reflexivity. -simplify.reflexivity. -qed. - -theorem Ztimes_neg_Zopp: \forall n:nat.\forall x:Z. -neg n * x = - (pos n * x). -intros.elim x. -simplify.reflexivity. -simplify.reflexivity. -simplify.reflexivity. -qed. -theorem symmetric_Ztimes : symmetric Z Ztimes. -change with (\forall x,y:Z. x*y = y*x). -intros.elim x.rewrite > Ztimes_z_OZ.reflexivity. -elim y.simplify.reflexivity. -change with (pos (pred ((S n) * (S n1))) = pos (pred ((S n1) * (S n)))). -rewrite < sym_times.reflexivity. -change with (neg (pred ((S n) * (S n1))) = neg (pred ((S n1) * (S n)))). -rewrite < sym_times.reflexivity. -elim y.simplify.reflexivity. -change with (neg (pred ((S n) * (S n1))) = neg (pred ((S n1) * (S n)))). -rewrite < sym_times.reflexivity. -change with (pos (pred ((S n) * (S n1))) = pos (pred ((S n1) * (S n)))). -rewrite < sym_times.reflexivity. -qed. - -variant sym_Ztimes : \forall x,y:Z. x*y = y*x -\def symmetric_Ztimes. - -theorem associative_Ztimes: associative Z Ztimes. -change with (\forall x,y,z:Z. (x*y)*z = x*(y*z)). -intros.elim x. - simplify.reflexivity. - elim y. - simplify.reflexivity. - elim z. - simplify.reflexivity. - change with - (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - pos (pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - change with - (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - neg (pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - elim z. - simplify.reflexivity. - change with - (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - neg (pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - change with - (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - pos(pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - elim y. - simplify.reflexivity. - elim z. - simplify.reflexivity. - change with - (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - neg (pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - change with - (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - pos (pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - elim z. - simplify.reflexivity. - change with - (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - pos (pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. - change with - (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = - neg(pred ((S n) * (S (pred ((S n1) * (S n2))))))). - rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. - apply lt_O_times_S_S.apply lt_O_times_S_S. -qed. - -variant assoc_Ztimes : \forall x,y,z:Z. -(x * y) * z = x * (y * z) \def -associative_Ztimes. - -lemma times_minus1: \forall n,p,q:nat. lt q p \to -(S n) * (S (pred ((S p) - (S q)))) = -pred ((S n) * (S p)) - pred ((S n) * (S q)). -intros. -rewrite < S_pred. -rewrite > minus_pred_pred. -rewrite < distr_times_minus. -reflexivity. -(* we now close all positivity conditions *) -apply lt_O_times_S_S. -apply lt_O_times_S_S. -simplify.unfold lt. -apply le_SO_minus. exact H. -qed. - -lemma Ztimes_Zplus_pos_neg_pos: \forall n,p,q:nat. -(pos n)*((neg p)+(pos q)) = (pos n)*(neg p)+ (pos n)*(pos q). -intros. -simplify. -change in match (p + n * (S p)) with (pred ((S n) * (S p))). -change in match (q + n * (S q)) with (pred ((S n) * (S q))). -rewrite < nat_compare_pred_pred. -rewrite < nat_compare_times_l. -rewrite < nat_compare_S_S. -apply (nat_compare_elim p q). -intro. -(* uff *) -change with (pos (pred ((S n) * (S (pred ((S q) - (S p)))))) = - pos (pred ((pred ((S n) * (S q))) - (pred ((S n) * (S p)))))). -rewrite < (times_minus1 n q p H).reflexivity. -intro.rewrite < H.simplify.reflexivity. -intro. -change with (neg (pred ((S n) * (S (pred ((S p) - (S q)))))) = - neg (pred ((pred ((S n) * (S p))) - (pred ((S n) * (S q)))))). -rewrite < (times_minus1 n p q H).reflexivity. -(* two more positivity conditions from nat_compare_pred_pred *) -apply lt_O_times_S_S. -apply lt_O_times_S_S. -qed. - -lemma Ztimes_Zplus_pos_pos_neg: \forall n,p,q:nat. -(pos n)*((pos p)+(neg q)) = (pos n)*(pos p)+ (pos n)*(neg q). -intros. -rewrite < sym_Zplus. -rewrite > Ztimes_Zplus_pos_neg_pos. -apply sym_Zplus. -qed. - -lemma distributive2_Ztimes_pos_Zplus: -distributive2 nat Z (\lambda n,z. (pos n) * z) Zplus. -change with (\forall n,y,z. -(pos n) * (y + z) = (pos n) * y + (pos n) * z). -intros.elim y. - reflexivity. - elim z. - reflexivity. - change with - (pos (pred ((S n) * ((S n1) + (S n2)))) = - pos (pred ((S n) * (S n1) + (S n) * (S n2)))). - rewrite < distr_times_plus.reflexivity. - apply Ztimes_Zplus_pos_pos_neg. - elim z. - reflexivity. - apply Ztimes_Zplus_pos_neg_pos. - change with - (neg (pred ((S n) * ((S n1) + (S n2)))) = - neg (pred ((S n) * (S n1) + (S n) * (S n2)))). - rewrite < distr_times_plus.reflexivity. -qed. - -variant distr_Ztimes_Zplus_pos: \forall n,y,z. -(pos n) * (y + z) = ((pos n) * y + (pos n) * z) \def -distributive2_Ztimes_pos_Zplus. - -lemma distributive2_Ztimes_neg_Zplus : -distributive2 nat Z (\lambda n,z. (neg n) * z) Zplus. -change with (\forall n,y,z. -(neg n) * (y + z) = (neg n) * y + (neg n) * z). -intros. -rewrite > Ztimes_neg_Zopp. -rewrite > distr_Ztimes_Zplus_pos. -rewrite > Zopp_Zplus. -rewrite < Ztimes_neg_Zopp. rewrite < Ztimes_neg_Zopp. -reflexivity. -qed. - -variant distr_Ztimes_Zplus_neg: \forall n,y,z. -(neg n) * (y + z) = (neg n) * y + (neg n) * z \def -distributive2_Ztimes_neg_Zplus. - -theorem distributive_Ztimes_Zplus: distributive Z Ztimes Zplus. -change with (\forall x,y,z:Z. x * (y + z) = x*y + x*z). -intros.elim x. -(* case x = OZ *) -simplify.reflexivity. -(* case x = pos n *) -apply distr_Ztimes_Zplus_pos. -(* case x = neg n *) -apply distr_Ztimes_Zplus_neg. -qed. - -variant distr_Ztimes_Zplus: \forall x,y,z. -x * (y + z) = x*y + x*z \def -distributive_Ztimes_Zplus. diff --git a/helm/matita/library/Z/z.ma b/helm/matita/library/Z/z.ma deleted file mode 100644 index ea50a2cd9..000000000 --- a/helm/matita/library/Z/z.ma +++ /dev/null @@ -1,173 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/Z/z". - -include "datatypes/bool.ma". -include "nat/nat.ma". - -inductive Z : Set \def - OZ : Z -| pos : nat \to Z -| neg : nat \to Z. - -definition Z_of_nat \def -\lambda n. match n with -[ O \Rightarrow OZ -| (S n)\Rightarrow pos n]. - -coercion cic:/matita/Z/z/Z_of_nat.con. - -definition neg_Z_of_nat \def -\lambda n. match n with -[ O \Rightarrow OZ -| (S n)\Rightarrow neg n]. - -definition abs \def -\lambda z. - match z with -[ OZ \Rightarrow O -| (pos n) \Rightarrow n -| (neg n) \Rightarrow n]. - -definition OZ_test \def -\lambda z. -match z with -[ OZ \Rightarrow true -| (pos n) \Rightarrow false -| (neg n) \Rightarrow false]. - -theorem OZ_test_to_Prop :\forall z:Z. -match OZ_test z with -[true \Rightarrow z=OZ -|false \Rightarrow z \neq OZ]. -intros.elim z. -simplify.reflexivity. -simplify. unfold Not. intros (H). -discriminate H. -simplify. unfold Not. intros (H). -discriminate H. -qed. - -(* discrimination *) -theorem injective_pos: injective nat Z pos. -unfold injective. -intros. -change with (abs (pos x) = abs (pos y)). -apply eq_f.assumption. -qed. - -variant inj_pos : \forall n,m:nat. pos n = pos m \to n = m -\def injective_pos. - -theorem injective_neg: injective nat Z neg. -unfold injective. -intros. -change with (abs (neg x) = abs (neg y)). -apply eq_f.assumption. -qed. - -variant inj_neg : \forall n,m:nat. neg n = neg m \to n = m -\def injective_neg. - -theorem not_eq_OZ_pos: \forall n:nat. OZ \neq pos n. -unfold Not.intros (n H). -discriminate H. -qed. - -theorem not_eq_OZ_neg :\forall n:nat. OZ \neq neg n. -unfold Not.intros (n H). -discriminate H. -qed. - -theorem not_eq_pos_neg :\forall n,m:nat. pos n \neq neg m. -unfold Not.intros (n m H). -discriminate H. -qed. - -theorem decidable_eq_Z : \forall x,y:Z. decidable (x=y). -intros.unfold decidable. -elim x. -(* goal: x=OZ *) - elim y. - (* goal: x=OZ y=OZ *) - left.reflexivity. - (* goal: x=OZ 2=2 *) - right.apply not_eq_OZ_pos. - (* goal: x=OZ 2=3 *) - right.apply not_eq_OZ_neg. -(* goal: x=pos *) - elim y. - (* goal: x=pos y=OZ *) - right.unfold Not.intro. - apply (not_eq_OZ_pos n). symmetry. assumption. - (* goal: x=pos y=pos *) - elim (decidable_eq_nat n n1:((n=n1) \lor ((n=n1) \to False))). - left.apply eq_f.assumption. - right.unfold Not.intros (H_inj).apply H. injection H_inj. assumption. - (* goal: x=pos y=neg *) - right.unfold Not.intro.apply (not_eq_pos_neg n n1). assumption. -(* goal: x=neg *) - elim y. - (* goal: x=neg y=OZ *) - right.unfold Not.intro. - apply (not_eq_OZ_neg n). symmetry. assumption. - (* goal: x=neg y=pos *) - right. unfold Not.intro. apply (not_eq_pos_neg n1 n). symmetry. assumption. - (* goal: x=neg y=neg *) - elim (decidable_eq_nat n n1:((n=n1) \lor ((n=n1) \to False))). - left.apply eq_f.assumption. - right.unfold Not.intro.apply H.apply injective_neg.assumption. -qed. - -(* end discrimination *) - -definition Zsucc \def -\lambda z. match z with -[ OZ \Rightarrow pos O -| (pos n) \Rightarrow pos (S n) -| (neg n) \Rightarrow - match n with - [ O \Rightarrow OZ - | (S p) \Rightarrow neg p]]. - -definition Zpred \def -\lambda z. match z with -[ OZ \Rightarrow neg O -| (pos n) \Rightarrow - match n with - [ O \Rightarrow OZ - | (S p) \Rightarrow pos p] -| (neg n) \Rightarrow neg (S n)]. - -theorem Zpred_Zsucc: \forall z:Z. Zpred (Zsucc z) = z. -intros. -elim z. - reflexivity. - reflexivity. - elim n. - reflexivity. - reflexivity. -qed. - -theorem Zsucc_Zpred: \forall z:Z. Zsucc (Zpred z) = z. -intros. -elim z. - reflexivity. - elim n. - reflexivity. - reflexivity. - reflexivity. -qed. - diff --git a/helm/matita/library/algebra/groups.ma b/helm/matita/library/algebra/groups.ma deleted file mode 100644 index 04a00c6f7..000000000 --- a/helm/matita/library/algebra/groups.ma +++ /dev/null @@ -1,610 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/algebra/groups/". - -include "algebra/monoids.ma". -include "nat/le_arith.ma". -include "datatypes/bool.ma". -include "nat/compare.ma". - -record PreGroup : Type ≝ - { premonoid:> PreMonoid; - opp: premonoid -> premonoid - }. - -record isGroup (G:PreGroup) : Prop ≝ - { is_monoid: isMonoid G; - opp_is_left_inverse: is_left_inverse (mk_Monoid ? is_monoid) (opp G); - opp_is_right_inverse: is_right_inverse (mk_Monoid ? is_monoid) (opp G) - }. - -record Group : Type ≝ - { pregroup:> PreGroup; - group_properties:> isGroup pregroup - }. - -(*notation < "G" -for @{ 'monoid $G }. - -interpretation "Monoid coercion" 'monoid G = - (cic:/matita/algebra/groups/monoid.con G).*) - -notation < "G" -for @{ 'type_of_group $G }. - -interpretation "Type_of_group coercion" 'type_of_group G = - (cic:/matita/algebra/groups/Type_of_Group.con G). - -notation < "G" -for @{ 'magma_of_group $G }. - -interpretation "magma_of_group coercion" 'magma_of_group G = - (cic:/matita/algebra/groups/Magma_of_Group.con G). - -notation "hvbox(x \sup (-1))" with precedence 89 -for @{ 'gopp $x }. - -interpretation "Group inverse" 'gopp x = - (cic:/matita/algebra/groups/opp.con _ x). - -definition left_cancellable ≝ - λT:Type. λop: T -> T -> T. - ∀x. injective ? ? (op x). - -definition right_cancellable ≝ - λT:Type. λop: T -> T -> T. - ∀x. injective ? ? (λz.op z x). - -theorem eq_op_x_y_op_x_z_to_eq: - ∀G:Group. left_cancellable G (op G). -intros; -unfold left_cancellable; -unfold injective; -intros (x y z); -rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G))); -rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G)) z); -rewrite < (opp_is_left_inverse ? (group_properties G) x); -rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); -rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); -apply eq_f; -assumption. -qed. - - -theorem eq_op_x_y_op_z_y_to_eq: - ∀G:Group. right_cancellable G (op G). -intros; -unfold right_cancellable; -unfold injective; -simplify;fold simplify (op G); -intros (x y z); -rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G))); -rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G)) z); -rewrite < (opp_is_right_inverse ? (group_properties G) x); -rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); -rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); -rewrite > H; -reflexivity. -qed. - - -record finite_enumerable (T:Type) : Type ≝ - { order: nat; - repr: nat → T; - index_of: T → nat; - index_of_sur: ∀x.index_of x ≤ order; - index_of_repr: ∀n. n≤order → index_of (repr n) = n; - repr_index_of: ∀x. repr (index_of x) = x - }. - -notation "hvbox(C \sub i)" with precedence 89 -for @{ 'repr $C $i }. - -(* CSC: multiple interpretations in the same file are not considered in the - right order -interpretation "Finite_enumerable representation" 'repr C i = - (cic:/matita/algebra/groups/repr.con C _ i).*) - -notation < "hvbox(|C|)" with precedence 89 -for @{ 'card $C }. - -interpretation "Finite_enumerable order" 'card C = - (cic:/matita/algebra/groups/order.con C _). - -record finite_enumerable_SemiGroup : Type ≝ - { semigroup:> SemiGroup; - is_finite_enumerable:> finite_enumerable semigroup - }. - -notation < "S" -for @{ 'semigroup_of_finite_enumerable_semigroup $S }. - -interpretation "Semigroup_of_finite_enumerable_semigroup" - 'semigroup_of_finite_enumerable_semigroup S -= - (cic:/matita/algebra/groups/semigroup.con S). - -notation < "S" -for @{ 'magma_of_finite_enumerable_semigroup $S }. - -interpretation "Magma_of_finite_enumerable_semigroup" - 'magma_of_finite_enumerable_semigroup S -= - (cic:/matita/algebra/groups/Magma_of_finite_enumerable_SemiGroup.con S). - -notation < "S" -for @{ 'type_of_finite_enumerable_semigroup $S }. - -interpretation "Type_of_finite_enumerable_semigroup" - 'type_of_finite_enumerable_semigroup S -= - (cic:/matita/algebra/groups/Type_of_finite_enumerable_SemiGroup.con S). - -interpretation "Finite_enumerable representation" 'repr S i = - (cic:/matita/algebra/groups/repr.con S - (cic:/matita/algebra/groups/is_finite_enumerable.con S) i). - -notation "hvbox(ι e)" with precedence 60 -for @{ 'index_of_finite_enumerable_semigroup $e }. - -interpretation "Index_of_finite_enumerable representation" - 'index_of_finite_enumerable_semigroup e -= - (cic:/matita/algebra/groups/index_of.con _ - (cic:/matita/algebra/groups/is_finite_enumerable.con _) e). - - -(* several definitions/theorems to be moved somewhere else *) - -definition ltb ≝ λn,m. leb n m ∧ notb (eqb n m). - -theorem not_eq_to_le_to_lt: ∀n,m. n≠m → n≤m → n (S_pred m); - [ apply le_S_S; - assumption - | assumption - ] -]. -qed. - -theorem le_to_le_pred: - ∀n,m. n ≤ m → pred n ≤ pred m. -intros 2; -elim n; -[ simplify; - apply le_O_n -| simplify; - generalize in match H1; - clear H1; - elim m; - [ elim (not_le_Sn_O ? H1) - | simplify; - apply le_S_S_to_le; - assumption - ] -]. -qed. - -theorem lt_n_m_to_not_lt_m_Sn: ∀n,m. n < m → m ≮ S n. -intros; -unfold Not; -intro; -unfold lt in H; -unfold lt in H1; -generalize in match (le_S_S ? ? H); -intro; -generalize in match (transitive_le ? ? ? H2 H1); -intro; -apply (not_le_Sn_n ? H3). -qed. - -theorem lt_S_S: ∀n,m. n < m → S n < S m. -intros; -unfold lt in H; -apply (le_S_S ? ? H). -qed. - -theorem lt_O_S: ∀n. O < S n. -intro; -unfold lt; -apply le_S_S; -apply le_O_n. -qed. - -theorem le_n_m_to_lt_m_Sn_to_eq_n_m: ∀n,m. n ≤ m → m < S n → n=m. -intros; -unfold lt in H1; -generalize in match (le_S_S_to_le ? ? H1); -intro; -apply cic:/matita/nat/orders/antisym_le.con; -assumption. -qed. - -theorem pigeonhole: - ∀n:nat.∀f:nat→nat. - (∀x,y.x≤n → y≤n → f x = f y → x=y) → - (∀m. m ≤ n → f m ≤ n) → - ∀x. x≤n \to ∃y.f y = x ∧ y ≤ n. -intro; -elim n; -[ apply (ex_intro ? ? O); - split; - [ rewrite < (le_n_O_to_eq ? H2); - rewrite < (le_n_O_to_eq ? (H1 O ?)); - [ reflexivity - | apply le_n - ] - | apply le_n - ] -| clear n; - letin f' ≝ - (λx. - let fSn1 ≝ f (S n1) in - let fx ≝ f x in - match ltb fSn1 fx with - [ true ⇒ pred fx - | false ⇒ fx - ]); - cut (∀x,y. x ≤ n1 → y ≤ n1 → f' x = f' y → x=y); - [ cut (∀x. x ≤ n1 → f' x ≤ n1); - [ apply (nat_compare_elim (f (S n1)) x); - [ intro; - elim (H f' ? ? (pred x)); - [ simplify in H5; - clear Hcut; - clear Hcut1; - clear f'; - elim H5; - clear H5; - apply (ex_intro ? ? a); - split; - [ generalize in match (eq_f ? ? S ? ? H6); - clear H6; - intro; - rewrite < S_pred in H5; - [ generalize in match H4; - clear H4; - rewrite < H5; - clear H5; - apply (ltb_elim (f (S n1)) (f a)); - [ simplify; - intros; - rewrite < S_pred; - [ reflexivity - | apply (ltn_to_ltO ? ? H4) - ] - | simplify; - intros; - generalize in match (not_lt_to_le ? ? H4); - clear H4; - intro; - generalize in match (le_n_m_to_lt_m_Sn_to_eq_n_m ? ? H6 H5); - intro; - generalize in match (H1 ? ? ? ? H4); - [ intro; - | - | - ] - ] - | apply (ltn_to_ltO ? ? H4) - ] - | apply le_S; - assumption - ] - | apply Hcut - | apply Hcut1 - | apply le_S_S_to_le; - rewrite < S_pred; - exact H3 - ] - (* TODO: caso complicato, ma simile al terzo *) - | intros; - apply (ex_intro ? ? (S n1)); - split; - [ assumption - | constructor 1 - ] - | intro; - elim (H f' ? ? x); - [ simplify in H5; - clear Hcut; - clear Hcut1; - clear f'; - elim H5; - clear H5; - apply (ex_intro ? ? a); - split; - [ generalize in match H4; - clear H4; - rewrite < H6; - clear H6; - apply (ltb_elim (f (S n1)) (f a)); - [ simplify; - intros; - generalize in match (lt_S_S ? ? H5); - intro; - rewrite < S_pred in H6; - [ elim (lt_n_m_to_not_lt_m_Sn ? ? H4 H6) - | apply (ltn_to_ltO ? ? H4) - ] - | simplify; - intros; - reflexivity - ] - | apply le_S; - assumption - ] - | apply Hcut - | apply Hcut1 - | rewrite > (pred_Sn n1); - simplify; - generalize in match (H2 (S n1)); - intro; - generalize in match (lt_to_le_to_lt ? ? ? H4 (H5 (le_n ?))); - intro; - unfold lt in H6; - apply le_S_S_to_le; - assumption - ] - ] - | unfold f'; - simplify; - intro; - apply (ltb_elim (f (S n1)) (f x1)); - simplify; - intros; - [ generalize in match (H2 x1); - intro; - change in match n1 with (pred (S n1)); - apply le_to_le_pred; - apply H6; - apply le_S; - assumption - | generalize in match (H2 (S n1) (le_n ?)); - intro; - generalize in match (not_lt_to_le ? ? H4); - intro; - generalize in match (transitive_le ? ? ? H7 H6); - intro; - cut (f x1 ≠ f (S n1)); - [ generalize in match (not_eq_to_le_to_lt ? ? Hcut1 H7); - intro; - unfold lt in H9; - generalize in match (transitive_le ? ? ? H9 H6); - intro; - apply le_S_S_to_le; - assumption - | unfold Not; - intro; - generalize in match (H1 ? ? ? ? H9); - [ intro; - rewrite > H10 in H5; - apply (not_le_Sn_n ? H5) - | apply le_S; - assumption - | apply le_n - ] - ] - ] - ] - | intros 4; - unfold f'; - simplify; - apply (ltb_elim (f (S n1)) (f x1)); - simplify; - apply (ltb_elim (f (S n1)) (f y)); - simplify; - intros; - [ cut (f x1 = f y); - [ apply (H1 ? ? ? ? Hcut); - apply le_S; - assumption - | apply eq_pred_to_eq; - [ apply (ltn_to_ltO ? ? H7) - | apply (ltn_to_ltO ? ? H6) - | assumption - ] - ] - | (* pred (f x1) = f y absurd since y ≠ S n1 and thus f y ≠ f (S n1) - so that f y < f (S n1) < f x1; hence pred (f x1) = f y is absurd *) - cut (y < S n1); - [ generalize in match (lt_to_not_eq ? ? Hcut); - intro; - cut (f y ≠ f (S n1)); - [ cut (f y < f (S n1)); - [ rewrite < H8 in Hcut2; - unfold lt in Hcut2; - unfold lt in H7; - generalize in match (le_S_S ? ? Hcut2); - intro; - generalize in match (transitive_le ? ? ? H10 H7); - intros; - rewrite < (S_pred (f x1)) in H11; - [ elim (not_le_Sn_n ? H11) - | fold simplify ((f (S n1)) < (f x1)) in H7; - apply (ltn_to_ltO ? ? H7) - ] - | apply not_eq_to_le_to_lt; - [ assumption - | apply not_lt_to_le; - assumption - ] - ] - | unfold Not; - intro; - apply H9; - apply (H1 ? ? ? ? H10); - [ apply lt_to_le; - assumption - | constructor 1 - ] - ] - | unfold lt; - apply le_S_S; - assumption - ] - | (* f x1 = pred (f y) absurd since it implies S (f x1) = f y and - f x1 ≤ f (S n1) < f y = S (f x1) so that f x1 = f (S n1); by - injectivity x1 = S n1 that is absurd since x1 ≤ n1 *) - generalize in match (eq_f ? ? S ? ? H8); - intro; - rewrite < S_pred in H9; - [ rewrite < H9 in H6; - generalize in match (not_lt_to_le ? ? H7); - intro; - unfold lt in H6; - generalize in match (le_S_S ? ? H10); - intro; - generalize in match (antisym_le ? ? H11 H6); - intro; - generalize in match (inj_S ? ? H12); - intro; - generalize in match (H1 ? ? ? ? H13); - [ intro; - rewrite > H14 in H4; - elim (not_le_Sn_n ? H4) - | apply le_S; - assumption - | apply le_n - ] - | apply (ltn_to_ltO ? ? H6) - ] - | apply (H1 ? ? ? ? H8); - apply le_S; - assumption - ] - ] -]. -qed. - -theorem foo: - ∀G:finite_enumerable_SemiGroup. - left_cancellable ? (op G) → - right_cancellable ? (op G) → - ∃e:G. isMonoid (mk_PreMonoid G e). -intros; -letin f ≝ (λn.ι(G \sub O · G \sub n)); -cut (∀n.n ≤ order ? (is_finite_enumerable G) → ∃m.f m = n); -[ letin EX ≝ (Hcut O ?); - [ apply le_O_n - | clearbody EX; - clear Hcut; - unfold f in EX; - elim EX; - clear EX; - letin HH ≝ (eq_f ? ? (repr ? (is_finite_enumerable G)) ? ? H2); - clearbody HH; - rewrite > (repr_index_of ? (is_finite_enumerable G)) in HH; - apply (ex_intro ? ? (G \sub a)); - letin GOGO ≝ (refl_eq ? (repr ? (is_finite_enumerable G) O)); - clearbody GOGO; - rewrite < HH in GOGO; - rewrite < HH in GOGO:(? ? % ?); - rewrite > (associative ? G) in GOGO; - letin GaGa ≝ (H ? ? ? GOGO); - clearbody GaGa; - clear GOGO; - constructor 1; - [ simplify; - apply (semigroup_properties G) - | unfold is_left_unit; intro; - letin GaxGax ≝ (refl_eq ? (G \sub a ·x)); - clearbody GaxGax; - rewrite < GaGa in GaxGax:(? ? % ?); - rewrite > (associative ? (semigroup_properties G)) in GaxGax; - apply (H ? ? ? GaxGax) - | unfold is_right_unit; intro; - letin GaxGax ≝ (refl_eq ? (x·G \sub a)); - clearbody GaxGax; - rewrite < GaGa in GaxGax:(? ? % ?); - rewrite < (associative ? (semigroup_properties G)) in GaxGax; - apply (H1 ? ? ? GaxGax) - ] - ] -| apply pigeonhole -]. diff --git a/helm/matita/library/algebra/monoids.ma b/helm/matita/library/algebra/monoids.ma deleted file mode 100644 index c3f3cc48e..000000000 --- a/helm/matita/library/algebra/monoids.ma +++ /dev/null @@ -1,85 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/algebra/monoids/". - -include "algebra/semigroups.ma". - -record PreMonoid : Type ≝ - { magma:> Magma; - e: magma - }. - -notation < "M" for @{ 'pmmagma $M }. -interpretation "premonoid magma coercion" 'pmmagma M = - (cic:/matita/algebra/monoids/magma.con M). - -record isMonoid (M:PreMonoid) : Prop ≝ - { is_semi_group: isSemiGroup M; - e_is_left_unit: - is_left_unit (mk_SemiGroup ? is_semi_group) (e M); - e_is_right_unit: - is_right_unit (mk_SemiGroup ? is_semi_group) (e M) - }. - -record Monoid : Type ≝ - { premonoid:> PreMonoid; - monoid_properties:> isMonoid premonoid - }. - -notation < "M" for @{ 'semigroup $M }. -interpretation "premonoid coercion" 'premonoid M = - (cic:/matita/algebra/monoids/premonoid.con M). - -notation < "M" for @{ 'typeofmonoid $M }. -interpretation "premonoid coercion" 'typeofmonoid M = - (cic:/matita/algebra/monoids/Type_of_Monoid.con M). - -notation < "M" for @{ 'magmaofmonoid $M }. -interpretation "premonoid coercion" 'magmaofmonoid M = - (cic:/matita/algebra/monoids/Magma_of_Monoid.con M). - -notation "1" with precedence 89 -for @{ 'munit }. - -interpretation "Monoid unit" 'munit = - (cic:/matita/algebra/monoids/e.con _). - -definition is_left_inverse ≝ - λM:Monoid. - λopp: M → M. - ∀x:M. (opp x)·x = 1. - -definition is_right_inverse ≝ - λM:Monoid. - λopp: M → M. - ∀x:M. x·(opp x) = 1. - -theorem is_left_inverse_to_is_right_inverse_to_eq: - ∀M:Monoid. ∀l,r. - is_left_inverse M l → is_right_inverse M r → - ∀x:M. l x = r x. - intros; - generalize in match (H x); intro; - generalize in match (eq_f ? ? (λy.y·(r x)) ? ? H2); - simplify; fold simplify (op M); - intro; clear H2; - generalize in match (associative ? (is_semi_group ? (monoid_properties M))); - intro; - rewrite > H2 in H3; clear H2; - rewrite > H1 in H3; - rewrite > (e_is_left_unit ? (monoid_properties M)) in H3; - rewrite > (e_is_right_unit ? (monoid_properties M)) in H3; - assumption. -qed. diff --git a/helm/matita/library/algebra/semigroups.ma b/helm/matita/library/algebra/semigroups.ma deleted file mode 100644 index 5b461d1a4..000000000 --- a/helm/matita/library/algebra/semigroups.ma +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/algebra/semigroups". - -include "higher_order_defs/functions.ma". - -(* Magmas *) - -record Magma : Type ≝ - { carrier:> Type; - op: carrier → carrier → carrier - }. - -notation < "M" for @{ 'carrier $M }. -interpretation "carrier coercion" 'carrier S = - (cic:/matita/algebra/semigroups/carrier.con S). - -notation "hvbox(a break \middot b)" - left associative with precedence 55 -for @{ 'magma_op $a $b }. - -interpretation "magma operation" 'magma_op a b = - (cic:/matita/algebra/semigroups/op.con _ a b). - -(* Semigroups *) - -record isSemiGroup (M:Magma) : Prop ≝ - { associative: associative ? (op M) }. - -record SemiGroup : Type ≝ - { magma:> Magma; - semigroup_properties:> isSemiGroup magma - }. - -notation < "S" for @{ 'magma $S }. -interpretation "magma coercion" 'magma S = - (cic:/matita/algebra/semigroups/magma.con S). - -definition is_left_unit ≝ - λS:SemiGroup. λe:S. ∀x:S. e·x = x. - -definition is_right_unit ≝ - λS:SemiGroup. λe:S. ∀x:S. x·e = x. - -theorem is_left_unit_to_is_right_unit_to_eq: - ∀S:SemiGroup. ∀e,e':S. - is_left_unit ? e → is_right_unit ? e' → e=e'. - intros; - rewrite < (H e'); - rewrite < (H1 e) in \vdash (? ? % ?); - reflexivity. -qed. diff --git a/helm/matita/library/datatypes/bool.ma b/helm/matita/library/datatypes/bool.ma deleted file mode 100644 index 3292e6789..000000000 --- a/helm/matita/library/datatypes/bool.ma +++ /dev/null @@ -1,126 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/datatypes/bool/". - -include "logic/equality.ma". - -inductive bool : Set \def - | true : bool - | false : bool. - -theorem bool_elim: \forall P:bool \to Prop. \forall b:bool. - (b = true \to P true) - \to (b = false \to P false) - \to P b. - intros 2 (P b). - elim b; - [ apply H; reflexivity - | apply H1; reflexivity - ] -qed. - -theorem not_eq_true_false : true \neq false. -unfold Not.intro. -change with -match true with -[ true \Rightarrow False -| flase \Rightarrow True]. -rewrite > H.simplify.exact I. -qed. - -definition notb : bool \to bool \def -\lambda b:bool. - match b with - [ true \Rightarrow false - | false \Rightarrow true ]. - -theorem notb_elim: \forall b:bool.\forall P:bool \to Prop. -match b with -[ true \Rightarrow P false -| false \Rightarrow P true] \to P (notb b). -intros 2.elim b.exact H. exact H. -qed. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "boolean not" 'not x = (cic:/matita/datatypes/bool/notb.con x). - -definition andb : bool \to bool \to bool\def -\lambda b1,b2:bool. - match b1 with - [ true \Rightarrow b2 - | false \Rightarrow false ]. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "boolean and" 'and x y = (cic:/matita/datatypes/bool/andb.con x y). - -theorem andb_elim: \forall b1,b2:bool. \forall P:bool \to Prop. -match b1 with -[ true \Rightarrow P b2 -| false \Rightarrow P false] \to P (b1 \land b2). -intros 3.elim b1.exact H. exact H. -qed. - -theorem andb_true_true: \forall b1,b2. (b1 \land b2) = true \to b1 = true. -intro. elim b1. -reflexivity. -assumption. -qed. - -definition orb : bool \to bool \to bool\def -\lambda b1,b2:bool. - match b1 with - [ true \Rightarrow true - | false \Rightarrow b2]. - -theorem orb_elim: \forall b1,b2:bool. \forall P:bool \to Prop. -match b1 with -[ true \Rightarrow P true -| false \Rightarrow P b2] \to P (orb b1 b2). -intros 3.elim b1.exact H. exact H. -qed. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "boolean or" 'or x y = (cic:/matita/datatypes/bool/orb.con x y). - -definition if_then_else : bool \to Prop \to Prop \to Prop \def -\lambda b:bool.\lambda P,Q:Prop. -match b with -[ true \Rightarrow P -| false \Rightarrow Q]. - -(*CSC: missing notation for if_then_else *) - -theorem bool_to_decidable_eq: - \forall b1,b2:bool. decidable (b1=b2). - intros. - unfold decidable. - elim b1. - elim b2. - left. reflexivity. - right. exact not_eq_true_false. - elim b2. - right. unfold Not. intro. - apply not_eq_true_false. - symmetry. exact H. - left. reflexivity. -qed. - -theorem P_x_to_P_x_to_eq: - \forall A:Set. \forall P: A \to bool. - \forall x:A. \forall p1,p2:P x = true. p1 = p2. - intros. - apply eq_to_eq_to_eq_p_q. - exact bool_to_decidable_eq. -qed. diff --git a/helm/matita/library/datatypes/compare.ma b/helm/matita/library/datatypes/compare.ma deleted file mode 100644 index c4fd119a5..000000000 --- a/helm/matita/library/datatypes/compare.ma +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/datatypes/compare/". - -inductive compare :Set \def -| LT : compare -| EQ : compare -| GT : compare. - -definition compare_invert: compare \to compare \def - \lambda c. - match c with - [ LT \Rightarrow GT - | EQ \Rightarrow EQ - | GT \Rightarrow LT ]. diff --git a/helm/matita/library/datatypes/constructors.ma b/helm/matita/library/datatypes/constructors.ma deleted file mode 100644 index 2ac1cb376..000000000 --- a/helm/matita/library/datatypes/constructors.ma +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/datatypes/constructors/". -include "logic/equality.ma". - -inductive void : Set \def. - -inductive Prod (A,B:Set) : Set \def -pair : A \to B \to Prod A B. - -definition fst \def \lambda A,B:Set.\lambda p: Prod A B. -match p with -[(pair a b) \Rightarrow a]. - -definition snd \def \lambda A,B:Set.\lambda p: Prod A B. -match p with -[(pair a b) \Rightarrow b]. - -theorem eq_pair_fst_snd: \forall A,B:Set.\forall p: Prod A B. -p = pair A B (fst A B p) (snd A B p). -intros.elim p.simplify.reflexivity. -qed. - -inductive Sum (A,B:Set) : Set \def - inl : A \to Sum A B -| inr : B \to Sum A B. diff --git a/helm/matita/library/higher_order_defs/functions.ma b/helm/matita/library/higher_order_defs/functions.ma deleted file mode 100644 index a1b54c80c..000000000 --- a/helm/matita/library/higher_order_defs/functions.ma +++ /dev/null @@ -1,67 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/higher_order_defs/functions/". - -include "logic/equality.ma". - -definition compose \def - \lambda A,B,C:Type.\lambda f:(B\to C).\lambda g:(A\to B).\lambda x:A. - f (g x). - -notation "hvbox(a break \circ b)" - left associative with precedence 70 -for @{ 'compose $a $b }. - -interpretation "function composition" 'compose f g = - (cic:/matita/higher_order_defs/functions/compose.con _ _ _ f g). - -definition injective: \forall A,B:Type.\forall f:A \to B.Prop -\def \lambda A,B.\lambda f. - \forall x,y:A.f x = f y \to x=y. - -definition surjective: \forall A,B:Type.\forall f:A \to B.Prop -\def \lambda A,B.\lambda f. - \forall z:B. \exists x:A.z=f x. - -definition symmetric: \forall A:Type.\forall f:A \to A\to A.Prop -\def \lambda A.\lambda f.\forall x,y.f x y = f y x. - -definition symmetric2: \forall A,B:Type.\forall f:A \to A\to B.Prop -\def \lambda A,B.\lambda f.\forall x,y.f x y = f y x. - -definition associative: \forall A:Type.\forall f:A \to A\to A.Prop -\def \lambda A.\lambda f.\forall x,y,z.f (f x y) z = f x (f y z). - -theorem eq_f_g_h: - \forall A,B,C,D:Type. - \forall f:C \to D.\forall g:B \to C.\forall h:A \to B. - f \circ (g \circ h) = (f \circ g) \circ h. - intros. - reflexivity. -qed. - -(* functions and relations *) -definition monotonic : \forall A:Type.\forall R:A \to A \to Prop. -\forall f:A \to A.Prop \def -\lambda A. \lambda R. \lambda f. \forall x,y:A.R x y \to R (f x) (f y). - -(* functions and functions *) -definition distributive: \forall A:Type.\forall f,g:A \to A \to A.Prop -\def \lambda A.\lambda f,g.\forall x,y,z:A. f x (g y z) = g (f x y) (f x z). - -definition distributive2: \forall A,B:Type.\forall f:A \to B \to B. -\forall g: B\to B\to B. Prop -\def \lambda A,B.\lambda f,g.\forall x:A.\forall y,z:B. f x (g y z) = g (f x y) (f x z). - diff --git a/helm/matita/library/higher_order_defs/ordering.ma b/helm/matita/library/higher_order_defs/ordering.ma deleted file mode 100644 index c2b351d7a..000000000 --- a/helm/matita/library/higher_order_defs/ordering.ma +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/higher_order_defs/ordering/". - -include "logic/equality.ma". - -definition antisymmetric: \forall A:Type.\forall R:A \to A \to Prop.Prop -\def -\lambda A.\lambda R.\forall x,y:A.R x y \to R y x \to x=y. - diff --git a/helm/matita/library/higher_order_defs/relations.ma b/helm/matita/library/higher_order_defs/relations.ma deleted file mode 100644 index 029b229dc..000000000 --- a/helm/matita/library/higher_order_defs/relations.ma +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/higher_order_defs/relations/". - -include "logic/connectives.ma". - -definition reflexive: \forall A:Type.\forall R:A \to A \to Prop.Prop -\def -\lambda A.\lambda R.\forall x:A.R x x. - -definition symmetric: \forall A:Type.\forall R:A \to A \to Prop.Prop -\def -\lambda A.\lambda R.\forall x,y:A.R x y \to R y x. - -definition transitive: \forall A:Type.\forall R:A \to A \to Prop.Prop -\def -\lambda A.\lambda R.\forall x,y,z:A.R x y \to R y z \to R x z. - -definition irreflexive: \forall A:Type.\forall R:A \to A \to Prop.Prop -\def -\lambda A.\lambda R.\forall x:A.\lnot (R x x). diff --git a/helm/matita/library/legacy/coq.ma b/helm/matita/library/legacy/coq.ma deleted file mode 100644 index d3c74fe21..000000000 --- a/helm/matita/library/legacy/coq.ma +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/legacy/coq/". - -(* aritmetic operators *) - -interpretation "Coq's natural plus" 'plus x y = (cic:/Coq/Init/Peano/plus.con x y). -interpretation "Coq's real plus" 'plus x y = (cic:/Coq/Reals/Rdefinitions/Rplus.con x y). -interpretation "Coq's binary integer plus" 'plus x y = (cic:/Coq/ZArith/BinInt/Zplus.con x y). -interpretation "Coq's binary positive plus" 'plus x y = (cic:/Coq/NArith/BinPos/Pplus.con x y). -interpretation "Coq's natural minus" 'minus x y = (cic:/Coq/Init/Peano/minus.con x y). -interpretation "Coq's real minus" 'minus x y = (cic:/Coq/Reals/Rdefinitions/Rminus.con x y). -interpretation "Coq's binary integer minus" 'minus x y = (cic:/Coq/ZArith/BinInt/Zminus.con x y). -interpretation "Coq's binary positive minus" 'minus x y = (cic:/Coq/NArith/BinPos/Pminus.con x y). -interpretation "Coq's natural times" 'times x y = (cic:/Coq/Init/Peano/mult.con x y). -interpretation "Coq's real times" 'times x y = (cic:/Coq/Reals/Rdefinitions/Rmult.con x y). -interpretation "Coq's binary positive times" 'times x y = (cic:/Coq/NArith/BinPos/Pmult.con x y). -interpretation "Coq's binary integer times" 'times x y = (cic:/Coq/ZArith/BinInt/Zmult.con x y). -interpretation "Coq's real power" 'power x y = (cic:/Coq/Reals/Rfunctions/pow.con x y). -interpretation "Coq's integer power" 'power x y = (cic:/Coq/ZArith/Zpower/Zpower.con x y). -interpretation "Coq's real divide" 'divide x y = (cic:/Coq/Reals/Rdefinitions/Rdiv.con x y). -interpretation "Coq's real unary minus" 'uminus x = (cic:/Coq/Reals/Rdefinitions/Ropp.con x). -interpretation "Coq's binary integer negative sign" 'uminus x = (cic:/Coq/ZArith/BinInt/Z.ind#xpointer(1/1/3) x). -interpretation "Coq's binary integer unary minus" 'uminus x = (cic:/Coq/ZArith/BinInt/Zopp.con x). - -(* logical operators *) - -interpretation "Coq's logical and" 'and x y = (cic:/Coq/Init/Logic/and.ind#xpointer(1/1) x y). -interpretation "Coq's logical or" 'or x y = (cic:/Coq/Init/Logic/or.ind#xpointer(1/1) x y). -interpretation "Coq's logical not" 'not x = (cic:/Coq/Init/Logic/not.con x). -interpretation "Coq's exists" 'exists \eta.x = (cic:/Coq/Init/Logic/ex.ind#xpointer(1/1) _ x). - -(* relational operators *) - -interpretation "Coq's natural 'less or equal to'" 'leq x y = (cic:/Coq/Init/Peano/le.ind#xpointer(1/1) x y). -interpretation "Coq's real 'less or equal to'" 'leq x y = (cic:/Coq/Reals/Rdefinitions/Rle.con x y). -interpretation "Coq's natural 'greater or equal to'" 'geq x y = (cic:/Coq/Init/Peano/ge.con x y). -interpretation "Coq's real 'greater or equal to'" 'geq x y = (cic:/Coq/Reals/Rdefinitions/Rge.con x y). -interpretation "Coq's natural 'less than'" 'lt x y = (cic:/Coq/Init/Peano/lt.con x y). -interpretation "Coq's real 'less than'" 'lt x y = (cic:/Coq/Reals/Rdefinitions/Rlt.con x y). -interpretation "Coq's natural 'greater than'" 'gt x y = (cic:/Coq/Init/Peano/gt.con x y). -interpretation "Coq's real 'greater than'" 'gt x y = (cic:/Coq/Reals/Rdefinitions/Rgt.con x y). - -interpretation "Coq's leibnitz's equality" 'eq x y = (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y). -interpretation "Coq's not equal to (leibnitz)" 'neq x y = (cic:/Coq/Init/Logic/not.con (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y)). - diff --git a/helm/matita/library/list/list.ma b/helm/matita/library/list/list.ma deleted file mode 100644 index ffa2c8ef9..000000000 --- a/helm/matita/library/list/list.ma +++ /dev/null @@ -1,112 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/list/". -include "logic/equality.ma". -include "higher_order_defs/functions.ma". - -inductive list (A:Set) : Set := - | nil: list A - | cons: A -> list A -> list A. - -notation "hvbox(hd break :: tl)" - right associative with precedence 46 - for @{'cons $hd $tl}. - -notation "[ list0 x sep ; ]" - non associative with precedence 90 - for ${fold right @'nil rec acc @{'cons $x $acc}}. - -notation "hvbox(l1 break @ l2)" - right associative with precedence 47 - for @{'append $l1 $l2 }. - -interpretation "nil" 'nil = (cic:/matita/list/list.ind#xpointer(1/1/1) _). -interpretation "cons" 'cons hd tl = - (cic:/matita/list/list.ind#xpointer(1/1/2) _ hd tl). - -(* theorem test_notation: [O; S O; S (S O)] = O :: S O :: S (S O) :: []. *) - -theorem nil_cons: - \forall A:Set.\forall l:list A.\forall a:A. - a::l <> []. - intros; - unfold Not; - intros; - discriminate H. -qed. - -let rec id_list A (l: list A) on l := - match l with - [ nil => [] - | (cons hd tl) => hd :: id_list A tl ]. - -let rec append A (l1: list A) l2 on l1 := - match l1 with - [ nil => l2 - | (cons hd tl) => hd :: append A tl l2 ]. - -definition tail := \lambda A:Set. \lambda l: list A. - match l with - [ nil => [] - | (cons hd tl) => tl]. - -interpretation "append" 'append l1 l2 = (cic:/matita/list/append.con _ l1 l2). - -theorem append_nil: \forall A:Set.\forall l:list A.l @ [] = l. - intros; - elim l; - [ reflexivity; - | simplify; - rewrite > H; - reflexivity; - ] -qed. - -theorem associative_append: \forall A:Set.associative (list A) (append A). - intros; unfold; intros; - elim x; - [ simplify; - reflexivity; - | simplify; - rewrite > H; - reflexivity; - ] -qed. - -theorem cons_append_commute: - \forall A:Set.\forall l1,l2:list A.\forall a:A. - a :: (l1 @ l2) = (a :: l1) @ l2. - intros; - reflexivity; -qed. - -(* -theorem nil_append_nil_both: - \forall A:Set.\forall l1,l2:list A. - l1 @ l2 = [] \to l1 = [] \land l2 = []. -*) - -(* -include "nat/nat.ma". - -theorem test_notation: [O; S O; S (S O)] = O :: S O :: S (S O) :: []. -reflexivity. -qed. - -theorem test_append: [O;O;O;O;O;O] = [O;O;O] @ [O;O] @ [O]. -simplify. -reflexivity. -qed. -*) diff --git a/helm/matita/library/list/sort.ma b/helm/matita/library/list/sort.ma deleted file mode 100644 index 939cecede..000000000 --- a/helm/matita/library/list/sort.ma +++ /dev/null @@ -1,172 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/list/sort/". - -include "datatypes/bool.ma". -include "datatypes/constructors.ma". -include "list/list.ma". - -let rec mem (A:Set) (eq: A → A → bool) x (l: list A) on l ≝ - match l with - [ nil ⇒ false - | (cons a l') ⇒ - match eq x a with - [ true ⇒ true - | false ⇒ mem A eq x l' - ] - ]. - -let rec ordered (A:Set) (le: A → A → bool) (l: list A) on l ≝ - match l with - [ nil ⇒ true - | (cons x l') ⇒ - match l' with - [ nil ⇒ true - | (cons y l'') ⇒ - le x y \land ordered A le l' - ] - ]. - -let rec insert (A:Set) (le: A → A → bool) x (l: list A) on l ≝ - match l with - [ nil ⇒ [x] - | (cons he l') ⇒ - match le x he with - [ true ⇒ x::l - | false ⇒ he::(insert A le x l') - ] - ]. - -lemma insert_ind : - ∀A:Set. ∀le: A → A → bool. ∀x. - ∀P:(list A → list A → Prop). - ∀H:(∀l: list A. l=[] → P [] [x]). - ∀H2: - (∀l: list A. ∀he. ∀l'. P l' (insert ? le x l') → - le x he = false → l=he::l' → P (he::l') (he::(insert ? le x l'))). - ∀H3: - (∀l: list A. ∀he. ∀l'. P l' (insert ? le x l') → - le x he = true → l=he::l' → P (he::l') (x::he::l')). - ∀l:list A. P l (insert ? le x l). - intros. - apply ( - let rec insert_ind (l: list A) \def - match l in list - return - λli. - l = li → P li (insert ? le x li) - with - [ nil ⇒ H l - | (cons he l') ⇒ - match le x he - return - λb. le x he = b → l = he::l' → - P (he::l') - (match b with - [ true ⇒ x::he::l' - | false ⇒ he::(insert ? le x l') ]) - with - [ true ⇒ H2 l he l' (insert_ind l') - | false ⇒ H1 l he l' (insert_ind l') - ] - (refl_eq ? (le x he)) - ] (refl_eq ? l) in insert_ind l). -qed. - - -let rec insertionsort (A:Set) (le: A → A → bool) (l: list A) on l ≝ - match l with - [ nil ⇒ [] - | (cons he l') ⇒ - let l'' ≝ insertionsort A le l' in - insert A le he l'' - ]. - -lemma ordered_injective: - ∀A:Set. ∀le:A → A → bool. - ∀l:list A. ordered A le l = true → ordered A le (tail A l) = true. - intros 3 (A le l). - elim l - [ simplify; reflexivity; - | simplify; - generalize in match H1; - clear H1; - elim l1; - [ simplify; reflexivity; - | cut ((le s s1 \land ordered A le (s1::l2)) = true); - [ generalize in match Hcut; - apply andb_elim; - elim (le s s1); - [ simplify; - fold simplify (ordered ? le (s1::l2)); - intros; assumption; - | simplify; - intros (Habsurd); - apply False_ind; - apply (not_eq_true_false); - symmetry; - assumption - ] - | exact H2; - ] - ] - ]. -qed. - -lemma insert_sorted: - \forall A:Set. \forall le:A\to A\to bool. - (\forall a,b:A. le a b = false \to le b a = true) \to - \forall l:list A. \forall x:A. - ordered A le l = true \to ordered A le (insert A le x l) = true. - intros 5 (A le H l x). - apply (insert_ind ? ? ? (λl,il. ordered ? le l = true → ordered ? le il = true)); - clear l; intros; simplify; intros; - [2: rewrite > H1; - [ generalize in match (H ? ? H2); clear H2; intro; - generalize in match H4; clear H4; - elim l'; simplify; - [ rewrite > H5; - reflexivity - | elim (le x s); simplify; - [ rewrite > H5; - reflexivity - | simplify in H4; - rewrite > (andb_true_true ? ? H4); - reflexivity - ] - ] - | apply (ordered_injective ? ? ? H4) - ] - | reflexivity - | rewrite > H2; - rewrite > H4; - reflexivity - ]. -qed. - -theorem insertionsort_sorted: - ∀A:Set. - ∀le:A → A → bool.∀eq:A → A → bool. - (∀a,b:A. le a b = false → le b a = true) \to - ∀l:list A. - ordered A le (insertionsort A le l) = true. - intros 5 (A le eq le_tot l). - elim l; - [ simplify; - reflexivity; - | apply (insert_sorted ? ? le_tot (insertionsort ? le l1) s); - assumption; - ] -qed. \ No newline at end of file diff --git a/helm/matita/library/logic/connectives.ma b/helm/matita/library/logic/connectives.ma deleted file mode 100644 index 4cbea3529..000000000 --- a/helm/matita/library/logic/connectives.ma +++ /dev/null @@ -1,90 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/logic/connectives/". - -inductive True: Prop \def -I : True. - -default "true" cic:/matita/logic/connectives/True.ind. - -inductive False: Prop \def . - -default "false" cic:/matita/logic/connectives/False.ind. - -definition Not: Prop \to Prop \def -\lambda A. (A \to False). - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "logical not" 'not x = (cic:/matita/logic/connectives/Not.con x). - -theorem absurd : \forall A,C:Prop. A \to \lnot A \to C. -intros. elim (H1 H). -qed. - -default "absurd" cic:/matita/logic/connectives/absurd.con. - -inductive And (A,B:Prop) : Prop \def - conj : A \to B \to (And A B). - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "logical and" 'and x y = (cic:/matita/logic/connectives/And.ind#xpointer(1/1) x y). - -theorem proj1: \forall A,B:Prop. A \land B \to A. -intros. elim H. assumption. -qed. - -theorem proj2: \forall A,B:Prop. A \land B \to B. -intros. elim H. assumption. -qed. - -inductive Or (A,B:Prop) : Prop \def - or_introl : A \to (Or A B) - | or_intror : B \to (Or A B). - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "logical or" 'or x y = - (cic:/matita/logic/connectives/Or.ind#xpointer(1/1) x y). - -theorem Or_ind': - \forall A,B:Prop. - \forall P: A \lor B \to Prop. - (\forall p:A. P (or_introl ? ? p)) \to - (\forall q:B. P (or_intror ? ? q)) \to - \forall p:A \lor B. P p. - intros. - apply - (match p return \lambda p.P p with - [(or_introl p) \Rightarrow H p - |(or_intror q) \Rightarrow H1 q]). -qed. - -definition decidable : Prop \to Prop \def \lambda A:Prop. A \lor \lnot A. - -inductive ex (A:Type) (P:A \to Prop) : Prop \def - ex_intro: \forall x:A. P x \to ex A P. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "exists" 'exists \eta.x = - (cic:/matita/logic/connectives/ex.ind#xpointer(1/1) _ x). - -notation < "hvbox(\exists ident i opt (: ty) break . p)" - right associative with precedence 20 -for @{ 'exists ${default - @{\lambda ${ident i} : $ty. $p)} - @{\lambda ${ident i} . $p}}}. - -inductive ex2 (A:Type) (P,Q:A \to Prop) : Prop \def - ex_intro2: \forall x:A. P x \to Q x \to ex2 A P Q. - diff --git a/helm/matita/library/logic/equality.ma b/helm/matita/library/logic/equality.ma deleted file mode 100644 index b87dc6c95..000000000 --- a/helm/matita/library/logic/equality.ma +++ /dev/null @@ -1,214 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/logic/equality/". - -include "higher_order_defs/relations.ma". - -inductive eq (A:Type) (x:A) : A \to Prop \def - refl_eq : eq A x x. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "leibnitz's equality" - 'eq x y = (cic:/matita/logic/equality/eq.ind#xpointer(1/1) _ x y). -(*CSC: the URI must disappear: there is a bug now *) -interpretation "leibnitz's non-equality" - 'neq x y = (cic:/matita/logic/connectives/Not.con - (cic:/matita/logic/equality/eq.ind#xpointer(1/1) _ x y)). - -theorem eq_ind': - \forall A. \forall x:A. \forall P: \forall y:A. x=y \to Prop. - P ? (refl_eq ? x) \to \forall y:A. \forall p:x=y. P y p. - intros. - exact - (match p return \lambda y. \lambda p.P y p with - [refl_eq \Rightarrow H]). -qed. - -theorem reflexive_eq : \forall A:Type. reflexive A (eq A). -simplify.intros.apply refl_eq. -qed. - -theorem symmetric_eq: \forall A:Type. symmetric A (eq A). -unfold symmetric.intros.elim H. apply refl_eq. -qed. - -theorem sym_eq : \forall A:Type.\forall x,y:A. x=y \to y=x -\def symmetric_eq. - -theorem transitive_eq : \forall A:Type. transitive A (eq A). -unfold transitive.intros.elim H1.assumption. -qed. - -theorem trans_eq : \forall A:Type.\forall x,y,z:A. x=y \to y=z \to x=z -\def transitive_eq. - -theorem eq_elim_r: - \forall A:Type.\forall x:A. \forall P: A \to Prop. - P x \to \forall y:A. y=x \to P y. -intros. elim (sym_eq ? ? ? H1).assumption. -qed. - -default "equality" - cic:/matita/logic/equality/eq.ind - cic:/matita/logic/equality/sym_eq.con - cic:/matita/logic/equality/trans_eq.con - cic:/matita/logic/equality/eq_ind.con - cic:/matita/logic/equality/eq_elim_r.con. - -theorem eq_f: \forall A,B:Type.\forall f:A\to B. -\forall x,y:A. x=y \to f x = f y. -intros.elim H.reflexivity. -qed. - -theorem eq_f2: \forall A,B,C:Type.\forall f:A\to B \to C. -\forall x1,x2:A. \forall y1,y2:B. -x1=x2 \to y1=y2 \to f x1 y1 = f x2 y2. -intros.elim H1.elim H.reflexivity. -qed. - -definition comp \def - \lambda A. - \lambda x,y,y':A. - \lambda eq1:x=y. - \lambda eq2:x=y'. - eq_ind ? ? (\lambda a.a=y') eq2 ? eq1. - -lemma trans_sym_eq: - \forall A. - \forall x,y:A. - \forall u:x=y. - comp ? ? ? ? u u = refl_eq ? y. - intros. - apply (eq_ind' ? ? ? ? ? u). - reflexivity. -qed. - -definition nu \def - \lambda A. - \lambda H: \forall x,y:A. decidable (x=y). - \lambda x,y. \lambda p:x=y. - match H x y with - [ (or_introl p') \Rightarrow p' - | (or_intror K) \Rightarrow False_ind ? (K p) ]. - -theorem nu_constant: - \forall A. - \forall H: \forall x,y:A. decidable (x=y). - \forall x,y:A. - \forall u,v:x=y. - nu ? H ? ? u = nu ? H ? ? v. - intros. - unfold nu. - unfold decidable in H. - apply (Or_ind' ? ? ? ? ? (H x y)); simplify. - intro; reflexivity. - intro; elim (q u). -qed. - -definition nu_inv \def - \lambda A. - \lambda H: \forall x,y:A. decidable (x=y). - \lambda x,y:A. - \lambda v:x=y. - comp ? ? ? ? (nu ? H ? ? (refl_eq ? x)) v. - -theorem nu_left_inv: - \forall A. - \forall H: \forall x,y:A. decidable (x=y). - \forall x,y:A. - \forall u:x=y. - nu_inv ? H ? ? (nu ? H ? ? u) = u. - intros. - apply (eq_ind' ? ? ? ? ? u). - unfold nu_inv. - apply trans_sym_eq. -qed. - -theorem eq_to_eq_to_eq_p_q: - \forall A. \forall x,y:A. - (\forall x,y:A. decidable (x=y)) \to - \forall p,q:x=y. p=q. - intros. - rewrite < (nu_left_inv ? H ? ? p). - rewrite < (nu_left_inv ? H ? ? q). - elim (nu_constant ? H ? ? q). - reflexivity. -qed. - -(*CSC: alternative proof that does not pollute the environment with - technical lemmata. Unfortunately, it is a pain to do without proper - support for let-ins. -theorem eq_to_eq_to_eq_p_q: - \forall A. \forall x,y:A. - (\forall x,y:A. decidable (x=y)) \to - \forall p,q:x=y. p=q. -intros. -letin nu \def - (\lambda x,y. \lambda p:x=y. - match H x y with - [ (or_introl p') \Rightarrow p' - | (or_intror K) \Rightarrow False_ind ? (K p) ]). -cut - (\forall q:x=y. - eq_ind ? ? (\lambda z. z=y) (nu ? ? q) ? (nu ? ? (refl_eq ? x)) - = q). -focus 8. - clear q; clear p. - intro. - apply (eq_ind' ? ? ? ? ? q); - fold simplify (nu ? ? (refl_eq ? x)). - generalize in match (nu ? ? (refl_eq ? x)); intro. - apply - (eq_ind' A x - (\lambda y. \lambda u. - eq_ind A x (\lambda a.a=y) u y u = refl_eq ? y) - ? x H1). - reflexivity. -unfocus. -rewrite < (Hcut p); fold simplify (nu ? ? p). -rewrite < (Hcut q); fold simplify (nu ? ? q). -apply (Or_ind' (x=x) (x \neq x) - (\lambda p:decidable (x=x). eq_ind A x (\lambda z.z=y) (nu x y p) x - ([\lambda H1.eq A x x] - match p with - [(or_introl p') \Rightarrow p' - |(or_intror K) \Rightarrow False_ind (x=x) (K (refl_eq A x))]) = - eq_ind A x (\lambda z.z=y) (nu x y q) x - ([\lambda H1.eq A x x] - match p with - [(or_introl p') \Rightarrow p' - |(or_intror K) \Rightarrow False_ind (x=x) (K (refl_eq A x))])) - ? ? (H x x)). -intro; simplify; reflexivity. -intro q; elim (q (refl_eq ? x)). -qed. -*) - -(* -theorem a:\forall x.x=x\land True. -[ -2:intros; - split; - [ - exact (refl_eq Prop x); - | - exact I; - ] -1: - skip -] -qed. -*) - diff --git a/helm/matita/library/nat/chinese_reminder.ma b/helm/matita/library/nat/chinese_reminder.ma deleted file mode 100644 index 30cc7440f..000000000 --- a/helm/matita/library/nat/chinese_reminder.ma +++ /dev/null @@ -1,251 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/chinese_reminder". - -include "nat/exp.ma". -include "nat/gcd.ma". -include "nat/permutation.ma". -include "nat/congruence.ma". - -theorem and_congruent_congruent: \forall m,n,a,b:nat. O < n \to O < m \to -gcd n m = (S O) \to ex nat (\lambda x. congruent x a m \land congruent x b n). -intros. -cut (\exists c,d.c*n - d*m = (S O) \lor d*m - c*n = (S O)). -elim Hcut.elim H3.elim H4. -apply (ex_intro nat ? ((a+b*m)*a1*n-b*a2*m)). -split. -(* congruent to a *) -cut (a1*n = a2*m + (S O)). -rewrite > assoc_times. -rewrite > Hcut1. -rewrite < (sym_plus ? (a2*m)). -rewrite > distr_times_plus. -rewrite < times_n_SO. -rewrite > assoc_plus. -rewrite < assoc_times. -rewrite < times_plus_l. -rewrite > eq_minus_plus_plus_minus. -rewrite < times_minus_l. -rewrite > sym_plus. -apply (eq_times_plus_to_congruent ? ? ? ((b+(a+b*m)*a2)-b*a2)). -assumption.reflexivity. -apply le_times_l. -apply (trans_le ? ((a+b*m)*a2)). -apply le_times_l. -apply (trans_le ? (b*m)). -rewrite > times_n_SO in \vdash (? % ?). -apply le_times_r.assumption. -apply le_plus_n. -apply le_plus_n. -apply minus_to_plus. -apply lt_to_le. -change with (O + a2*m < a1*n). -apply lt_minus_to_plus. -rewrite > H5.unfold lt.apply le_n. -assumption. -(* congruent to b *) -cut (a2*m = a1*n - (S O)). -rewrite > (assoc_times b a2). -rewrite > Hcut1. -rewrite > distr_times_minus. -rewrite < assoc_times. -rewrite < eq_plus_minus_minus_minus. -rewrite < times_n_SO. -rewrite < times_minus_l. -rewrite < sym_plus. -apply (eq_times_plus_to_congruent ? ? ? ((a+b*m)*a1-b*a1)). -assumption.reflexivity. -rewrite > assoc_times. -apply le_times_r. -apply (trans_le ? (a1*n - a2*m)). -rewrite > H5.apply le_n. -apply (le_minus_m ? (a2*m)). -apply le_times_l. -apply le_times_l. -apply (trans_le ? (b*m)). -rewrite > times_n_SO in \vdash (? % ?). -apply le_times_r.assumption. -apply le_plus_n. -apply sym_eq. apply plus_to_minus. -rewrite > sym_plus. -apply minus_to_plus. -apply lt_to_le. -change with (O + a2*m < a1*n). -apply lt_minus_to_plus. -rewrite > H5.unfold lt.apply le_n. -assumption. -(* and now the symmetric case; the price to pay for working - in nat instead than Z *) -apply (ex_intro nat ? ((b+a*n)*a2*m-a*a1*n)). -split. -(* congruent to a *) -cut (a1*n = a2*m - (S O)). -rewrite > (assoc_times a a1). -rewrite > Hcut1. -rewrite > distr_times_minus. -rewrite < assoc_times. -rewrite < eq_plus_minus_minus_minus. -rewrite < times_n_SO. -rewrite < times_minus_l. -rewrite < sym_plus. -apply (eq_times_plus_to_congruent ? ? ? ((b+a*n)*a2-a*a2)). -assumption.reflexivity. -rewrite > assoc_times. -apply le_times_r. -apply (trans_le ? (a2*m - a1*n)). -rewrite > H5.apply le_n. -apply (le_minus_m ? (a1*n)). -rewrite > assoc_times.rewrite > assoc_times. -apply le_times_l. -apply (trans_le ? (a*n)). -rewrite > times_n_SO in \vdash (? % ?). -apply le_times_r.assumption. -apply le_plus_n. -apply sym_eq.apply plus_to_minus. -rewrite > sym_plus. -apply minus_to_plus. -apply lt_to_le. -change with (O + a1*n < a2*m). -apply lt_minus_to_plus. -rewrite > H5.unfold lt.apply le_n. -assumption. -(* congruent to a *) -cut (a2*m = a1*n + (S O)). -rewrite > assoc_times. -rewrite > Hcut1. -rewrite > (sym_plus (a1*n)). -rewrite > distr_times_plus. -rewrite < times_n_SO. -rewrite < assoc_times. -rewrite > assoc_plus. -rewrite < times_plus_l. -rewrite > eq_minus_plus_plus_minus. -rewrite < times_minus_l. -rewrite > sym_plus. -apply (eq_times_plus_to_congruent ? ? ? ((a+(b+a*n)*a1)-a*a1)). -assumption.reflexivity. -apply le_times_l. -apply (trans_le ? ((b+a*n)*a1)). -apply le_times_l. -apply (trans_le ? (a*n)). -rewrite > times_n_SO in \vdash (? % ?). -apply le_times_r. -assumption. -apply le_plus_n. -apply le_plus_n. -apply minus_to_plus. -apply lt_to_le. -change with (O + a1*n < a2*m). -apply lt_minus_to_plus. -rewrite > H5.unfold lt.apply le_n. -assumption. -(* proof of the cut *) -rewrite < H2. -apply eq_minus_gcd. -qed. - -theorem and_congruent_congruent_lt: \forall m,n,a,b:nat. O < n \to O < m \to -gcd n m = (S O) \to -ex nat (\lambda x. (congruent x a m \land congruent x b n) \land - (x < m*n)). -intros.elim (and_congruent_congruent m n a b). -elim H3. -apply (ex_intro ? ? (a1 \mod (m*n))). -split.split. -apply (transitive_congruent m ? a1). -unfold congruent. -apply sym_eq. -change with (congruent a1 (a1 \mod (m*n)) m). -rewrite < sym_times. -apply congruent_n_mod_times. -assumption.assumption.assumption. -apply (transitive_congruent n ? a1). -unfold congruent. -apply sym_eq. -change with (congruent a1 (a1 \mod (m*n)) n). -apply congruent_n_mod_times. -assumption.assumption.assumption. -apply lt_mod_m_m. -rewrite > (times_n_O O). -apply lt_times.assumption.assumption. -assumption.assumption.assumption. -qed. - -definition cr_pair : nat \to nat \to nat \to nat \to nat \def -\lambda n,m,a,b. -min (pred (n*m)) (\lambda x. andb (eqb (x \mod n) a) (eqb (x \mod m) b)). - -theorem cr_pair1: cr_pair (S (S O)) (S (S (S O))) O O = O. -reflexivity. -qed. - -theorem cr_pair2: cr_pair (S(S O)) (S(S(S O))) (S O) O = (S(S(S O))). -simplify. -reflexivity. -qed. - -theorem cr_pair3: cr_pair (S(S O)) (S(S(S O))) (S O) (S(S O)) = (S(S(S(S(S O))))). -reflexivity. -qed. - -theorem cr_pair4: cr_pair (S(S(S(S(S O))))) (S(S(S(S(S(S(S O))))))) (S(S(S O))) (S(S O)) = -(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S O))))))))))))))))))))))). -reflexivity. -qed. - -theorem mod_cr_pair : \forall m,n,a,b. a \lt m \to b \lt n \to -gcd n m = (S O) \to -(cr_pair m n a b) \mod m = a \land (cr_pair m n a b) \mod n = b. -intros. -cut (andb (eqb ((cr_pair m n a b) \mod m) a) - (eqb ((cr_pair m n a b) \mod n) b) = true). -generalize in match Hcut. -apply andb_elim. -apply eqb_elim.intro. -rewrite > H3. -change with -(eqb ((cr_pair m n a b) \mod n) b = true \to -a = a \land (cr_pair m n a b) \mod n = b). -intro.split.reflexivity. -apply eqb_true_to_eq.assumption. -intro. -change with (false = true \to -(cr_pair m n a b) \mod m = a \land (cr_pair m n a b) \mod n = b). -intro.apply False_ind. -apply not_eq_true_false.apply sym_eq.assumption. -apply (f_min_aux_true -(\lambda x. andb (eqb (x \mod m) a) (eqb (x \mod n) b)) (pred (m*n)) (pred (m*n))). -elim (and_congruent_congruent_lt m n a b). -apply (ex_intro ? ? a1).split.split. -rewrite < minus_n_n.apply le_O_n. -elim H3.apply le_S_S_to_le.apply (trans_le ? (m*n)). -assumption.apply (nat_case (m*n)).apply le_O_n. -intro. -rewrite < pred_Sn.apply le_n. -elim H3.elim H4. -apply andb_elim. -cut (a1 \mod m = a). -cut (a1 \mod n = b). -rewrite > (eq_to_eqb_true ? ? Hcut). -rewrite > (eq_to_eqb_true ? ? Hcut1). -simplify.reflexivity. -rewrite < (lt_to_eq_mod b n).assumption. -assumption. -rewrite < (lt_to_eq_mod a m).assumption. -assumption. -apply (le_to_lt_to_lt ? b).apply le_O_n.assumption. -apply (le_to_lt_to_lt ? a).apply le_O_n.assumption. -assumption. -qed. \ No newline at end of file diff --git a/helm/matita/library/nat/compare.ma b/helm/matita/library/nat/compare.ma deleted file mode 100644 index 264731580..000000000 --- a/helm/matita/library/nat/compare.ma +++ /dev/null @@ -1,227 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/compare". - -include "datatypes/bool.ma". -include "datatypes/compare.ma". -include "nat/orders.ma". - -let rec eqb n m \def -match n with - [ O \Rightarrow - match m with - [ O \Rightarrow true - | (S q) \Rightarrow false] - | (S p) \Rightarrow - match m with - [ O \Rightarrow false - | (S q) \Rightarrow eqb p q]]. - -theorem eqb_to_Prop: \forall n,m:nat. -match (eqb n m) with -[ true \Rightarrow n = m -| false \Rightarrow n \neq m]. -intros. -apply (nat_elim2 -(\lambda n,m:nat.match (eqb n m) with -[ true \Rightarrow n = m -| false \Rightarrow n \neq m])). -intro.elim n1. -simplify.reflexivity. -simplify.apply not_eq_O_S. -intro. -simplify.unfold Not. -intro. apply (not_eq_O_S n1).apply sym_eq.assumption. -intros.simplify. -generalize in match H. -elim ((eqb n1 m1)). -simplify.apply eq_f.apply H1. -simplify.unfold Not.intro.apply H1.apply inj_S.assumption. -qed. - -theorem eqb_elim : \forall n,m:nat.\forall P:bool \to Prop. -(n=m \to (P true)) \to (n \neq m \to (P false)) \to (P (eqb n m)). -intros. -cut -(match (eqb n m) with -[ true \Rightarrow n = m -| false \Rightarrow n \neq m] \to (P (eqb n m))). -apply Hcut.apply eqb_to_Prop. -elim (eqb n m). -apply ((H H2)). -apply ((H1 H2)). -qed. - -theorem eqb_n_n: \forall n. eqb n n = true. -intro.elim n.simplify.reflexivity. -simplify.assumption. -qed. - -theorem eqb_true_to_eq: \forall n,m:nat. -eqb n m = true \to n = m. -intros. -change with -match true with -[ true \Rightarrow n = m -| false \Rightarrow n \neq m]. -rewrite < H. -apply eqb_to_Prop. -qed. - -theorem eqb_false_to_not_eq: \forall n,m:nat. -eqb n m = false \to n \neq m. -intros. -change with -match false with -[ true \Rightarrow n = m -| false \Rightarrow n \neq m]. -rewrite < H. -apply eqb_to_Prop. -qed. - -theorem eq_to_eqb_true: \forall n,m:nat. -n = m \to eqb n m = true. -intros.apply (eqb_elim n m). -intros. reflexivity. -intros.apply False_ind.apply (H1 H). -qed. - -theorem not_eq_to_eqb_false: \forall n,m:nat. -\lnot (n = m) \to eqb n m = false. -intros.apply (eqb_elim n m). -intros. apply False_ind.apply (H H1). -intros.reflexivity. -qed. - -let rec leb n m \def -match n with - [ O \Rightarrow true - | (S p) \Rightarrow - match m with - [ O \Rightarrow false - | (S q) \Rightarrow leb p q]]. - -theorem leb_to_Prop: \forall n,m:nat. -match (leb n m) with -[ true \Rightarrow n \leq m -| false \Rightarrow n \nleq m]. -intros. -apply (nat_elim2 -(\lambda n,m:nat.match (leb n m) with -[ true \Rightarrow n \leq m -| false \Rightarrow n \nleq m])). -simplify.exact le_O_n. -simplify.exact not_le_Sn_O. -intros 2.simplify.elim ((leb n1 m1)). -simplify.apply le_S_S.apply H. -simplify.unfold Not.intros.apply H.apply le_S_S_to_le.assumption. -qed. - -theorem leb_elim: \forall n,m:nat. \forall P:bool \to Prop. -(n \leq m \to (P true)) \to (n \nleq m \to (P false)) \to -P (leb n m). -intros. -cut -(match (leb n m) with -[ true \Rightarrow n \leq m -| false \Rightarrow n \nleq m] \to (P (leb n m))). -apply Hcut.apply leb_to_Prop. -elim (leb n m). -apply ((H H2)). -apply ((H1 H2)). -qed. - -let rec nat_compare n m: compare \def -match n with -[ O \Rightarrow - match m with - [ O \Rightarrow EQ - | (S q) \Rightarrow LT ] -| (S p) \Rightarrow - match m with - [ O \Rightarrow GT - | (S q) \Rightarrow nat_compare p q]]. - -theorem nat_compare_n_n: \forall n:nat. nat_compare n n = EQ. -intro.elim n. -simplify.reflexivity. -simplify.assumption. -qed. - -theorem nat_compare_S_S: \forall n,m:nat. -nat_compare n m = nat_compare (S n) (S m). -intros.simplify.reflexivity. -qed. - -theorem S_pred: \forall n:nat.lt O n \to eq nat n (S (pred n)). -intro.elim n.apply False_ind.exact (not_le_Sn_O O H). -apply eq_f.apply pred_Sn. -qed. - -theorem nat_compare_pred_pred: -\forall n,m:nat.lt O n \to lt O m \to -eq compare (nat_compare n m) (nat_compare (pred n) (pred m)). -intros. -apply (lt_O_n_elim n H). -apply (lt_O_n_elim m H1). -intros. -simplify.reflexivity. -qed. - -theorem nat_compare_to_Prop: \forall n,m:nat. -match (nat_compare n m) with - [ LT \Rightarrow n < m - | EQ \Rightarrow n=m - | GT \Rightarrow m < n ]. -intros. -apply (nat_elim2 (\lambda n,m.match (nat_compare n m) with - [ LT \Rightarrow n < m - | EQ \Rightarrow n=m - | GT \Rightarrow m < n ])). -intro.elim n1.simplify.reflexivity. -simplify.unfold lt.apply le_S_S.apply le_O_n. -intro.simplify.unfold lt.apply le_S_S. apply le_O_n. -intros 2.simplify.elim ((nat_compare n1 m1)). -simplify. unfold lt. apply le_S_S.apply H. -simplify. apply eq_f. apply H. -simplify. unfold lt.apply le_S_S.apply H. -qed. - -theorem nat_compare_n_m_m_n: \forall n,m:nat. -nat_compare n m = compare_invert (nat_compare m n). -intros. -apply (nat_elim2 (\lambda n,m. nat_compare n m = compare_invert (nat_compare m n))). -intros.elim n1.simplify.reflexivity. -simplify.reflexivity. -intro.elim n1.simplify.reflexivity. -simplify.reflexivity. -intros.simplify.elim H.reflexivity. -qed. - -theorem nat_compare_elim : \forall n,m:nat. \forall P:compare \to Prop. -(n < m \to P LT) \to (n=m \to P EQ) \to (m < n \to P GT) \to -(P (nat_compare n m)). -intros. -cut (match (nat_compare n m) with -[ LT \Rightarrow n < m -| EQ \Rightarrow n=m -| GT \Rightarrow m < n] \to -(P (nat_compare n m))). -apply Hcut.apply nat_compare_to_Prop. -elim ((nat_compare n m)). -apply ((H H3)). -apply ((H1 H3)). -apply ((H2 H3)). -qed. diff --git a/helm/matita/library/nat/congruence.ma b/helm/matita/library/nat/congruence.ma deleted file mode 100644 index af744cf34..000000000 --- a/helm/matita/library/nat/congruence.ma +++ /dev/null @@ -1,177 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/congruence". - -include "nat/relevant_equations.ma". -include "nat/primes.ma". - -definition S_mod: nat \to nat \to nat \def -\lambda n,m:nat. (S m) \mod n. - -definition congruent: nat \to nat \to nat \to Prop \def -\lambda n,m,p:nat. mod n p = mod m p. - -theorem congruent_n_n: \forall n,p:nat.congruent n n p. -intros.unfold congruent.reflexivity. -qed. - -theorem transitive_congruent: \forall p:nat. transitive nat -(\lambda n,m. congruent n m p). -intros.unfold transitive.unfold congruent.intros. -whd.apply (trans_eq ? ? (y \mod p)). -apply H.apply H1. -qed. - -theorem le_to_mod: \forall n,m:nat. n \lt m \to n = n \mod m. -intros. -apply (div_mod_spec_to_eq2 n m O n (n/m) (n \mod m)). -constructor 1.assumption.simplify.reflexivity. -apply div_mod_spec_div_mod. -apply (le_to_lt_to_lt O n m).apply le_O_n.assumption. -qed. - -theorem mod_mod : \forall n,p:nat. O

(div_mod (n \mod p) p) in \vdash (? ? % ?). -rewrite > (eq_div_O ? p).reflexivity. -(* uffa: hint non lo trova lt vs. le*) -apply lt_mod_m_m. -assumption. -assumption. -qed. - -theorem mod_times_mod : \forall n,m,p:nat. O

times_plus_l. -rewrite > assoc_plus. -rewrite < div_mod. -rewrite > assoc_times. -rewrite < div_mod. -reflexivity. -rewrite > (times_n_O O). -apply lt_times. -assumption.assumption.assumption. -qed. - -theorem congruent_n_mod_n : -\forall n,p:nat. O < p \to congruent n (n \mod p) p. -intros.unfold congruent. -apply mod_mod.assumption. -qed. - -theorem congruent_n_mod_times : -\forall n,m,p:nat. O < p \to O < m \to congruent n (n \mod (m*p)) p. -intros.unfold congruent. -apply mod_times_mod.assumption.assumption. -qed. - -theorem eq_times_plus_to_congruent: \forall n,m,p,r:nat. O< p \to -n = r*p+m \to congruent n m p. -intros.unfold congruent. -apply (div_mod_spec_to_eq2 n p (div n p) (mod n p) (r +(div m p)) (mod m p)). -apply div_mod_spec_div_mod.assumption. -constructor 1. -apply lt_mod_m_m.assumption. -rewrite > sym_times. -rewrite > distr_times_plus. -rewrite > sym_times. -rewrite > (sym_times p). -rewrite > assoc_plus. -rewrite < div_mod. -assumption.assumption. -qed. - -theorem divides_to_congruent: \forall n,m,p:nat. O < p \to m \le n \to -divides p (n - m) \to congruent n m p. -intros.elim H2. -apply (eq_times_plus_to_congruent n m p n2). -assumption. -rewrite < sym_plus. -apply minus_to_plus.assumption. -rewrite > sym_times. assumption. -qed. - -theorem congruent_to_divides: \forall n,m,p:nat. -O < p \to congruent n m p \to divides p (n - m). -intros.unfold congruent in H1. -apply (witness ? ? ((n / p)-(m / p))). -rewrite > sym_times. -rewrite > (div_mod n p) in \vdash (? ? % ?). -rewrite > (div_mod m p) in \vdash (? ? % ?). -rewrite < (sym_plus (m \mod p)). -rewrite < H1. -rewrite < (eq_minus_minus_minus_plus ? (n \mod p)). -rewrite < minus_plus_m_m. -apply sym_eq. -apply times_minus_l. -assumption.assumption. -qed. - -theorem mod_times: \forall n,m,p:nat. -O < p \to mod (n*m) p = mod ((mod n p)*(mod m p)) p. -intros. -change with (congruent (n*m) ((mod n p)*(mod m p)) p). -apply (eq_times_plus_to_congruent ? ? p -((n / p)*p*(m / p) + (n / p)*(m \mod p) + (n \mod p)*(m / p))). -assumption. -apply (trans_eq ? ? (((n/p)*p+(n \mod p))*((m/p)*p+(m \mod p)))). -apply eq_f2. -apply div_mod.assumption. -apply div_mod.assumption. -apply (trans_eq ? ? (((n/p)*p)*((m/p)*p) + (n/p)*p*(m \mod p) + -(n \mod p)*((m / p)*p) + (n \mod p)*(m \mod p))). -apply times_plus_plus. -apply eq_f2. -rewrite < assoc_times. -rewrite > (assoc_times (n/p) p (m \mod p)). -rewrite > (sym_times p (m \mod p)). -rewrite < (assoc_times (n/p) (m \mod p) p). -rewrite < times_plus_l. -rewrite < (assoc_times (n \mod p)). -rewrite < times_plus_l. -apply eq_f2. -apply eq_f2.reflexivity. -reflexivity.reflexivity. -reflexivity. -qed. - -theorem congruent_times: \forall n,m,n1,m1,p. O < p \to congruent n n1 p \to -congruent m m1 p \to congruent (n*m) (n1*m1) p. -unfold congruent. -intros. -rewrite > (mod_times n m p H). -rewrite > H1. -rewrite > H2. -apply sym_eq. -apply mod_times.assumption. -qed. - -theorem congruent_pi: \forall f:nat \to nat. \forall n,m,p:nat.O < p \to -congruent (pi n f m) (pi n (\lambda m. mod (f m) p) m) p. -intros. -elim n.change with (congruent (f m) (f m \mod p) p). -apply congruent_n_mod_n.assumption. -change with (congruent ((f (S n1+m))*(pi n1 f m)) -(((f (S n1+m))\mod p)*(pi n1 (\lambda m.(f m) \mod p) m)) p). -apply congruent_times. -assumption. -apply congruent_n_mod_n.assumption. -assumption. -qed. diff --git a/helm/matita/library/nat/count.ma b/helm/matita/library/nat/count.ma deleted file mode 100644 index 20913fa60..000000000 --- a/helm/matita/library/nat/count.ma +++ /dev/null @@ -1,246 +0,0 @@ -(**************************************************************************) -(* __ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/count". - -include "nat/relevant_equations.ma". -include "nat/sigma_and_pi.ma". -include "nat/permutation.ma". - -theorem sigma_f_g : \forall n,m:nat.\forall f,g:nat \to nat. -sigma n (\lambda p.f p + g p) m = sigma n f m + sigma n g m. -intros.elim n. -simplify.reflexivity. -simplify.rewrite > H. -rewrite > assoc_plus. -rewrite < (assoc_plus (g (S (n1+m)))). -rewrite > (sym_plus (g (S (n1+m)))). -rewrite > (assoc_plus (sigma n1 f m)). -rewrite < assoc_plus. -reflexivity. -qed. - -theorem sigma_plus: \forall n,p,m:nat.\forall f:nat \to nat. -sigma (S (p+n)) f m = sigma p (\lambda x.(f ((S n) + x))) m + sigma n f m. -intros. elim p. -simplify. -rewrite < (sym_plus n m).reflexivity. -simplify. -rewrite > assoc_plus in \vdash (? ? ? %). -rewrite < H. -simplify. -rewrite < plus_n_Sm. -rewrite > (sym_plus n). -rewrite > assoc_plus. -rewrite < (sym_plus m). -rewrite < (assoc_plus n1). -reflexivity. -qed. - -theorem sigma_plus1: \forall n,p,m:nat.\forall f:nat \to nat. -sigma (p+(S n)) f m = sigma p (\lambda x.(f ((S n) + x))) m + sigma n f m. -intros. elim p. -simplify.reflexivity. -simplify. -rewrite > assoc_plus in \vdash (? ? ? %). -rewrite < H. -rewrite < plus_n_Sm. -rewrite < plus_n_Sm.simplify. -rewrite < (sym_plus n). -rewrite > assoc_plus. -rewrite < (sym_plus m). -rewrite < (assoc_plus n). -reflexivity. -qed. - -theorem eq_sigma_sigma : \forall n,m:nat.\forall f:nat \to nat. -sigma (pred ((S n)*(S m))) f O = -sigma m (\lambda a.(sigma n (\lambda b.f (b*(S m) + a)) O)) O. -intro.elim n.simplify. -rewrite < plus_n_O. -apply eq_sigma.intros.reflexivity. -change with -(sigma (m+(S n1)*(S m)) f O = -sigma m (\lambda a.(f ((S(n1+O))*(S m)+a)) + (sigma n1 (\lambda b.f (b*(S m)+a)) O)) O). -rewrite > sigma_f_g. -rewrite < plus_n_O. -rewrite < H. -rewrite > (S_pred ((S n1)*(S m))). -apply sigma_plus1. -simplify.unfold lt.apply le_S_S.apply le_O_n. -qed. - -theorem eq_sigma_sigma1 : \forall n,m:nat.\forall f:nat \to nat. -sigma (pred ((S n)*(S m))) f O = -sigma n (\lambda a.(sigma m (\lambda b.f (b*(S n) + a)) O)) O. -intros. -rewrite > sym_times. -apply eq_sigma_sigma. -qed. - -theorem sigma_times: \forall n,m,p:nat.\forall f:nat \to nat. -(sigma n f m)*p = sigma n (\lambda i.(f i) * p) m. -intro. elim n.simplify.reflexivity. -simplify.rewrite < H. -apply times_plus_l. -qed. - -definition bool_to_nat: bool \to nat \def -\lambda b. match b with -[ true \Rightarrow (S O) -| false \Rightarrow O ]. - -theorem bool_to_nat_andb: \forall a,b:bool. -bool_to_nat (andb a b) = (bool_to_nat a)*(bool_to_nat b). -intros. elim a.elim b. -simplify.reflexivity. -reflexivity. -reflexivity. -qed. - -definition count : nat \to (nat \to bool) \to nat \def -\lambda n.\lambda f. sigma (pred n) (\lambda n.(bool_to_nat (f n))) O. - -theorem count_times:\forall n,m:nat. -\forall f,f1,f2:nat \to bool. -\forall g:nat \to nat \to nat. -\forall g1,g2: nat \to nat. -(\forall a,b:nat. a < (S n) \to b < (S m) \to (g b a) < (S n)*(S m)) \to -(\forall a,b:nat. a < (S n) \to b < (S m) \to (g1 (g b a)) = a) \to -(\forall a,b:nat. a < (S n) \to b < (S m) \to (g2 (g b a)) = b) \to -(\forall a,b:nat. a < (S n) \to b < (S m) \to f (g b a) = andb (f2 b) (f1 a)) \to -(count ((S n)*(S m)) f) = (count (S n) f1)*(count (S m) f2). -intros.unfold count. -rewrite < eq_map_iter_i_sigma. -rewrite > (permut_to_eq_map_iter_i plus assoc_plus sym_plus ? ? ? - (\lambda i.g (div i (S n)) (mod i (S n)))). -rewrite > eq_map_iter_i_sigma. -rewrite > eq_sigma_sigma1. -apply (trans_eq ? ? -(sigma n (\lambda a. - sigma m (\lambda b.(bool_to_nat (f2 b))*(bool_to_nat (f1 a))) O) O)). -apply eq_sigma.intros. -apply eq_sigma.intros. -rewrite > (div_mod_spec_to_eq (i1*(S n) + i) (S n) ((i1*(S n) + i)/(S n)) - ((i1*(S n) + i) \mod (S n)) i1 i). -rewrite > (div_mod_spec_to_eq2 (i1*(S n) + i) (S n) ((i1*(S n) + i)/(S n)) - ((i1*(S n) + i) \mod (S n)) i1 i). -rewrite > H3. -apply bool_to_nat_andb. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.assumption. -apply div_mod_spec_div_mod. -unfold lt.apply le_S_S.apply le_O_n. -constructor 1.unfold lt.apply le_S_S.assumption. -reflexivity. -apply div_mod_spec_div_mod. -unfold lt.apply le_S_S.apply le_O_n. -constructor 1.unfold lt.apply le_S_S.assumption. -reflexivity. -apply (trans_eq ? ? -(sigma n (\lambda n.((bool_to_nat (f1 n)) * -(sigma m (\lambda n.bool_to_nat (f2 n)) O))) O)). -apply eq_sigma. -intros. -rewrite > sym_times. -apply (trans_eq ? ? -(sigma m (\lambda n.(bool_to_nat (f2 n))*(bool_to_nat (f1 i))) O)). -reflexivity. -apply sym_eq. apply sigma_times. -change in match (pred (S n)) with n. -change in match (pred (S m)) with m. -apply sym_eq. apply sigma_times. -unfold permut. -split. -intros. -rewrite < plus_n_O. -apply le_S_S_to_le. -rewrite < S_pred in \vdash (? ? %). -change with ((g (i/(S n)) (i \mod (S n))) \lt (S n)*(S m)). -apply H. -apply lt_mod_m_m. -unfold lt. apply le_S_S.apply le_O_n. -apply (lt_times_to_lt_l n). -apply (le_to_lt_to_lt ? i). -rewrite > (div_mod i (S n)) in \vdash (? ? %). -rewrite > sym_plus. -apply le_plus_n. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. -rewrite > S_pred in \vdash (? ? %). -apply le_S_S. -rewrite > plus_n_O in \vdash (? ? %). -rewrite > sym_times. assumption. -rewrite > (times_n_O O). -apply lt_times. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. apply le_S_S.apply le_O_n. -rewrite > (times_n_O O). -apply lt_times. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. apply le_S_S.apply le_O_n. -rewrite < plus_n_O. -unfold injn. -intros. -cut (i < (S n)*(S m)). -cut (j < (S n)*(S m)). -cut ((i \mod (S n)) < (S n)). -cut ((i/(S n)) < (S m)). -cut ((j \mod (S n)) < (S n)). -cut ((j/(S n)) < (S m)). -rewrite > (div_mod i (S n)). -rewrite > (div_mod j (S n)). -rewrite < (H1 (i \mod (S n)) (i/(S n)) Hcut2 Hcut3). -rewrite < (H2 (i \mod (S n)) (i/(S n)) Hcut2 Hcut3) in \vdash (? ? (? % ?) ?). -rewrite < (H1 (j \mod (S n)) (j/(S n)) Hcut4 Hcut5). -rewrite < (H2 (j \mod (S n)) (j/(S n)) Hcut4 Hcut5) in \vdash (? ? ? (? % ?)). -rewrite > H6.reflexivity. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. apply le_S_S.apply le_O_n. -apply (lt_times_to_lt_l n). -apply (le_to_lt_to_lt ? j). -rewrite > (div_mod j (S n)) in \vdash (? ? %). -rewrite > sym_plus. -apply le_plus_n. -unfold lt. apply le_S_S.apply le_O_n. -rewrite < sym_times. assumption. -apply lt_mod_m_m. -unfold lt. apply le_S_S.apply le_O_n. -apply (lt_times_to_lt_l n). -apply (le_to_lt_to_lt ? i). -rewrite > (div_mod i (S n)) in \vdash (? ? %). -rewrite > sym_plus. -apply le_plus_n. -unfold lt. apply le_S_S.apply le_O_n. -rewrite < sym_times. assumption. -apply lt_mod_m_m. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. -rewrite > S_pred in \vdash (? ? %). -apply le_S_S.assumption. -rewrite > (times_n_O O). -apply lt_times. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. -rewrite > S_pred in \vdash (? ? %). -apply le_S_S.assumption. -rewrite > (times_n_O O). -apply lt_times. -unfold lt. apply le_S_S.apply le_O_n. -unfold lt. apply le_S_S.apply le_O_n. -intros. -apply False_ind. -apply (not_le_Sn_O m1 H4). -qed. diff --git a/helm/matita/library/nat/div_and_mod.ma b/helm/matita/library/nat/div_and_mod.ma deleted file mode 100644 index e9831f82a..000000000 --- a/helm/matita/library/nat/div_and_mod.ma +++ /dev/null @@ -1,298 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/div_and_mod". - -include "nat/minus.ma". - -let rec mod_aux p m n: nat \def -match (leb m n) with -[ true \Rightarrow m -| false \Rightarrow - match p with - [O \Rightarrow m - |(S q) \Rightarrow mod_aux q (m-(S n)) n]]. - -definition mod : nat \to nat \to nat \def -\lambda n,m. -match m with -[O \Rightarrow m -| (S p) \Rightarrow mod_aux n n p]. - -interpretation "natural remainder" 'module x y = - (cic:/matita/nat/div_and_mod/mod.con x y). - -let rec div_aux p m n : nat \def -match (leb m n) with -[ true \Rightarrow O -| false \Rightarrow - match p with - [O \Rightarrow O - |(S q) \Rightarrow S (div_aux q (m-(S n)) n)]]. - -definition div : nat \to nat \to nat \def -\lambda n,m. -match m with -[O \Rightarrow S n -| (S p) \Rightarrow div_aux n n p]. - -interpretation "natural divide" 'divide x y = - (cic:/matita/nat/div_and_mod/div.con x y). - -theorem le_mod_aux_m_m: -\forall p,n,m. n \leq p \to (mod_aux p n m) \leq m. -intro.elim p. -apply (le_n_O_elim n H (\lambda n.(mod_aux O n m) \leq m)). -simplify.apply le_O_n. -simplify. -apply (leb_elim n1 m). -simplify.intro.assumption. -simplify.intro.apply H. -cut (n1 \leq (S n) \to n1-(S m) \leq n). -apply Hcut.assumption. -elim n1. -simplify.apply le_O_n. -simplify.apply (trans_le ? n2 n). -apply le_minus_m.apply le_S_S_to_le.assumption. -qed. - -theorem lt_mod_m_m: \forall n,m. O < m \to (n \mod m) < m. -intros 2.elim m.apply False_ind. -apply (not_le_Sn_O O H). -simplify.unfold lt.apply le_S_S.apply le_mod_aux_m_m. -apply le_n. -qed. - -theorem div_aux_mod_aux: \forall p,n,m:nat. -(n=(div_aux p n m)*(S m) + (mod_aux p n m)). -intro.elim p. -simplify.elim (leb n m). -simplify.apply refl_eq. -simplify.apply refl_eq. -simplify. -apply (leb_elim n1 m). -simplify.intro.apply refl_eq. -simplify.intro. -rewrite > assoc_plus. -elim (H (n1-(S m)) m). -change with (n1=(S m)+(n1-(S m))). -rewrite < sym_plus. -apply plus_minus_m_m. -change with (m < n1). -apply not_le_to_lt.exact H1. -qed. - -theorem div_mod: \forall n,m:nat. O < m \to n=(n / m)*m+(n \mod m). -intros 2.elim m.elim (not_le_Sn_O O H). -simplify. -apply div_aux_mod_aux. -qed. - -inductive div_mod_spec (n,m,q,r:nat) : Prop \def -div_mod_spec_intro: r < m \to n=q*m+r \to (div_mod_spec n m q r). - -(* -definition div_mod_spec : nat \to nat \to nat \to nat \to Prop \def -\lambda n,m,q,r:nat.r < m \land n=q*m+r). -*) - -theorem div_mod_spec_to_not_eq_O: \forall n,m,q,r.(div_mod_spec n m q r) \to m \neq O. -intros 4.unfold Not.intros.elim H.absurd (le (S r) O). -rewrite < H1.assumption. -exact (not_le_Sn_O r). -qed. - -theorem div_mod_spec_div_mod: -\forall n,m. O < m \to (div_mod_spec n m (n / m) (n \mod m)). -intros. -apply div_mod_spec_intro. -apply lt_mod_m_m.assumption. -apply div_mod.assumption. -qed. - -theorem div_mod_spec_to_eq :\forall a,b,q,r,q1,r1. -(div_mod_spec a b q r) \to (div_mod_spec a b q1 r1) \to -(eq nat q q1). -intros.elim H.elim H1. -apply (nat_compare_elim q q1).intro. -apply False_ind. -cut (eq nat ((q1-q)*b+r1) r). -cut (b \leq (q1-q)*b+r1). -cut (b \leq r). -apply (lt_to_not_le r b H2 Hcut2). -elim Hcut.assumption. -apply (trans_le ? ((q1-q)*b)). -apply le_times_n. -apply le_SO_minus.exact H6. -rewrite < sym_plus. -apply le_plus_n. -rewrite < sym_times. -rewrite > distr_times_minus. -rewrite > plus_minus. -rewrite > sym_times. -rewrite < H5. -rewrite < sym_times. -apply plus_to_minus. -apply H3. -apply le_times_r. -apply lt_to_le. -apply H6. -(* eq case *) -intros.assumption. -(* the following case is symmetric *) -intro. -apply False_ind. -cut (eq nat ((q-q1)*b+r) r1). -cut (b \leq (q-q1)*b+r). -cut (b \leq r1). -apply (lt_to_not_le r1 b H4 Hcut2). -elim Hcut.assumption. -apply (trans_le ? ((q-q1)*b)). -apply le_times_n. -apply le_SO_minus.exact H6. -rewrite < sym_plus. -apply le_plus_n. -rewrite < sym_times. -rewrite > distr_times_minus. -rewrite > plus_minus. -rewrite > sym_times. -rewrite < H3. -rewrite < sym_times. -apply plus_to_minus. -apply H5. -apply le_times_r. -apply lt_to_le. -apply H6. -qed. - -theorem div_mod_spec_to_eq2 :\forall a,b,q,r,q1,r1. -(div_mod_spec a b q r) \to (div_mod_spec a b q1 r1) \to -(eq nat r r1). -intros.elim H.elim H1. -apply (inj_plus_r (q*b)). -rewrite < H3. -rewrite > (div_mod_spec_to_eq a b q r q1 r1 H H1). -assumption. -qed. - -theorem div_mod_spec_times : \forall n,m:nat.div_mod_spec ((S n)*m) (S n) m O. -intros.constructor 1. -unfold lt.apply le_S_S.apply le_O_n. -rewrite < plus_n_O.rewrite < sym_times.reflexivity. -qed. - -(* some properties of div and mod *) -theorem div_times: \forall n,m:nat. ((S n)*m) / (S n) = m. -intros. -apply (div_mod_spec_to_eq ((S n)*m) (S n) ? ? ? O). -goal 15. (* ?11 is closed with the following tactics *) -apply div_mod_spec_div_mod. -unfold lt.apply le_S_S.apply le_O_n. -apply div_mod_spec_times. -qed. - -theorem div_n_n: \forall n:nat. O < n \to n / n = S O. -intros. -apply (div_mod_spec_to_eq n n (n / n) (n \mod n) (S O) O). -apply div_mod_spec_div_mod.assumption. -constructor 1.assumption. -rewrite < plus_n_O.simplify.rewrite < plus_n_O.reflexivity. -qed. - -theorem eq_div_O: \forall n,m. n < m \to n / m = O. -intros. -apply (div_mod_spec_to_eq n m (n/m) (n \mod m) O n). -apply div_mod_spec_div_mod. -apply (le_to_lt_to_lt O n m). -apply le_O_n.assumption. -constructor 1.assumption.reflexivity. -qed. - -theorem mod_n_n: \forall n:nat. O < n \to n \mod n = O. -intros. -apply (div_mod_spec_to_eq2 n n (n / n) (n \mod n) (S O) O). -apply div_mod_spec_div_mod.assumption. -constructor 1.assumption. -rewrite < plus_n_O.simplify.rewrite < plus_n_O.reflexivity. -qed. - -theorem mod_S: \forall n,m:nat. O < m \to S (n \mod m) < m \to -((S n) \mod m) = S (n \mod m). -intros. -apply (div_mod_spec_to_eq2 (S n) m ((S n) / m) ((S n) \mod m) (n / m) (S (n \mod m))). -apply div_mod_spec_div_mod.assumption. -constructor 1.assumption.rewrite < plus_n_Sm. -apply eq_f. -apply div_mod. -assumption. -qed. - -theorem mod_O_n: \forall n:nat.O \mod n = O. -intro.elim n.simplify.reflexivity. -simplify.reflexivity. -qed. - -theorem lt_to_eq_mod:\forall n,m:nat. n < m \to n \mod m = n. -intros. -apply (div_mod_spec_to_eq2 n m (n/m) (n \mod m) O n). -apply div_mod_spec_div_mod. -apply (le_to_lt_to_lt O n m).apply le_O_n.assumption. -constructor 1. -assumption.reflexivity. -qed. - -(* injectivity *) -theorem injective_times_r: \forall n:nat.injective nat nat (\lambda m:nat.(S n)*m). -change with (\forall n,p,q:nat.(S n)*p = (S n)*q \to p=q). -intros. -rewrite < (div_times n). -rewrite < (div_times n q). -apply eq_f2.assumption. -reflexivity. -qed. - -variant inj_times_r : \forall n,p,q:nat.(S n)*p = (S n)*q \to p=q \def -injective_times_r. - -theorem lt_O_to_injective_times_r: \forall n:nat. O < n \to injective nat nat (\lambda m:nat.n*m). -change with (\forall n. O < n \to \forall p,q:nat.n*p = n*q \to p=q). -intros 4. -apply (lt_O_n_elim n H).intros. -apply (inj_times_r m).assumption. -qed. - -variant inj_times_r1:\forall n. O < n \to \forall p,q:nat.n*p = n*q \to p=q -\def lt_O_to_injective_times_r. - -theorem injective_times_l: \forall n:nat.injective nat nat (\lambda m:nat.m*(S n)). -change with (\forall n,p,q:nat.p*(S n) = q*(S n) \to p=q). -intros. -apply (inj_times_r n p q). -rewrite < sym_times. -rewrite < (sym_times q). -assumption. -qed. - -variant inj_times_l : \forall n,p,q:nat. p*(S n) = q*(S n) \to p=q \def -injective_times_l. - -theorem lt_O_to_injective_times_l: \forall n:nat. O < n \to injective nat nat (\lambda m:nat.m*n). -change with (\forall n. O < n \to \forall p,q:nat.p*n = q*n \to p=q). -intros 4. -apply (lt_O_n_elim n H).intros. -apply (inj_times_l m).assumption. -qed. - -variant inj_times_l1:\forall n. O < n \to \forall p,q:nat.p*n = q*n \to p=q -\def lt_O_to_injective_times_l. diff --git a/helm/matita/library/nat/exp.ma b/helm/matita/library/nat/exp.ma deleted file mode 100644 index 11d84f74c..000000000 --- a/helm/matita/library/nat/exp.ma +++ /dev/null @@ -1,97 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/exp". - -include "nat/div_and_mod.ma". - -let rec exp n m on m\def - match m with - [ O \Rightarrow (S O) - | (S p) \Rightarrow (times n (exp n p)) ]. - -interpretation "natural exponent" 'exp a b = (cic:/matita/nat/exp/exp.con a b). - -theorem exp_plus_times : \forall n,p,q:nat. -n \sup (p + q) = (n \sup p) * (n \sup q). -intros.elim p. -simplify.rewrite < plus_n_O.reflexivity. -simplify.rewrite > H.symmetry. -apply assoc_times. -qed. - -theorem exp_n_O : \forall n:nat. S O = n \sup O. -intro.simplify.reflexivity. -qed. - -theorem exp_n_SO : \forall n:nat. n = n \sup (S O). -intro.simplify.rewrite < times_n_SO.reflexivity. -qed. - -theorem exp_exp_times : \forall n,p,q:nat. -(n \sup p) \sup q = n \sup (p * q). -intros. -elim q.simplify.rewrite < times_n_O.simplify.reflexivity. -simplify.rewrite > H.rewrite < exp_plus_times. -rewrite < times_n_Sm.reflexivity. -qed. - -theorem lt_O_exp: \forall n,m:nat. O < n \to O < n \sup m. -intros.elim m.simplify.unfold lt.apply le_n. -simplify.unfold lt.rewrite > times_n_SO. -apply le_times.assumption.assumption. -qed. - -theorem lt_m_exp_nm: \forall n,m:nat. (S O) < n \to m < n \sup m. -intros.elim m.simplify.unfold lt.reflexivity. -simplify.unfold lt. -apply (trans_le ? ((S(S O))*(S n1))). -simplify. -rewrite < plus_n_Sm.apply le_S_S.apply le_S_S. -rewrite < sym_plus. -apply le_plus_n. -apply le_times.assumption.assumption. -qed. - -theorem exp_to_eq_O: \forall n,m:nat. (S O) < n -\to n \sup m = (S O) \to m = O. -intros.apply antisym_le.apply le_S_S_to_le. -rewrite < H1.change with (m < n \sup m). -apply lt_m_exp_nm.assumption. -apply le_O_n. -qed. - -theorem injective_exp_r: \forall n:nat. (S O) < n \to -injective nat nat (\lambda m:nat. n \sup m). -simplify.intros 4. -apply (nat_elim2 (\lambda x,y.n \sup x = n \sup y \to x = y)). -intros.apply sym_eq.apply (exp_to_eq_O n).assumption. -rewrite < H1.reflexivity. -intros.apply (exp_to_eq_O n).assumption.assumption. -intros.apply eq_f. -apply H1. -(* esprimere inj_times senza S *) -cut (\forall a,b:nat.O < n \to n*a=n*b \to a=b). -apply Hcut.simplify.unfold lt.apply le_S_S_to_le. apply le_S. assumption. -assumption. -intros 2. -apply (nat_case n). -intros.apply False_ind.apply (not_le_Sn_O O H3). -intros. -apply (inj_times_r m1).assumption. -qed. - -variant inj_exp_r: \forall p:nat. (S O) < p \to \forall n,m:nat. -p \sup n = p \sup m \to n = m \def -injective_exp_r. diff --git a/helm/matita/library/nat/factorial.ma b/helm/matita/library/nat/factorial.ma deleted file mode 100644 index 14217bbcb..000000000 --- a/helm/matita/library/nat/factorial.ma +++ /dev/null @@ -1,61 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/factorial". - -include "nat/le_arith.ma". - -let rec fact n \def - match n with - [ O \Rightarrow (S O) - | (S m) \Rightarrow (S m)*(fact m)]. - -interpretation "factorial" 'fact n = (cic:/matita/nat/factorial/fact.con n). - -theorem le_SO_fact : \forall n. (S O) \le n!. -intro.elim n.simplify.apply le_n. -change with ((S O) \le (S n1)*n1!). -apply (trans_le ? ((S n1)*(S O))).simplify. -apply le_S_S.apply le_O_n. -apply le_times_r.assumption. -qed. - -theorem le_SSO_fact : \forall n. (S O) < n \to (S(S O)) \le n!. -intro.apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S O) H). -intros.change with ((S (S O)) \le (S m)*m!). -apply (trans_le ? ((S(S O))*(S O))).apply le_n. -apply le_times.exact H.apply le_SO_fact. -qed. - -theorem le_n_fact_n: \forall n. n \le n!. -intro. elim n.apply le_O_n. -change with (S n1 \le (S n1)*n1!). -apply (trans_le ? ((S n1)*(S O))). -rewrite < times_n_SO.apply le_n. -apply le_times.apply le_n. -apply le_SO_fact. -qed. - -theorem lt_n_fact_n: \forall n. (S(S O)) < n \to n < n!. -intro.apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S(S O)) H). -intros.change with ((S m) < (S m)*m!). -apply (lt_to_le_to_lt ? ((S m)*(S (S O)))). -rewrite < sym_times. -simplify.unfold lt. -apply le_S_S.rewrite < plus_n_O. -apply le_plus_n. -apply le_times_r.apply le_SSO_fact. -simplify.unfold lt.apply le_S_S_to_le.exact H. -qed. - diff --git a/helm/matita/library/nat/factorization.ma b/helm/matita/library/nat/factorization.ma deleted file mode 100644 index 37b5ea1dd..000000000 --- a/helm/matita/library/nat/factorization.ma +++ /dev/null @@ -1,619 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/factorization". - -include "nat/ord.ma". -include "nat/gcd.ma". -include "nat/nth_prime.ma". - -(* the following factorization algorithm looks for the largest prime - factor. *) -definition max_prime_factor \def \lambda n:nat. -(max n (\lambda p:nat.eqb (n \mod (nth_prime p)) O)). - -(* max_prime_factor is indeed a factor *) -theorem divides_max_prime_factor_n: - \forall n:nat. (S O) < n - \to nth_prime (max_prime_factor n) \divides n. -intros; apply divides_b_true_to_divides; -[ apply lt_O_nth_prime_n; -| apply (f_max_true (\lambda p:nat.eqb (n \mod (nth_prime p)) O) n); - cut (\exists i. nth_prime i = smallest_factor n); - [ elim Hcut. - apply (ex_intro nat ? a); - split; - [ apply (trans_le a (nth_prime a)); - [ apply le_n_fn; - exact lt_nth_prime_n_nth_prime_Sn; - | rewrite > H1; - apply le_smallest_factor_n; ] - | rewrite > H1; - change with (divides_b (smallest_factor n) n = true); - apply divides_to_divides_b_true; - [ apply (trans_lt ? (S O)); - [ unfold lt; apply le_n; - | apply lt_SO_smallest_factor; assumption; ] - | apply divides_smallest_factor_n; - apply (trans_lt ? (S O)); - [ unfold lt; apply le_n; - | assumption; ] ] ] - | apply prime_to_nth_prime; - apply prime_smallest_factor_n; - assumption; ] ] -qed. - -theorem divides_to_max_prime_factor : \forall n,m. (S O) < n \to O < m \to n \divides m \to -max_prime_factor n \le max_prime_factor m. -intros.change with -((max n (\lambda p:nat.eqb (n \mod (nth_prime p)) O)) \le -(max m (\lambda p:nat.eqb (m \mod (nth_prime p)) O))). -apply f_m_to_le_max. -apply (trans_le ? n). -apply le_max_n.apply divides_to_le.assumption.assumption. -change with (divides_b (nth_prime (max_prime_factor n)) m = true). -apply divides_to_divides_b_true. -cut (prime (nth_prime (max_prime_factor n))). -apply lt_O_nth_prime_n.apply prime_nth_prime. -cut (nth_prime (max_prime_factor n) \divides n). -apply (transitive_divides ? n). -apply divides_max_prime_factor_n. -assumption.assumption. -apply divides_b_true_to_divides. -apply lt_O_nth_prime_n. -apply divides_to_divides_b_true. -apply lt_O_nth_prime_n. -apply divides_max_prime_factor_n. -assumption. -qed. - -theorem p_ord_to_lt_max_prime_factor: \forall n,p,q,r. O < n \to -p = max_prime_factor n \to -(pair nat nat q r) = p_ord n (nth_prime p) \to -(S O) < r \to max_prime_factor r < p. -intros. -rewrite > H1. -cut (max_prime_factor r \lt max_prime_factor n \lor - max_prime_factor r = max_prime_factor n). -elim Hcut.assumption. -absurd (nth_prime (max_prime_factor n) \divides r). -rewrite < H4. -apply divides_max_prime_factor_n. -assumption. -change with (nth_prime (max_prime_factor n) \divides r \to False). -intro. -cut (r \mod (nth_prime (max_prime_factor n)) \neq O). -apply Hcut1.apply divides_to_mod_O. -apply lt_O_nth_prime_n.assumption. -apply (p_ord_aux_to_not_mod_O n n ? q r). -apply lt_SO_nth_prime_n.assumption. -apply le_n. -rewrite < H1.assumption. -apply (le_to_or_lt_eq (max_prime_factor r) (max_prime_factor n)). -apply divides_to_max_prime_factor. -assumption.assumption. -apply (witness r n ((nth_prime p) \sup q)). -rewrite < sym_times. -apply (p_ord_aux_to_exp n n ? q r). -apply lt_O_nth_prime_n.assumption. -qed. - -theorem p_ord_to_lt_max_prime_factor1: \forall n,p,q,r. O < n \to -max_prime_factor n \le p \to -(pair nat nat q r) = p_ord n (nth_prime p) \to -(S O) < r \to max_prime_factor r < p. -intros. -cut (max_prime_factor n < p \lor max_prime_factor n = p). -elim Hcut.apply (le_to_lt_to_lt ? (max_prime_factor n)). -apply divides_to_max_prime_factor.assumption.assumption. -apply (witness r n ((nth_prime p) \sup q)). -rewrite > sym_times. -apply (p_ord_aux_to_exp n n). -apply lt_O_nth_prime_n. -assumption.assumption. -apply (p_ord_to_lt_max_prime_factor n ? q). -assumption.apply sym_eq.assumption.assumption.assumption. -apply (le_to_or_lt_eq ? p H1). -qed. - -(* datatypes and functions *) - -inductive nat_fact : Set \def - nf_last : nat \to nat_fact - | nf_cons : nat \to nat_fact \to nat_fact. - -inductive nat_fact_all : Set \def - nfa_zero : nat_fact_all - | nfa_one : nat_fact_all - | nfa_proper : nat_fact \to nat_fact_all. - -let rec factorize_aux p n acc \def - match p with - [ O \Rightarrow acc - | (S p1) \Rightarrow - match p_ord n (nth_prime p1) with - [ (pair q r) \Rightarrow - factorize_aux p1 r (nf_cons q acc)]]. - -definition factorize : nat \to nat_fact_all \def \lambda n:nat. - match n with - [ O \Rightarrow nfa_zero - | (S n1) \Rightarrow - match n1 with - [ O \Rightarrow nfa_one - | (S n2) \Rightarrow - let p \def (max (S(S n2)) (\lambda p:nat.eqb ((S(S n2)) \mod (nth_prime p)) O)) in - match p_ord (S(S n2)) (nth_prime p) with - [ (pair q r) \Rightarrow - nfa_proper (factorize_aux p r (nf_last (pred q)))]]]. - -let rec defactorize_aux f i \def - match f with - [ (nf_last n) \Rightarrow (nth_prime i) \sup (S n) - | (nf_cons n g) \Rightarrow - (nth_prime i) \sup n *(defactorize_aux g (S i))]. - -definition defactorize : nat_fact_all \to nat \def -\lambda f : nat_fact_all. -match f with -[ nfa_zero \Rightarrow O -| nfa_one \Rightarrow (S O) -| (nfa_proper g) \Rightarrow defactorize_aux g O]. - -theorem lt_O_defactorize_aux: \forall f:nat_fact.\forall i:nat. -O < defactorize_aux f i. -intro.elim f.simplify.unfold lt. -rewrite > times_n_SO. -apply le_times. -change with (O < nth_prime i). -apply lt_O_nth_prime_n. -change with (O < exp (nth_prime i) n). -apply lt_O_exp. -apply lt_O_nth_prime_n. -simplify.unfold lt. -rewrite > times_n_SO. -apply le_times. -change with (O < exp (nth_prime i) n). -apply lt_O_exp. -apply lt_O_nth_prime_n. -change with (O < defactorize_aux n1 (S i)). -apply H. -qed. - -theorem lt_SO_defactorize_aux: \forall f:nat_fact.\forall i:nat. -S O < defactorize_aux f i. -intro.elim f.simplify.unfold lt. -rewrite > times_n_SO. -apply le_times. -change with (S O < nth_prime i). -apply lt_SO_nth_prime_n. -change with (O < exp (nth_prime i) n). -apply lt_O_exp. -apply lt_O_nth_prime_n. -simplify.unfold lt. -rewrite > times_n_SO. -rewrite > sym_times. -apply le_times. -change with (O < exp (nth_prime i) n). -apply lt_O_exp. -apply lt_O_nth_prime_n. -change with (S O < defactorize_aux n1 (S i)). -apply H. -qed. - -theorem defactorize_aux_factorize_aux : -\forall p,n:nat.\forall acc:nat_fact.O < n \to -((n=(S O) \land p=O) \lor max_prime_factor n < p) \to -defactorize_aux (factorize_aux p n acc) O = n*(defactorize_aux acc p). -intro.elim p.simplify. -elim H1.elim H2.rewrite > H3. -rewrite > sym_times. apply times_n_SO. -apply False_ind.apply (not_le_Sn_O (max_prime_factor n) H2). -simplify. -(* generalizing the goal: I guess there exists a better way *) -cut (\forall q,r.(pair nat nat q r) = (p_ord_aux n1 n1 (nth_prime n)) \to -defactorize_aux match (p_ord_aux n1 n1 (nth_prime n)) with -[(pair q r) \Rightarrow (factorize_aux n r (nf_cons q acc))] O = -n1*defactorize_aux acc (S n)). -apply (Hcut (fst ? ? (p_ord_aux n1 n1 (nth_prime n))) -(snd ? ? (p_ord_aux n1 n1 (nth_prime n)))). -apply sym_eq.apply eq_pair_fst_snd. -intros. -rewrite < H3. -simplify. -cut (n1 = r * (nth_prime n) \sup q). -rewrite > H. -simplify.rewrite < assoc_times. -rewrite < Hcut.reflexivity. -cut (O < r \lor O = r). -elim Hcut1.assumption.absurd (n1 = O). -rewrite > Hcut.rewrite < H4.reflexivity. -unfold Not. intro.apply (not_le_Sn_O O). -rewrite < H5 in \vdash (? ? %).assumption. -apply le_to_or_lt_eq.apply le_O_n. -cut ((S O) < r \lor (S O) \nlt r). -elim Hcut1. -right. -apply (p_ord_to_lt_max_prime_factor1 n1 ? q r). -assumption.elim H2. -elim H5. -apply False_ind. -apply (not_eq_O_S n).apply sym_eq.assumption. -apply le_S_S_to_le. -exact H5. -assumption.assumption. -cut (r=(S O)). -apply (nat_case n). -left.split.assumption.reflexivity. -intro.right.rewrite > Hcut2. -simplify.unfold lt.apply le_S_S.apply le_O_n. -cut (r \lt (S O) \or r=(S O)). -elim Hcut2.absurd (O=r). -apply le_n_O_to_eq.apply le_S_S_to_le.exact H5. -unfold Not.intro. -cut (O=n1). -apply (not_le_Sn_O O). -rewrite > Hcut3 in \vdash (? ? %). -assumption.rewrite > Hcut. -rewrite < H6.reflexivity. -assumption. -apply (le_to_or_lt_eq r (S O)). -apply not_lt_to_le.assumption. -apply (decidable_lt (S O) r). -rewrite > sym_times. -apply (p_ord_aux_to_exp n1 n1). -apply lt_O_nth_prime_n.assumption. -qed. - -theorem defactorize_factorize: \forall n:nat.defactorize (factorize n) = n. -intro. -apply (nat_case n).reflexivity. -intro.apply (nat_case m).reflexivity. -intro.change with -(let p \def (max (S(S m1)) (\lambda p:nat.eqb ((S(S m1)) \mod (nth_prime p)) O)) in -defactorize (match p_ord (S(S m1)) (nth_prime p) with -[ (pair q r) \Rightarrow - nfa_proper (factorize_aux p r (nf_last (pred q)))])=(S(S m1))). -intro. -(* generalizing the goal; find a better way *) -cut (\forall q,r.(pair nat nat q r) = (p_ord (S(S m1)) (nth_prime p)) \to -defactorize (match p_ord (S(S m1)) (nth_prime p) with -[ (pair q r) \Rightarrow - nfa_proper (factorize_aux p r (nf_last (pred q)))])=(S(S m1))). -apply (Hcut (fst ? ? (p_ord (S(S m1)) (nth_prime p))) -(snd ? ? (p_ord (S(S m1)) (nth_prime p)))). -apply sym_eq.apply eq_pair_fst_snd. -intros. -rewrite < H. -change with -(defactorize_aux (factorize_aux p r (nf_last (pred q))) O = (S(S m1))). -cut ((S(S m1)) = (nth_prime p) \sup q *r). -cut (O defactorize_aux_factorize_aux. -change with (r*(nth_prime p) \sup (S (pred q)) = (S(S m1))). -cut ((S (pred q)) = q). -rewrite > Hcut2. -rewrite > sym_times. -apply sym_eq. -apply (p_ord_aux_to_exp (S(S m1))). -apply lt_O_nth_prime_n. -assumption. -(* O < q *) -apply sym_eq. apply S_pred. -cut (O < q \lor O = q). -elim Hcut2.assumption. -absurd (nth_prime p \divides S (S m1)). -apply (divides_max_prime_factor_n (S (S m1))). -unfold lt.apply le_S_S.apply le_S_S. apply le_O_n. -cut ((S(S m1)) = r). -rewrite > Hcut3 in \vdash (? (? ? %)). -change with (nth_prime p \divides r \to False). -intro. -apply (p_ord_aux_to_not_mod_O (S(S m1)) (S(S m1)) (nth_prime p) q r). -apply lt_SO_nth_prime_n. -unfold lt.apply le_S_S.apply le_O_n.apply le_n. -assumption. -apply divides_to_mod_O.apply lt_O_nth_prime_n.assumption. -rewrite > times_n_SO in \vdash (? ? ? %). -rewrite < sym_times. -rewrite > (exp_n_O (nth_prime p)). -rewrite > H1 in \vdash (? ? ? (? (? ? %) ?)). -assumption. -apply le_to_or_lt_eq.apply le_O_n.assumption. -(* e adesso l'ultimo goal. TASSI: che ora non e' piu' l'ultimo :P *) -cut ((S O) < r \lor S O \nlt r). -elim Hcut2. -right. -apply (p_ord_to_lt_max_prime_factor1 (S(S m1)) ? q r). -unfold lt.apply le_S_S. apply le_O_n. -apply le_n. -assumption.assumption. -cut (r=(S O)). -apply (nat_case p). -left.split.assumption.reflexivity. -intro.right.rewrite > Hcut3. -simplify.unfold lt.apply le_S_S.apply le_O_n. -cut (r \lt (S O) \or r=(S O)). -elim Hcut3.absurd (O=r). -apply le_n_O_to_eq.apply le_S_S_to_le.exact H2. -unfold Not.intro. -apply (not_le_Sn_O O). -rewrite > H3 in \vdash (? ? %).assumption.assumption. -apply (le_to_or_lt_eq r (S O)). -apply not_lt_to_le.assumption. -apply (decidable_lt (S O) r). -(* O < r *) -cut (O < r \lor O = r). -elim Hcut1.assumption. -apply False_ind. -apply (not_eq_O_S (S m1)). -rewrite > Hcut.rewrite < H1.rewrite < times_n_O.reflexivity. -apply le_to_or_lt_eq.apply le_O_n. -(* prova del cut *) -goal 20. -apply (p_ord_aux_to_exp (S(S m1))). -apply lt_O_nth_prime_n. -assumption. -(* fine prova cut *) -qed. - -let rec max_p f \def -match f with -[ (nf_last n) \Rightarrow O -| (nf_cons n g) \Rightarrow S (max_p g)]. - -let rec max_p_exponent f \def -match f with -[ (nf_last n) \Rightarrow n -| (nf_cons n g) \Rightarrow max_p_exponent g]. - -theorem divides_max_p_defactorize: \forall f:nat_fact.\forall i:nat. -nth_prime ((max_p f)+i) \divides defactorize_aux f i. -intro. -elim f.simplify.apply (witness ? ? ((nth_prime i) \sup n)). -reflexivity. -change with -(nth_prime (S(max_p n1)+i) \divides -(nth_prime i) \sup n *(defactorize_aux n1 (S i))). -elim (H (S i)). -rewrite > H1. -rewrite < sym_times. -rewrite > assoc_times. -rewrite < plus_n_Sm. -apply (witness ? ? (n2* (nth_prime i) \sup n)). -reflexivity. -qed. - -theorem divides_exp_to_divides: -\forall p,n,m:nat. prime p \to -p \divides n \sup m \to p \divides n. -intros 3.elim m.simplify in H1. -apply (transitive_divides p (S O)).assumption. -apply divides_SO_n. -cut (p \divides n \lor p \divides n \sup n1). -elim Hcut.assumption. -apply H.assumption.assumption. -apply divides_times_to_divides.assumption. -exact H2. -qed. - -theorem divides_exp_to_eq: -\forall p,q,m:nat. prime p \to prime q \to -p \divides q \sup m \to p = q. -intros. -unfold prime in H1. -elim H1.apply H4. -apply (divides_exp_to_divides p q m). -assumption.assumption. -unfold prime in H.elim H.assumption. -qed. - -theorem not_divides_defactorize_aux: \forall f:nat_fact. \forall i,j:nat. -i < j \to nth_prime i \ndivides defactorize_aux f j. -intro.elim f. -change with -(nth_prime i \divides (nth_prime j) \sup (S n) \to False). -intro.absurd ((nth_prime i) = (nth_prime j)). -apply (divides_exp_to_eq ? ? (S n)). -apply prime_nth_prime.apply prime_nth_prime. -assumption. -change with ((nth_prime i) = (nth_prime j) \to False). -intro.cut (i = j). -apply (not_le_Sn_n i).rewrite > Hcut in \vdash (? ? %).assumption. -apply (injective_nth_prime ? ? H2). -change with -(nth_prime i \divides (nth_prime j) \sup n *(defactorize_aux n1 (S j)) \to False). -intro. -cut (nth_prime i \divides (nth_prime j) \sup n -\lor nth_prime i \divides defactorize_aux n1 (S j)). -elim Hcut. -absurd ((nth_prime i) = (nth_prime j)). -apply (divides_exp_to_eq ? ? n). -apply prime_nth_prime.apply prime_nth_prime. -assumption. -change with ((nth_prime i) = (nth_prime j) \to False). -intro. -cut (i = j). -apply (not_le_Sn_n i).rewrite > Hcut1 in \vdash (? ? %).assumption. -apply (injective_nth_prime ? ? H4). -apply (H i (S j)). -apply (trans_lt ? j).assumption.unfold lt.apply le_n. -assumption. -apply divides_times_to_divides. -apply prime_nth_prime.assumption. -qed. - -lemma not_eq_nf_last_nf_cons: \forall g:nat_fact.\forall n,m,i:nat. -\lnot (defactorize_aux (nf_last n) i= defactorize_aux (nf_cons m g) i). -intros. -change with -(exp (nth_prime i) (S n) = defactorize_aux (nf_cons m g) i \to False). -intro. -cut (S(max_p g)+i= i). -apply (not_le_Sn_n i). -rewrite < Hcut in \vdash (? ? %). -simplify.apply le_S_S. -apply le_plus_n. -apply injective_nth_prime. -(* uffa, perche' semplifica ? *) -change with (nth_prime (S(max_p g)+i)= nth_prime i). -apply (divides_exp_to_eq ? ? (S n)). -apply prime_nth_prime.apply prime_nth_prime. -rewrite > H. -change with (divides (nth_prime ((max_p (nf_cons m g))+i)) -(defactorize_aux (nf_cons m g) i)). -apply divides_max_p_defactorize. -qed. - -lemma not_eq_nf_cons_O_nf_cons: \forall f,g:nat_fact.\forall n,i:nat. -\lnot (defactorize_aux (nf_cons O f) i= defactorize_aux (nf_cons (S n) g) i). -intros. -simplify.unfold Not.rewrite < plus_n_O. -intro. -apply (not_divides_defactorize_aux f i (S i) ?). -unfold lt.apply le_n. -rewrite > H. -rewrite > assoc_times. -apply (witness ? ? ((exp (nth_prime i) n)*(defactorize_aux g (S i)))). -reflexivity. -qed. - -theorem eq_defactorize_aux_to_eq: \forall f,g:nat_fact.\forall i:nat. -defactorize_aux f i = defactorize_aux g i \to f = g. -intro. -elim f. -generalize in match H. -elim g. -apply eq_f. -apply inj_S. apply (inj_exp_r (nth_prime i)). -apply lt_SO_nth_prime_n. -assumption. -apply False_ind. -apply (not_eq_nf_last_nf_cons n2 n n1 i H2). -generalize in match H1. -elim g. -apply False_ind. -apply (not_eq_nf_last_nf_cons n1 n2 n i). -apply sym_eq. assumption. -simplify in H3. -generalize in match H3. -apply (nat_elim2 (\lambda n,n2. -((nth_prime i) \sup n)*(defactorize_aux n1 (S i)) = -((nth_prime i) \sup n2)*(defactorize_aux n3 (S i)) \to -nf_cons n n1 = nf_cons n2 n3)). -intro. -elim n4. apply eq_f. -apply (H n3 (S i)). -simplify in H4. -rewrite > plus_n_O. -rewrite > (plus_n_O (defactorize_aux n3 (S i))).assumption. -apply False_ind. -apply (not_eq_nf_cons_O_nf_cons n1 n3 n5 i).assumption. -intros. -apply False_ind. -apply (not_eq_nf_cons_O_nf_cons n3 n1 n4 i). -apply sym_eq.assumption. -intros. -cut (nf_cons n4 n1 = nf_cons m n3). -cut (n4=m). -cut (n1=n3). -rewrite > Hcut1.rewrite > Hcut2.reflexivity. -change with -(match nf_cons n4 n1 with -[ (nf_last m) \Rightarrow n1 -| (nf_cons m g) \Rightarrow g ] = n3). -rewrite > Hcut.simplify.reflexivity. -change with -(match nf_cons n4 n1 with -[ (nf_last m) \Rightarrow m -| (nf_cons m g) \Rightarrow m ] = m). -rewrite > Hcut.simplify.reflexivity. -apply H4.simplify in H5. -apply (inj_times_r1 (nth_prime i)). -apply lt_O_nth_prime_n. -rewrite < assoc_times.rewrite < assoc_times.assumption. -qed. - -theorem injective_defactorize_aux: \forall i:nat. -injective nat_fact nat (\lambda f.defactorize_aux f i). -change with (\forall i:nat.\forall f,g:nat_fact. -defactorize_aux f i = defactorize_aux g i \to f = g). -intros. -apply (eq_defactorize_aux_to_eq f g i H). -qed. - -theorem injective_defactorize: -injective nat_fact_all nat defactorize. -change with (\forall f,g:nat_fact_all. -defactorize f = defactorize g \to f = g). -intro.elim f. -generalize in match H.elim g. -(* zero - zero *) -reflexivity. -(* zero - one *) -simplify in H1. -apply False_ind. -apply (not_eq_O_S O H1). -(* zero - proper *) -simplify in H1. -apply False_ind. -apply (not_le_Sn_n O). -rewrite > H1 in \vdash (? ? %). -change with (O < defactorize_aux n O). -apply lt_O_defactorize_aux. -generalize in match H. -elim g. -(* one - zero *) -simplify in H1. -apply False_ind. -apply (not_eq_O_S O).apply sym_eq. assumption. -(* one - one *) -reflexivity. -(* one - proper *) -simplify in H1. -apply False_ind. -apply (not_le_Sn_n (S O)). -rewrite > H1 in \vdash (? ? %). -change with ((S O) < defactorize_aux n O). -apply lt_SO_defactorize_aux. -generalize in match H.elim g. -(* proper - zero *) -simplify in H1. -apply False_ind. -apply (not_le_Sn_n O). -rewrite < H1 in \vdash (? ? %). -change with (O < defactorize_aux n O). -apply lt_O_defactorize_aux. -(* proper - one *) -simplify in H1. -apply False_ind. -apply (not_le_Sn_n (S O)). -rewrite < H1 in \vdash (? ? %). -change with ((S O) < defactorize_aux n O). -apply lt_SO_defactorize_aux. -(* proper - proper *) -apply eq_f. -apply (injective_defactorize_aux O). -exact H1. -qed. - -theorem factorize_defactorize: -\forall f,g: nat_fact_all. factorize (defactorize f) = f. -intros. -apply injective_defactorize. -(* uffa: perche' semplifica ??? *) -change with (defactorize(factorize (defactorize f)) = (defactorize f)). -apply defactorize_factorize. -qed. - diff --git a/helm/matita/library/nat/fermat_little_theorem.ma b/helm/matita/library/nat/fermat_little_theorem.ma deleted file mode 100644 index cc18a8bb9..000000000 --- a/helm/matita/library/nat/fermat_little_theorem.ma +++ /dev/null @@ -1,250 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/fermat_little_theorem". - -include "nat/exp.ma". -include "nat/gcd.ma". -include "nat/permutation.ma". -include "nat/congruence.ma". - -theorem permut_S_mod: \forall n:nat. permut (S_mod (S n)) n. -intro.unfold permut.split.intros. -unfold S_mod. -apply le_S_S_to_le. -change with ((S i) \mod (S n) < S n). -apply lt_mod_m_m. -unfold lt.apply le_S_S.apply le_O_n. -unfold injn.intros. -apply inj_S. -rewrite < (lt_to_eq_mod i (S n)). -rewrite < (lt_to_eq_mod j (S n)). -cut (i < n \lor i = n). -cut (j < n \lor j = n). -elim Hcut. -elim Hcut1. -(* i < n, j< n *) -rewrite < mod_S. -rewrite < mod_S. -apply H2.unfold lt.apply le_S_S.apply le_O_n. -rewrite > lt_to_eq_mod. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.apply le_O_n. -rewrite > lt_to_eq_mod. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.assumption. -(* i < n, j=n *) -unfold S_mod in H2. -simplify. -apply False_ind. -apply (not_eq_O_S (i \mod (S n))). -apply sym_eq. -rewrite < (mod_n_n (S n)). -rewrite < H4 in \vdash (? ? ? (? %?)). -rewrite < mod_S.assumption. -unfold lt.apply le_S_S.apply le_O_n. -rewrite > lt_to_eq_mod. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.apply le_O_n. -(* i = n, j < n *) -elim Hcut1. -apply False_ind. -apply (not_eq_O_S (j \mod (S n))). -rewrite < (mod_n_n (S n)). -rewrite < H3 in \vdash (? ? (? %?) ?). -rewrite < mod_S.assumption. -unfold lt.apply le_S_S.apply le_O_n. -rewrite > lt_to_eq_mod. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.apply le_O_n. -(* i = n, j= n*) -rewrite > H3. -rewrite > H4. -reflexivity. -apply le_to_or_lt_eq.assumption. -apply le_to_or_lt_eq.assumption. -unfold lt.apply le_S_S.assumption. -unfold lt.apply le_S_S.assumption. -qed. - -(* -theorem eq_fact_pi: \forall n,m:nat. n < m \to n! = pi n (S_mod m). -intro.elim n. -simplify.reflexivity. -change with (S n1)*n1!=(S_mod m n1)*(pi n1 (S_mod m)). -unfold S_mod in \vdash (? ? ? (? % ?)). -rewrite > lt_to_eq_mod. -apply eq_f.apply H.apply (trans_lt ? (S n1)). -simplify. apply le_n.assumption.assumption. -qed. -*) - -theorem prime_to_not_divides_fact: \forall p:nat. prime p \to \forall n:nat. -n \lt p \to \not divides p n!. -intros 3.elim n.unfold Not.intros. -apply (lt_to_not_le (S O) p). -unfold prime in H.elim H. -assumption.apply divides_to_le.unfold lt.apply le_n. -assumption. -change with (divides p ((S n1)*n1!) \to False). -intro. -cut (divides p (S n1) \lor divides p n1!). -elim Hcut.apply (lt_to_not_le (S n1) p). -assumption. -apply divides_to_le.unfold lt.apply le_S_S.apply le_O_n. -assumption.apply H1. -apply (trans_lt ? (S n1)).unfold lt. apply le_n. -assumption.assumption. -apply divides_times_to_divides. -assumption.assumption. -qed. - -theorem permut_mod: \forall p,a:nat. prime p \to -\lnot divides p a\to permut (\lambda n.(mod (a*n) p)) (pred p). -unfold permut.intros. -split.intros.apply le_S_S_to_le. -apply (trans_le ? p). -change with (mod (a*i) p < p). -apply lt_mod_m_m. -unfold prime in H.elim H. -unfold lt.apply (trans_le ? (S (S O))). -apply le_n_Sn.assumption. -rewrite < S_pred.apply le_n. -unfold prime in H. -elim H. -apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. -unfold injn.intros. -apply (nat_compare_elim i j). -(* i < j *) -intro. -absurd (j-i \lt p). -unfold lt. -rewrite > (S_pred p). -apply le_S_S. -apply le_plus_to_minus. -apply (trans_le ? (pred p)).assumption. -rewrite > sym_plus. -apply le_plus_n. -unfold prime in H. -elim H. -apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. -apply (le_to_not_lt p (j-i)). -apply divides_to_le.unfold lt. -apply le_SO_minus.assumption. -cut (divides p a \lor divides p (j-i)). -elim Hcut.apply False_ind.apply H1.assumption.assumption. -apply divides_times_to_divides.assumption. -rewrite > distr_times_minus. -apply eq_mod_to_divides. -unfold prime in H. -elim H. -apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. -apply sym_eq. -apply H4. -(* i = j *) -intro. assumption. -(* j < i *) -intro. -absurd (i-j \lt p). -unfold lt. -rewrite > (S_pred p). -apply le_S_S. -apply le_plus_to_minus. -apply (trans_le ? (pred p)).assumption. -rewrite > sym_plus. -apply le_plus_n. -unfold prime in H. -elim H. -apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. -apply (le_to_not_lt p (i-j)). -apply divides_to_le.unfold lt. -apply le_SO_minus.assumption. -cut (divides p a \lor divides p (i-j)). -elim Hcut.apply False_ind.apply H1.assumption.assumption. -apply divides_times_to_divides.assumption. -rewrite > distr_times_minus. -apply eq_mod_to_divides. -unfold prime in H. -elim H. -apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. -apply H4. -qed. - -theorem congruent_exp_pred_SO: \forall p,a:nat. prime p \to \lnot divides p a \to -congruent (exp a (pred p)) (S O) p. -intros. -cut (O < a). -cut (O < p). -cut (O < pred p). -apply divides_to_congruent. -assumption. -change with (O < exp a (pred p)). -apply lt_O_exp.assumption. -cut (divides p (exp a (pred p)-(S O)) \lor divides p (pred p)!). -elim Hcut3. -assumption. -apply False_ind. -apply (prime_to_not_divides_fact p H (pred p)). -change with (S (pred p) \le p). -rewrite < S_pred.apply le_n. -assumption.assumption. -apply divides_times_to_divides. -assumption. -rewrite > times_minus_l. -rewrite > (sym_times (S O)). -rewrite < times_n_SO. -rewrite > (S_pred (pred p)). -rewrite > eq_fact_pi. -(* in \vdash (? ? (? % ?)). *) -rewrite > exp_pi_l. -apply congruent_to_divides. -assumption. -apply (transitive_congruent p ? -(pi (pred (pred p)) (\lambda m. a*m \mod p) (S O))). -apply (congruent_pi (\lambda m. a*m)). -assumption. -cut (pi (pred(pred p)) (\lambda m.m) (S O) -= pi (pred(pred p)) (\lambda m.a*m \mod p) (S O)). -rewrite > Hcut3.apply congruent_n_n. -rewrite < eq_map_iter_i_pi. -rewrite < eq_map_iter_i_pi. -apply permut_to_eq_map_iter_i. -apply assoc_times. -apply sym_times. -rewrite < plus_n_Sm.rewrite < plus_n_O. -rewrite < S_pred. -apply permut_mod.assumption. -assumption.assumption. -intros.cut (m=O). -rewrite > Hcut3.rewrite < times_n_O. -apply mod_O_n.apply sym_eq.apply le_n_O_to_eq. -apply le_S_S_to_le.assumption. -assumption. -change with ((S O) \le pred p). -apply le_S_S_to_le.rewrite < S_pred. -unfold prime in H.elim H.assumption.assumption. -unfold prime in H.elim H.apply (trans_lt ? (S O)). -unfold lt.apply le_n.assumption. -cut (O < a \lor O = a). -elim Hcut.assumption. -apply False_ind.apply H1. -rewrite < H2. -apply (witness ? ? O).apply times_n_O. -apply le_to_or_lt_eq. -apply le_O_n. -qed. - diff --git a/helm/matita/library/nat/gcd.ma b/helm/matita/library/nat/gcd.ma deleted file mode 100644 index 65f61b581..000000000 --- a/helm/matita/library/nat/gcd.ma +++ /dev/null @@ -1,608 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/gcd". - -include "nat/primes.ma". - -let rec gcd_aux p m n: nat \def -match divides_b n m with -[ true \Rightarrow n -| false \Rightarrow - match p with - [O \Rightarrow n - |(S q) \Rightarrow gcd_aux q n (m \mod n)]]. - -definition gcd : nat \to nat \to nat \def -\lambda n,m:nat. - match leb n m with - [ true \Rightarrow - match n with - [ O \Rightarrow m - | (S p) \Rightarrow gcd_aux (S p) m (S p) ] - | false \Rightarrow - match m with - [ O \Rightarrow n - | (S p) \Rightarrow gcd_aux (S p) n (S p) ]]. - -theorem divides_mod: \forall p,m,n:nat. O < n \to p \divides m \to p \divides n \to -p \divides (m \mod n). -intros.elim H1.elim H2. -apply (witness ? ? (n2 - n1*(m / n))). -rewrite > distr_times_minus. -rewrite < H3. -rewrite < assoc_times. -rewrite < H4. -apply sym_eq. -apply plus_to_minus. -rewrite > sym_times. -apply div_mod. -assumption. -qed. - -theorem divides_mod_to_divides: \forall p,m,n:nat. O < n \to -p \divides (m \mod n) \to p \divides n \to p \divides m. -intros.elim H1.elim H2. -apply (witness p m ((n1*(m / n))+n2)). -rewrite > distr_times_plus. -rewrite < H3. -rewrite < assoc_times. -rewrite < H4.rewrite < sym_times. -apply div_mod.assumption. -qed. - -theorem divides_gcd_aux_mn: \forall p,m,n. O < n \to n \le m \to n \le p \to -gcd_aux p m n \divides m \land gcd_aux p m n \divides n. -intro.elim p. -absurd (O < n).assumption.apply le_to_not_lt.assumption. -cut ((n1 \divides m) \lor (n1 \ndivides m)). -change with -((match divides_b n1 m with -[ true \Rightarrow n1 -| false \Rightarrow gcd_aux n n1 (m \mod n1)]) \divides m \land -(match divides_b n1 m with -[ true \Rightarrow n1 -| false \Rightarrow gcd_aux n n1 (m \mod n1)]) \divides n1). -elim Hcut.rewrite > divides_to_divides_b_true. -simplify. -split.assumption.apply (witness n1 n1 (S O)).apply times_n_SO. -assumption.assumption. -rewrite > not_divides_to_divides_b_false. -change with -(gcd_aux n n1 (m \mod n1) \divides m \land -gcd_aux n n1 (m \mod n1) \divides n1). -cut (gcd_aux n n1 (m \mod n1) \divides n1 \land -gcd_aux n n1 (m \mod n1) \divides mod m n1). -elim Hcut1. -split.apply (divides_mod_to_divides ? ? n1). -assumption.assumption.assumption.assumption. -apply H. -cut (O \lt m \mod n1 \lor O = mod m n1). -elim Hcut1.assumption. -apply False_ind.apply H4.apply mod_O_to_divides. -assumption.apply sym_eq.assumption. -apply le_to_or_lt_eq.apply le_O_n. -apply lt_to_le. -apply lt_mod_m_m.assumption. -apply le_S_S_to_le. -apply (trans_le ? n1). -change with (m \mod n1 < n1). -apply lt_mod_m_m.assumption.assumption. -assumption.assumption. -apply (decidable_divides n1 m).assumption. -qed. - -theorem divides_gcd_nm: \forall n,m. -gcd n m \divides m \land gcd n m \divides n. -intros. -change with -(match leb n m with - [ true \Rightarrow - match n with - [ O \Rightarrow m - | (S p) \Rightarrow gcd_aux (S p) m (S p) ] - | false \Rightarrow - match m with - [ O \Rightarrow n - | (S p) \Rightarrow gcd_aux (S p) n (S p) ] ] \divides m -\land -match leb n m with - [ true \Rightarrow - match n with - [ O \Rightarrow m - | (S p) \Rightarrow gcd_aux (S p) m (S p) ] - | false \Rightarrow - match m with - [ O \Rightarrow n - | (S p) \Rightarrow gcd_aux (S p) n (S p) ] ] \divides n). -apply (leb_elim n m). -apply (nat_case1 n). -simplify.intros.split. -apply (witness m m (S O)).apply times_n_SO. -apply (witness m O O).apply times_n_O. -intros.change with -(gcd_aux (S m1) m (S m1) \divides m -\land -gcd_aux (S m1) m (S m1) \divides (S m1)). -apply divides_gcd_aux_mn. -unfold lt.apply le_S_S.apply le_O_n. -assumption.apply le_n. -simplify.intro. -apply (nat_case1 m). -simplify.intros.split. -apply (witness n O O).apply times_n_O. -apply (witness n n (S O)).apply times_n_SO. -intros.change with -(gcd_aux (S m1) n (S m1) \divides (S m1) -\land -gcd_aux (S m1) n (S m1) \divides n). -cut (gcd_aux (S m1) n (S m1) \divides n -\land -gcd_aux (S m1) n (S m1) \divides S m1). -elim Hcut.split.assumption.assumption. -apply divides_gcd_aux_mn. -unfold lt.apply le_S_S.apply le_O_n. -apply not_lt_to_le.unfold Not. unfold lt.intro.apply H. -rewrite > H1.apply (trans_le ? (S n)). -apply le_n_Sn.assumption.apply le_n. -qed. - -theorem divides_gcd_n: \forall n,m. gcd n m \divides n. -intros. -exact (proj2 ? ? (divides_gcd_nm n m)). -qed. - -theorem divides_gcd_m: \forall n,m. gcd n m \divides m. -intros. -exact (proj1 ? ? (divides_gcd_nm n m)). -qed. - -theorem divides_gcd_aux: \forall p,m,n,d. O < n \to n \le m \to n \le p \to -d \divides m \to d \divides n \to d \divides gcd_aux p m n. -intro.elim p. -absurd (O < n).assumption.apply le_to_not_lt.assumption. -change with -(d \divides -(match divides_b n1 m with -[ true \Rightarrow n1 -| false \Rightarrow gcd_aux n n1 (m \mod n1)])). -cut (n1 \divides m \lor n1 \ndivides m). -elim Hcut. -rewrite > divides_to_divides_b_true. -simplify.assumption. -assumption.assumption. -rewrite > not_divides_to_divides_b_false. -change with (d \divides gcd_aux n n1 (m \mod n1)). -apply H. -cut (O \lt m \mod n1 \lor O = m \mod n1). -elim Hcut1.assumption. -absurd (n1 \divides m).apply mod_O_to_divides. -assumption.apply sym_eq.assumption.assumption. -apply le_to_or_lt_eq.apply le_O_n. -apply lt_to_le. -apply lt_mod_m_m.assumption. -apply le_S_S_to_le. -apply (trans_le ? n1). -change with (m \mod n1 < n1). -apply lt_mod_m_m.assumption.assumption. -assumption. -apply divides_mod.assumption.assumption.assumption. -assumption.assumption. -apply (decidable_divides n1 m).assumption. -qed. - -theorem divides_d_gcd: \forall m,n,d. -d \divides m \to d \divides n \to d \divides gcd n m. -intros. -change with -(d \divides -match leb n m with - [ true \Rightarrow - match n with - [ O \Rightarrow m - | (S p) \Rightarrow gcd_aux (S p) m (S p) ] - | false \Rightarrow - match m with - [ O \Rightarrow n - | (S p) \Rightarrow gcd_aux (S p) n (S p) ]]). -apply (leb_elim n m). -apply (nat_case1 n).simplify.intros.assumption. -intros. -change with (d \divides gcd_aux (S m1) m (S m1)). -apply divides_gcd_aux. -unfold lt.apply le_S_S.apply le_O_n.assumption.apply le_n.assumption. -rewrite < H2.assumption. -apply (nat_case1 m).simplify.intros.assumption. -intros. -change with (d \divides gcd_aux (S m1) n (S m1)). -apply divides_gcd_aux. -unfold lt.apply le_S_S.apply le_O_n. -apply lt_to_le.apply not_le_to_lt.assumption.apply le_n.assumption. -rewrite < H2.assumption. -qed. - -theorem eq_minus_gcd_aux: \forall p,m,n.O < n \to n \le m \to n \le p \to -\exists a,b. a*n - b*m = gcd_aux p m n \lor b*m - a*n = gcd_aux p m n. -intro. -elim p. -absurd (O < n).assumption.apply le_to_not_lt.assumption. -cut (O < m). -cut (n1 \divides m \lor n1 \ndivides m). -change with -(\exists a,b. -a*n1 - b*m = match divides_b n1 m with -[ true \Rightarrow n1 -| false \Rightarrow gcd_aux n n1 (m \mod n1)] -\lor -b*m - a*n1 = match divides_b n1 m with -[ true \Rightarrow n1 -| false \Rightarrow gcd_aux n n1 (m \mod n1)]). -elim Hcut1. -rewrite > divides_to_divides_b_true. -simplify. -apply (ex_intro ? ? (S O)). -apply (ex_intro ? ? O). -left.simplify.rewrite < plus_n_O. -apply sym_eq.apply minus_n_O. -assumption.assumption. -rewrite > not_divides_to_divides_b_false. -change with -(\exists a,b. -a*n1 - b*m = gcd_aux n n1 (m \mod n1) -\lor -b*m - a*n1 = gcd_aux n n1 (m \mod n1)). -cut -(\exists a,b. -a*(m \mod n1) - b*n1= gcd_aux n n1 (m \mod n1) -\lor -b*n1 - a*(m \mod n1) = gcd_aux n n1 (m \mod n1)). -elim Hcut2.elim H5.elim H6. -(* first case *) -rewrite < H7. -apply (ex_intro ? ? (a1+a*(m / n1))). -apply (ex_intro ? ? a). -right. -rewrite < sym_plus. -rewrite < (sym_times n1). -rewrite > distr_times_plus. -rewrite > (sym_times n1). -rewrite > (sym_times n1). -rewrite > (div_mod m n1) in \vdash (? ? (? % ?) ?). -rewrite > assoc_times. -rewrite < sym_plus. -rewrite > distr_times_plus. -rewrite < eq_minus_minus_minus_plus. -rewrite < sym_plus. -rewrite < plus_minus. -rewrite < minus_n_n.reflexivity. -apply le_n. -assumption. -(* second case *) -rewrite < H7. -apply (ex_intro ? ? (a1+a*(m / n1))). -apply (ex_intro ? ? a). -left. -(* clear Hcut2.clear H5.clear H6.clear H. *) -rewrite > sym_times. -rewrite > distr_times_plus. -rewrite > sym_times. -rewrite > (sym_times n1). -rewrite > (div_mod m n1) in \vdash (? ? (? ? %) ?). -rewrite > distr_times_plus. -rewrite > assoc_times. -rewrite < eq_minus_minus_minus_plus. -rewrite < sym_plus. -rewrite < plus_minus. -rewrite < minus_n_n.reflexivity. -apply le_n. -assumption. -apply (H n1 (m \mod n1)). -cut (O \lt m \mod n1 \lor O = m \mod n1). -elim Hcut2.assumption. -absurd (n1 \divides m).apply mod_O_to_divides. -assumption. -symmetry.assumption.assumption. -apply le_to_or_lt_eq.apply le_O_n. -apply lt_to_le. -apply lt_mod_m_m.assumption. -apply le_S_S_to_le. -apply (trans_le ? n1). -change with (m \mod n1 < n1). -apply lt_mod_m_m. -assumption.assumption.assumption.assumption. -apply (decidable_divides n1 m).assumption. -apply (lt_to_le_to_lt ? n1).assumption.assumption. -qed. - -theorem eq_minus_gcd: - \forall m,n.\exists a,b.a*n - b*m = (gcd n m) \lor b*m - a*n = (gcd n m). -intros. -unfold gcd. -apply (leb_elim n m). -apply (nat_case1 n). -simplify.intros. -apply (ex_intro ? ? O). -apply (ex_intro ? ? (S O)). -right.simplify. -rewrite < plus_n_O. -apply sym_eq.apply minus_n_O. -intros. -change with -(\exists a,b. -a*(S m1) - b*m = (gcd_aux (S m1) m (S m1)) -\lor b*m - a*(S m1) = (gcd_aux (S m1) m (S m1))). -apply eq_minus_gcd_aux. -unfold lt. apply le_S_S.apply le_O_n. -assumption.apply le_n. -apply (nat_case1 m). -simplify.intros. -apply (ex_intro ? ? (S O)). -apply (ex_intro ? ? O). -left.simplify. -rewrite < plus_n_O. -apply sym_eq.apply minus_n_O. -intros. -change with -(\exists a,b. -a*n - b*(S m1) = (gcd_aux (S m1) n (S m1)) -\lor b*(S m1) - a*n = (gcd_aux (S m1) n (S m1))). -cut -(\exists a,b. -a*(S m1) - b*n = (gcd_aux (S m1) n (S m1)) -\lor -b*n - a*(S m1) = (gcd_aux (S m1) n (S m1))). -elim Hcut.elim H2.elim H3. -apply (ex_intro ? ? a1). -apply (ex_intro ? ? a). -right.assumption. -apply (ex_intro ? ? a1). -apply (ex_intro ? ? a). -left.assumption. -apply eq_minus_gcd_aux. -unfold lt. apply le_S_S.apply le_O_n. -apply lt_to_le.apply not_le_to_lt.assumption. -apply le_n. -qed. - -(* some properties of gcd *) - -theorem gcd_O_n: \forall n:nat. gcd O n = n. -intro.simplify.reflexivity. -qed. - -theorem gcd_O_to_eq_O:\forall m,n:nat. (gcd m n) = O \to -m = O \land n = O. -intros.cut (O \divides n \land O \divides m). -elim Hcut.elim H2.split. -assumption.elim H1.assumption. -rewrite < H. -apply divides_gcd_nm. -qed. - -theorem lt_O_gcd:\forall m,n:nat. O < n \to O < gcd m n. -intros. -apply (nat_case1 (gcd m n)). -intros. -generalize in match (gcd_O_to_eq_O m n H1). -intros.elim H2. -rewrite < H4 in \vdash (? ? %).assumption. -intros.unfold lt.apply le_S_S.apply le_O_n. -qed. - -theorem symmetric_gcd: symmetric nat gcd. -change with -(\forall n,m:nat. gcd n m = gcd m n). -intros. -cut (O < (gcd n m) \lor O = (gcd n m)). -elim Hcut. -cut (O < (gcd m n) \lor O = (gcd m n)). -elim Hcut1. -apply antisym_le. -apply divides_to_le.assumption. -apply divides_d_gcd.apply divides_gcd_n.apply divides_gcd_m. -apply divides_to_le.assumption. -apply divides_d_gcd.apply divides_gcd_n.apply divides_gcd_m. -rewrite < H1. -cut (m=O \land n=O). -elim Hcut2.rewrite > H2.rewrite > H3.reflexivity. -apply gcd_O_to_eq_O.apply sym_eq.assumption. -apply le_to_or_lt_eq.apply le_O_n. -rewrite < H. -cut (n=O \land m=O). -elim Hcut1.rewrite > H1.rewrite > H2.reflexivity. -apply gcd_O_to_eq_O.apply sym_eq.assumption. -apply le_to_or_lt_eq.apply le_O_n. -qed. - -variant sym_gcd: \forall n,m:nat. gcd n m = gcd m n \def -symmetric_gcd. - -theorem le_gcd_times: \forall m,n,p:nat. O< p \to gcd m n \le gcd m (n*p). -intros. -apply (nat_case n).reflexivity. -intro. -apply divides_to_le. -apply lt_O_gcd. -rewrite > (times_n_O O). -apply lt_times.unfold lt.apply le_S_S.apply le_O_n.assumption. -apply divides_d_gcd. -apply (transitive_divides ? (S m1)). -apply divides_gcd_m. -apply (witness ? ? p).reflexivity. -apply divides_gcd_n. -qed. - -theorem gcd_times_SO_to_gcd_SO: \forall m,n,p:nat. O < n \to O < p \to -gcd m (n*p) = (S O) \to gcd m n = (S O). -intros. -apply antisymmetric_le. -rewrite < H2. -apply le_gcd_times.assumption. -change with (O < gcd m n). -apply lt_O_gcd.assumption. -qed. - -(* for the "converse" of the previous result see the end of this development *) - -theorem gcd_SO_n: \forall n:nat. gcd (S O) n = (S O). -intro. -apply antisym_le.apply divides_to_le.unfold lt.apply le_n. -apply divides_gcd_n. -cut (O < gcd (S O) n \lor O = gcd (S O) n). -elim Hcut.assumption. -apply False_ind. -apply (not_eq_O_S O). -cut ((S O)=O \land n=O). -elim Hcut1.apply sym_eq.assumption. -apply gcd_O_to_eq_O.apply sym_eq.assumption. -apply le_to_or_lt_eq.apply le_O_n. -qed. - -theorem divides_gcd_mod: \forall m,n:nat. O < n \to -divides (gcd m n) (gcd n (m \mod n)). -intros. -apply divides_d_gcd. -apply divides_mod.assumption. -apply divides_gcd_n. -apply divides_gcd_m. -apply divides_gcd_m. -qed. - -theorem divides_mod_gcd: \forall m,n:nat. O < n \to -divides (gcd n (m \mod n)) (gcd m n) . -intros. -apply divides_d_gcd. -apply divides_gcd_n. -apply (divides_mod_to_divides ? ? n). -assumption. -apply divides_gcd_m. -apply divides_gcd_n. -qed. - -theorem gcd_mod: \forall m,n:nat. O < n \to -(gcd n (m \mod n)) = (gcd m n) . -intros. -apply antisymmetric_divides. -apply divides_mod_gcd.assumption. -apply divides_gcd_mod.assumption. -qed. - -(* gcd and primes *) - -theorem prime_to_gcd_SO: \forall n,m:nat. prime n \to n \ndivides m \to -gcd n m = (S O). -intros.unfold prime in H.change with (gcd n m = (S O)). -elim H. -apply antisym_le. -apply not_lt_to_le. -change with ((S (S O)) \le gcd n m \to False).intro. -apply H1.rewrite < (H3 (gcd n m)). -apply divides_gcd_m. -apply divides_gcd_n.assumption. -cut (O < gcd n m \lor O = gcd n m). -elim Hcut.assumption. -apply False_ind. -apply (not_le_Sn_O (S O)). -cut (n=O \land m=O). -elim Hcut1.rewrite < H5 in \vdash (? ? %).assumption. -apply gcd_O_to_eq_O.apply sym_eq.assumption. -apply le_to_or_lt_eq.apply le_O_n. -qed. - -theorem divides_times_to_divides: \forall n,p,q:nat.prime n \to n \divides p*q \to -n \divides p \lor n \divides q. -intros. -cut (n \divides p \lor n \ndivides p). -elim Hcut. -left.assumption. -right. -cut (\exists a,b. a*n - b*p = (S O) \lor b*p - a*n = (S O)). -elim Hcut1.elim H3.elim H4. -(* first case *) -rewrite > (times_n_SO q).rewrite < H5. -rewrite > distr_times_minus. -rewrite > (sym_times q (a1*p)). -rewrite > (assoc_times a1). -elim H1.rewrite > H6. -rewrite < (sym_times n).rewrite < assoc_times. -rewrite > (sym_times q).rewrite > assoc_times. -rewrite < (assoc_times a1).rewrite < (sym_times n). -rewrite > (assoc_times n). -rewrite < distr_times_minus. -apply (witness ? ? (q*a-a1*n2)).reflexivity. -(* second case *) -rewrite > (times_n_SO q).rewrite < H5. -rewrite > distr_times_minus. -rewrite > (sym_times q (a1*p)). -rewrite > (assoc_times a1). -elim H1.rewrite > H6. -rewrite < sym_times.rewrite > assoc_times. -rewrite < (assoc_times q). -rewrite < (sym_times n). -rewrite < distr_times_minus. -apply (witness ? ? (n2*a1-q*a)).reflexivity. -(* end second case *) -rewrite < (prime_to_gcd_SO n p). -apply eq_minus_gcd. -assumption.assumption. -apply (decidable_divides n p). -apply (trans_lt ? (S O)).unfold lt.apply le_n. -unfold prime in H.elim H. assumption. -qed. - -theorem eq_gcd_times_SO: \forall m,n,p:nat. O < n \to O < p \to -gcd m n = (S O) \to gcd m p = (S O) \to gcd m (n*p) = (S O). -intros. -apply antisymmetric_le. -apply not_lt_to_le. -unfold Not.intro. -cut (divides (smallest_factor (gcd m (n*p))) n \lor - divides (smallest_factor (gcd m (n*p))) p). -elim Hcut. -apply (not_le_Sn_n (S O)). -change with ((S O) < (S O)). -rewrite < H2 in \vdash (? ? %). -apply (lt_to_le_to_lt ? (smallest_factor (gcd m (n*p)))). -apply lt_SO_smallest_factor.assumption. -apply divides_to_le. -rewrite > H2.unfold lt.apply le_n. -apply divides_d_gcd.assumption. -apply (transitive_divides ? (gcd m (n*p))). -apply divides_smallest_factor_n. -apply (trans_lt ? (S O)). unfold lt. apply le_n. assumption. -apply divides_gcd_n. -apply (not_le_Sn_n (S O)). -change with ((S O) < (S O)). -rewrite < H3 in \vdash (? ? %). -apply (lt_to_le_to_lt ? (smallest_factor (gcd m (n*p)))). -apply lt_SO_smallest_factor.assumption. -apply divides_to_le. -rewrite > H3.unfold lt.apply le_n. -apply divides_d_gcd.assumption. -apply (transitive_divides ? (gcd m (n*p))). -apply divides_smallest_factor_n. -apply (trans_lt ? (S O)). unfold lt. apply le_n. assumption. -apply divides_gcd_n. -apply divides_times_to_divides. -apply prime_smallest_factor_n. -assumption. -apply (transitive_divides ? (gcd m (n*p))). -apply divides_smallest_factor_n. -apply (trans_lt ? (S O)).unfold lt. apply le_n. assumption. -apply divides_gcd_m. -change with (O < gcd m (n*p)). -apply lt_O_gcd. -rewrite > (times_n_O O). -apply lt_times.assumption.assumption. -qed. diff --git a/helm/matita/library/nat/le_arith.ma b/helm/matita/library/nat/le_arith.ma deleted file mode 100644 index a76183063..000000000 --- a/helm/matita/library/nat/le_arith.ma +++ /dev/null @@ -1,95 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/le_arith". - -include "nat/times.ma". -include "nat/orders.ma". - -(* plus *) -theorem monotonic_le_plus_r: -\forall n:nat.monotonic nat le (\lambda m.n + m). -simplify.intros.elim n. -simplify.assumption. -simplify.apply le_S_S.assumption. -qed. - -theorem le_plus_r: \forall p,n,m:nat. n \le m \to p + n \le p + m -\def monotonic_le_plus_r. - -theorem monotonic_le_plus_l: -\forall m:nat.monotonic nat le (\lambda n.n + m). -simplify.intros. -rewrite < sym_plus.rewrite < (sym_plus m). -apply le_plus_r.assumption. -qed. - -theorem le_plus_l: \forall p,n,m:nat. n \le m \to n + p \le m + p -\def monotonic_le_plus_l. - -theorem le_plus: \forall n1,n2,m1,m2:nat. n1 \le n2 \to m1 \le m2 -\to n1 + m1 \le n2 + m2. -intros. -apply (trans_le ? (n2 + m1)). -apply le_plus_l.assumption. -apply le_plus_r.assumption. -qed. - -theorem le_plus_n :\forall n,m:nat. m \le n + m. -intros.change with (O+m \le n+m). -apply le_plus_l.apply le_O_n. -qed. - -theorem eq_plus_to_le: \forall n,m,p:nat.n=m+p \to m \le n. -intros.rewrite > H. -rewrite < sym_plus. -apply le_plus_n. -qed. - -(* times *) -theorem monotonic_le_times_r: -\forall n:nat.monotonic nat le (\lambda m. n * m). -simplify.intros.elim n. -simplify.apply le_O_n. -simplify.apply le_plus. -assumption. -assumption. -qed. - -theorem le_times_r: \forall p,n,m:nat. n \le m \to p*n \le p*m -\def monotonic_le_times_r. - -theorem monotonic_le_times_l: -\forall m:nat.monotonic nat le (\lambda n.n*m). -simplify.intros. -rewrite < sym_times.rewrite < (sym_times m). -apply le_times_r.assumption. -qed. - -theorem le_times_l: \forall p,n,m:nat. n \le m \to n*p \le m*p -\def monotonic_le_times_l. - -theorem le_times: \forall n1,n2,m1,m2:nat. n1 \le n2 \to m1 \le m2 -\to n1*m1 \le n2*m2. -intros. -apply (trans_le ? (n2*m1)). -apply le_times_l.assumption. -apply le_times_r.assumption. -qed. - -theorem le_times_n: \forall n,m:nat.(S O) \le n \to m \le n*m. -intros.elim H.simplify. -elim (plus_n_O ?).apply le_n. -simplify.rewrite < sym_plus.apply le_plus_n. -qed. diff --git a/helm/matita/library/nat/lt_arith.ma b/helm/matita/library/nat/lt_arith.ma deleted file mode 100644 index f60da5eba..000000000 --- a/helm/matita/library/nat/lt_arith.ma +++ /dev/null @@ -1,221 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/lt_arith". - -include "nat/div_and_mod.ma". - -(* plus *) -theorem monotonic_lt_plus_r: -\forall n:nat.monotonic nat lt (\lambda m.n+m). -simplify.intros. -elim n.simplify.assumption. -simplify.unfold lt. -apply le_S_S.assumption. -qed. - -variant lt_plus_r: \forall n,p,q:nat. p < q \to n + p < n + q \def -monotonic_lt_plus_r. - -theorem monotonic_lt_plus_l: -\forall n:nat.monotonic nat lt (\lambda m.m+n). -change with (\forall n,p,q:nat. p < q \to p + n < q + n). -intros. -rewrite < sym_plus. rewrite < (sym_plus n). -apply lt_plus_r.assumption. -qed. - -variant lt_plus_l: \forall n,p,q:nat. p < q \to p + n < q + n \def -monotonic_lt_plus_l. - -theorem lt_plus: \forall n,m,p,q:nat. n < m \to p < q \to n + p < m + q. -intros. -apply (trans_lt ? (n + q)). -apply lt_plus_r.assumption. -apply lt_plus_l.assumption. -qed. - -theorem lt_plus_to_lt_l :\forall n,p,q:nat. p+n < q+n \to p plus_n_O. -rewrite > (plus_n_O q).assumption. -apply H. -unfold lt.apply le_S_S_to_le. -rewrite > plus_n_Sm. -rewrite > (plus_n_Sm q). -exact H1. -qed. - -theorem lt_plus_to_lt_r :\forall n,p,q:nat. n+p < n+q \to p sym_plus. -rewrite > (sym_plus q).assumption. -qed. - -(* times and zero *) -theorem lt_O_times_S_S: \forall n,m:nat.O < (S n)*(S m). -intros.simplify.unfold lt.apply le_S_S.apply le_O_n. -qed. - -(* times *) -theorem monotonic_lt_times_r: -\forall n:nat.monotonic nat lt (\lambda m.(S n)*m). -change with (\forall n,p,q:nat. p < q \to (S n) * p < (S n) * q). -intros.elim n. -simplify.rewrite < plus_n_O.rewrite < plus_n_O.assumption. -change with (p + (S n1) * p < q + (S n1) * q). -apply lt_plus.assumption.assumption. -qed. - -theorem lt_times_r: \forall n,p,q:nat. p < q \to (S n) * p < (S n) * q -\def monotonic_lt_times_r. - -theorem monotonic_lt_times_l: -\forall m:nat.monotonic nat lt (\lambda n.n * (S m)). -change with -(\forall n,p,q:nat. p < q \to p*(S n) < q*(S n)). -intros. -rewrite < sym_times.rewrite < (sym_times (S n)). -apply lt_times_r.assumption. -qed. - -variant lt_times_l: \forall n,p,q:nat. p nat_compare_n_n.reflexivity. -intro.apply nat_compare_elim.intro. -absurd (p (plus_n_O ((S m1)*(n / (S m1)))). -rewrite < H2. -rewrite < sym_times. -rewrite < div_mod. -rewrite > H2. -assumption. -unfold lt.apply le_S_S.apply le_O_n. -qed. - -theorem lt_div_n_m_n: \forall n,m:nat. (S O) < m \to O < n \to n / m \lt n. -intros. -apply (nat_case1 (n / m)).intro. -assumption.intros.rewrite < H2. -rewrite > (div_mod n m) in \vdash (? ? %). -apply (lt_to_le_to_lt ? ((n / m)*m)). -apply (lt_to_le_to_lt ? ((n / m)*(S (S O)))). -rewrite < sym_times. -rewrite > H2. -simplify.unfold lt. -rewrite < plus_n_O. -rewrite < plus_n_Sm. -apply le_S_S. -apply le_S_S. -apply le_plus_n. -apply le_times_r. -assumption. -rewrite < sym_plus. -apply le_plus_n. -apply (trans_lt ? (S O)). -unfold lt. apply le_n.assumption. -qed. - -(* general properties of functions *) -theorem monotonic_to_injective: \forall f:nat\to nat. -monotonic nat lt f \to injective nat nat f. -unfold injective.intros. -apply (nat_compare_elim x y). -intro.apply False_ind.apply (not_le_Sn_n (f x)). -rewrite > H1 in \vdash (? ? %). -change with (f x < f y). -apply H.apply H2. -intros.assumption. -intro.apply False_ind.apply (not_le_Sn_n (f y)). -rewrite < H1 in \vdash (? ? %). -change with (f y < f x). -apply H.apply H2. -qed. - -theorem increasing_to_injective: \forall f:nat\to nat. -increasing f \to injective nat nat f. -intros.apply monotonic_to_injective. -apply increasing_to_monotonic.assumption. -qed. diff --git a/helm/matita/library/nat/minimization.ma b/helm/matita/library/nat/minimization.ma deleted file mode 100644 index 0abed5ad3..000000000 --- a/helm/matita/library/nat/minimization.ma +++ /dev/null @@ -1,222 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/minimization". - -include "nat/minus.ma". - -let rec max i f \def - match (f i) with - [ true \Rightarrow i - | false \Rightarrow - match i with - [ O \Rightarrow O - | (S j) \Rightarrow max j f ]]. - -theorem max_O_f : \forall f: nat \to bool. max O f = O. -intro. simplify. -elim (f O). -simplify.reflexivity. -simplify.reflexivity. -qed. - -theorem max_S_max : \forall f: nat \to bool. \forall n:nat. -(f (S n) = true \land max (S n) f = (S n)) \lor -(f (S n) = false \land max (S n) f = max n f). -intros.simplify.elim (f (S n)). -simplify.left.split.reflexivity.reflexivity. -simplify.right.split.reflexivity.reflexivity. -qed. - -theorem le_max_n : \forall f: nat \to bool. \forall n:nat. -max n f \le n. -intros.elim n.rewrite > max_O_f.apply le_n. -simplify.elim (f (S n1)).simplify.apply le_n. -simplify.apply le_S.assumption. -qed. - -theorem le_to_le_max : \forall f: nat \to bool. \forall n,m:nat. -n\le m \to max n f \le max m f. -intros.elim H. -apply le_n. -apply (trans_le ? (max n1 f)).apply H2. -cut ((f (S n1) = true \land max (S n1) f = (S n1)) \lor -(f (S n1) = false \land max (S n1) f = max n1 f)). -elim Hcut.elim H3. -rewrite > H5. -apply le_S.apply le_max_n. -elim H3.rewrite > H5.apply le_n. -apply max_S_max. -qed. - -theorem f_m_to_le_max: \forall f: nat \to bool. \forall n,m:nat. -m\le n \to f m = true \to m \le max n f. -intros 3.elim n.apply (le_n_O_elim m H). -apply le_O_n. -apply (le_n_Sm_elim m n1 H1). -intro.apply (trans_le ? (max n1 f)). -apply H.apply le_S_S_to_le.assumption.assumption. -apply le_to_le_max.apply le_n_Sn. -intro.simplify.rewrite < H3. -rewrite > H2.simplify.apply le_n. -qed. - - -definition max_spec \def \lambda f:nat \to bool.\lambda n: nat. -\exists i. (le i n) \land (f i = true) \to -(f n) = true \land (\forall i. i < n \to (f i = false)). - -theorem f_max_true : \forall f:nat \to bool. \forall n:nat. -(\exists i:nat. le i n \land f i = true) \to f (max n f) = true. -intros 2. -elim n.elim H.elim H1.generalize in match H3. -apply (le_n_O_elim a H2).intro.simplify.rewrite > H4. -simplify.assumption. -simplify. -apply (bool_ind (\lambda b:bool. -(f (S n1) = b) \to (f (match b in bool with -[ true \Rightarrow (S n1) -| false \Rightarrow (max n1 f)])) = true)). -simplify.intro.assumption. -simplify.intro.apply H. -elim H1.elim H3.generalize in match H5. -apply (le_n_Sm_elim a n1 H4). -intros. -apply (ex_intro nat ? a). -split.apply le_S_S_to_le.assumption.assumption. -intros.apply False_ind.apply not_eq_true_false. -rewrite < H2.rewrite < H7.rewrite > H6. reflexivity. -reflexivity. -qed. - -theorem lt_max_to_false : \forall f:nat \to bool. -\forall n,m:nat. (max n f) < m \to m \leq n \to f m = false. -intros 2. -elim n.absurd (le m O).assumption. -cut (O < m).apply (lt_O_n_elim m Hcut).exact not_le_Sn_O. -rewrite < (max_O_f f).assumption. -generalize in match H1. -elim (max_S_max f n1). -elim H3. -absurd (m \le S n1).assumption. -apply lt_to_not_le.rewrite < H6.assumption. -elim H3. -apply (le_n_Sm_elim m n1 H2). -intro. -apply H.rewrite < H6.assumption. -apply le_S_S_to_le.assumption. -intro.rewrite > H7.assumption. -qed. - -let rec min_aux off n f \def - match f (n-off) with - [ true \Rightarrow (n-off) - | false \Rightarrow - match off with - [ O \Rightarrow n - | (S p) \Rightarrow min_aux p n f]]. - -definition min : nat \to (nat \to bool) \to nat \def -\lambda n.\lambda f. min_aux n n f. - -theorem min_aux_O_f: \forall f:nat \to bool. \forall i :nat. -min_aux O i f = i. -intros.simplify.rewrite < minus_n_O. -elim (f i).reflexivity. -simplify.reflexivity. -qed. - -theorem min_O_f : \forall f:nat \to bool. -min O f = O. -intro.apply (min_aux_O_f f O). -qed. - -theorem min_aux_S : \forall f: nat \to bool. \forall i,n:nat. -(f (n -(S i)) = true \land min_aux (S i) n f = (n - (S i))) \lor -(f (n -(S i)) = false \land min_aux (S i) n f = min_aux i n f). -intros.simplify.elim (f (n - (S i))). -simplify.left.split.reflexivity.reflexivity. -simplify.right.split.reflexivity.reflexivity. -qed. - -theorem f_min_aux_true: \forall f:nat \to bool. \forall off,m:nat. -(\exists i. le (m-off) i \land le i m \land f i = true) \to -f (min_aux off m f) = true. -intros 2. -elim off.elim H.elim H1.elim H2. -cut (a = m). -rewrite > (min_aux_O_f f).rewrite < Hcut.assumption. -apply (antisym_le a m).assumption.rewrite > (minus_n_O m).assumption. -simplify. -apply (bool_ind (\lambda b:bool. -(f (m-(S n)) = b) \to (f (match b in bool with -[ true \Rightarrow m-(S n) -| false \Rightarrow (min_aux n m f)])) = true)). -simplify.intro.assumption. -simplify.intro.apply H. -elim H1.elim H3.elim H4. -elim (le_to_or_lt_eq (m-(S n)) a H6). -apply (ex_intro nat ? a). -split.split. -apply lt_minus_S_n_to_le_minus_n.assumption. -assumption.assumption. -absurd (f a = false).rewrite < H8.assumption. -rewrite > H5. -apply not_eq_true_false. -reflexivity. -qed. - -theorem lt_min_aux_to_false : \forall f:nat \to bool. -\forall n,off,m:nat. (n-off) \leq m \to m < (min_aux off n f) \to f m = false. -intros 3. -elim off.absurd (le n m).rewrite > minus_n_O.assumption. -apply lt_to_not_le.rewrite < (min_aux_O_f f n).assumption. -generalize in match H1. -elim (min_aux_S f n1 n). -elim H3. -absurd (n - S n1 \le m).assumption. -apply lt_to_not_le.rewrite < H6.assumption. -elim H3. -elim (le_to_or_lt_eq (n -(S n1)) m). -apply H.apply lt_minus_S_n_to_le_minus_n.assumption. -rewrite < H6.assumption. -rewrite < H7.assumption. -assumption. -qed. - -theorem le_min_aux : \forall f:nat \to bool. -\forall n,off:nat. (n-off) \leq (min_aux off n f). -intros 3. -elim off.rewrite < minus_n_O. -rewrite > (min_aux_O_f f n).apply le_n. -elim (min_aux_S f n1 n). -elim H1.rewrite > H3.apply le_n. -elim H1.rewrite > H3. -apply (trans_le (n-(S n1)) (n-n1)). -apply monotonic_le_minus_r. -apply le_n_Sn. -assumption. -qed. - -theorem le_min_aux_r : \forall f:nat \to bool. -\forall n,off:nat. (min_aux off n f) \le n. -intros. -elim off.simplify.rewrite < minus_n_O. -elim (f n).simplify.apply le_n. -simplify.apply le_n. -simplify.elim (f (n -(S n1))). -simplify.apply le_plus_to_minus. -rewrite < sym_plus.apply le_plus_n. -simplify.assumption. -qed. diff --git a/helm/matita/library/nat/minus.ma b/helm/matita/library/nat/minus.ma deleted file mode 100644 index 710418d72..000000000 --- a/helm/matita/library/nat/minus.ma +++ /dev/null @@ -1,300 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - - -set "baseuri" "cic:/matita/nat/minus". - -include "nat/le_arith.ma". -include "nat/compare.ma". - -let rec minus n m \def - match n with - [ O \Rightarrow O - | (S p) \Rightarrow - match m with - [O \Rightarrow (S p) - | (S q) \Rightarrow minus p q ]]. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural minus" 'minus x y = (cic:/matita/nat/minus/minus.con x y). - -theorem minus_n_O: \forall n:nat.n=n-O. -intros.elim n.simplify.reflexivity. -simplify.reflexivity. -qed. - -theorem minus_n_n: \forall n:nat.O=n-n. -intros.elim n.simplify. -reflexivity. -simplify.apply H. -qed. - -theorem minus_Sn_n: \forall n:nat. S O = (S n)-n. -intro.elim n. -simplify.reflexivity. -elim H.reflexivity. -qed. - -theorem minus_Sn_m: \forall n,m:nat. m \leq n \to (S n)-m = S (n-m). -intros 2. -apply (nat_elim2 -(\lambda n,m.m \leq n \to (S n)-m = S (n-m))). -intros.apply (le_n_O_elim n1 H). -simplify.reflexivity. -intros.simplify.reflexivity. -intros.rewrite < H.reflexivity. -apply le_S_S_to_le. assumption. -qed. - -theorem plus_minus: -\forall n,m,p:nat. m \leq n \to (n-m)+p = (n+p)-m. -intros 2. -apply (nat_elim2 -(\lambda n,m.\forall p:nat.m \leq n \to (n-m)+p = (n+p)-m)). -intros.apply (le_n_O_elim ? H). -simplify.rewrite < minus_n_O.reflexivity. -intros.simplify.reflexivity. -intros.simplify.apply H.apply le_S_S_to_le.assumption. -qed. - -theorem minus_plus_m_m: \forall n,m:nat.n = (n+m)-m. -intros 2. -generalize in match n. -elim m. -rewrite < minus_n_O.apply plus_n_O. -elim n2.simplify. -apply minus_n_n. -rewrite < plus_n_Sm. -change with (S n3 = (S n3 + n1)-n1). -apply H. -qed. - -theorem plus_minus_m_m: \forall n,m:nat. -m \leq n \to n = (n-m)+m. -intros 2. -apply (nat_elim2 (\lambda n,m.m \leq n \to n = (n-m)+m)). -intros.apply (le_n_O_elim n1 H). -reflexivity. -intros.simplify.rewrite < plus_n_O.reflexivity. -intros.simplify.rewrite < sym_plus.simplify. -apply eq_f.rewrite < sym_plus.apply H. -apply le_S_S_to_le.assumption. -qed. - -theorem minus_to_plus :\forall n,m,p:nat.m \leq n \to n-m = p \to -n = m+p. -intros.apply (trans_eq ? ? ((n-m)+m)). -apply plus_minus_m_m. -apply H.elim H1. -apply sym_plus. -qed. - -theorem plus_to_minus :\forall n,m,p:nat. -n = m+p \to n-m = p. -intros. -apply (inj_plus_r m). -rewrite < H. -rewrite < sym_plus. -symmetry. -apply plus_minus_m_m.rewrite > H. -rewrite > sym_plus. -apply le_plus_n. -qed. - -theorem minus_S_S : \forall n,m:nat. -eq nat (minus (S n) (S m)) (minus n m). -intros. -reflexivity. -qed. - -theorem minus_pred_pred : \forall n,m:nat. lt O n \to lt O m \to -eq nat (minus (pred n) (pred m)) (minus n m). -intros. -apply (lt_O_n_elim n H).intro. -apply (lt_O_n_elim m H1).intro. -simplify.reflexivity. -qed. - -theorem eq_minus_n_m_O: \forall n,m:nat. -n \leq m \to n-m = O. -intros 2. -apply (nat_elim2 (\lambda n,m.n \leq m \to n-m = O)). -intros.simplify.reflexivity. -intros.apply False_ind. -apply not_le_Sn_O. -goal 13.apply H. -intros. -simplify.apply H.apply le_S_S_to_le. apply H1. -qed. - -theorem le_SO_minus: \forall n,m:nat.S n \leq m \to S O \leq m-n. -intros.elim H.elim (minus_Sn_n n).apply le_n. -rewrite > minus_Sn_m. -apply le_S.assumption. -apply lt_to_le.assumption. -qed. - -theorem minus_le_S_minus_S: \forall n,m:nat. m-n \leq S (m-(S n)). -intros.apply (nat_elim2 (\lambda n,m.m-n \leq S (m-(S n)))). -intro.elim n1.simplify.apply le_n_Sn. -simplify.rewrite < minus_n_O.apply le_n. -intros.simplify.apply le_n_Sn. -intros.simplify.apply H. -qed. - -theorem lt_minus_S_n_to_le_minus_n : \forall n,m,p:nat. m-(S n) < p \to m-n \leq p. -intros 3.simplify.intro. -apply (trans_le (m-n) (S (m-(S n))) p). -apply minus_le_S_minus_S. -assumption. -qed. - -theorem le_minus_m: \forall n,m:nat. n-m \leq n. -intros.apply (nat_elim2 (\lambda m,n. n-m \leq n)). -intros.rewrite < minus_n_O.apply le_n. -intros.simplify.apply le_n. -intros.simplify.apply le_S.assumption. -qed. - -theorem lt_minus_m: \forall n,m:nat. O < n \to O < m \to n-m \lt n. -intros.apply (lt_O_n_elim n H).intro. -apply (lt_O_n_elim m H1).intro. -simplify.unfold lt.apply le_S_S.apply le_minus_m. -qed. - -theorem minus_le_O_to_le: \forall n,m:nat. n-m \leq O \to n \leq m. -intros 2. -apply (nat_elim2 (\lambda n,m:nat.n-m \leq O \to n \leq m)). -intros.apply le_O_n. -simplify.intros. assumption. -simplify.intros.apply le_S_S.apply H.assumption. -qed. - -(* galois *) -theorem monotonic_le_minus_r: -\forall p,q,n:nat. q \leq p \to n-p \le n-q. -simplify.intros 2.apply (nat_elim2 -(\lambda p,q.\forall a.q \leq p \to a-p \leq a-q)). -intros.apply (le_n_O_elim n H).apply le_n. -intros.rewrite < minus_n_O. -apply le_minus_m. -intros.elim a.simplify.apply le_n. -simplify.apply H.apply le_S_S_to_le.assumption. -qed. - -theorem le_minus_to_plus: \forall n,m,p. (le (n-m) p) \to (le n (p+m)). -intros 2.apply (nat_elim2 (\lambda n,m.\forall p.(le (n-m) p) \to (le n (p+m)))). -intros.apply le_O_n. -simplify.intros.rewrite < plus_n_O.assumption. -intros. -rewrite < plus_n_Sm. -apply le_S_S.apply H. -exact H1. -qed. - -theorem le_plus_to_minus: \forall n,m,p. (le n (p+m)) \to (le (n-m) p). -intros 2.apply (nat_elim2 (\lambda n,m.\forall p.(le n (p+m)) \to (le (n-m) p))). -intros.simplify.apply le_O_n. -intros 2.rewrite < plus_n_O.intro.simplify.assumption. -intros.simplify.apply H. -apply le_S_S_to_le.rewrite > plus_n_Sm.assumption. -qed. - -(* the converse of le_plus_to_minus does not hold *) -theorem le_plus_to_minus_r: \forall n,m,p. (le (n+m) p) \to (le n (p-m)). -intros 3.apply (nat_elim2 (\lambda m,p.(le (n+m) p) \to (le n (p-m)))). -intro.rewrite < plus_n_O.rewrite < minus_n_O.intro.assumption. -intro.intro.cut (n=O).rewrite > Hcut.apply le_O_n. -apply sym_eq. apply le_n_O_to_eq. -apply (trans_le ? (n+(S n1))). -rewrite < sym_plus. -apply le_plus_n.assumption. -intros.simplify. -apply H.apply le_S_S_to_le. -rewrite > plus_n_Sm.assumption. -qed. - -(* minus and lt - to be completed *) -theorem lt_minus_to_plus: \forall n,m,p. (lt n (p-m)) \to (lt (n+m) p). -intros 3.apply (nat_elim2 (\lambda m,p.(lt n (p-m)) \to (lt (n+m) p))). -intro.rewrite < plus_n_O.rewrite < minus_n_O.intro.assumption. -simplify.intros.apply False_ind.apply (not_le_Sn_O n H). -simplify.intros.unfold lt. -apply le_S_S. -rewrite < plus_n_Sm. -apply H.apply H1. -qed. - -theorem distributive_times_minus: distributive nat times minus. -unfold distributive. -intros. -apply ((leb_elim z y)). - intro.cut (x*(y-z)+x*z = (x*y-x*z)+x*z). - apply (inj_plus_l (x*z)).assumption. - apply (trans_eq nat ? (x*y)). - rewrite < distr_times_plus.rewrite < (plus_minus_m_m ? ? H).reflexivity. - rewrite < plus_minus_m_m. - reflexivity. - apply le_times_r.assumption. - intro.rewrite > eq_minus_n_m_O. - rewrite > (eq_minus_n_m_O (x*y)). - rewrite < sym_times.simplify.reflexivity. - apply le_times_r.apply lt_to_le.apply not_le_to_lt.assumption. - apply lt_to_le.apply not_le_to_lt.assumption. -qed. - -theorem distr_times_minus: \forall n,m,p:nat. n*(m-p) = n*m-n*p -\def distributive_times_minus. - -theorem eq_minus_plus_plus_minus: \forall n,m,p:nat. p \le m \to (n+m)-p = n+(m-p). -intros. -apply plus_to_minus. -rewrite > sym_plus in \vdash (? ? ? %). -rewrite > assoc_plus. -rewrite < plus_minus_m_m. -reflexivity.assumption. -qed. - -theorem eq_minus_minus_minus_plus: \forall n,m,p:nat. (n-m)-p = n-(m+p). -intros. -cut (m+p \le n \or m+p \nleq n). - elim Hcut. - symmetry.apply plus_to_minus. - rewrite > assoc_plus.rewrite > (sym_plus p).rewrite < plus_minus_m_m. - rewrite > sym_plus.rewrite < plus_minus_m_m. - reflexivity. - apply (trans_le ? (m+p)). - rewrite < sym_plus.apply le_plus_n. - assumption. - apply le_plus_to_minus_r.rewrite > sym_plus.assumption. - rewrite > (eq_minus_n_m_O n (m+p)). - rewrite > (eq_minus_n_m_O (n-m) p). - reflexivity. - apply le_plus_to_minus.apply lt_to_le. rewrite < sym_plus. - apply not_le_to_lt. assumption. - apply lt_to_le.apply not_le_to_lt.assumption. - apply (decidable_le (m+p) n). -qed. - -theorem eq_plus_minus_minus_minus: \forall n,m,p:nat. p \le m \to m \le n \to -p+(n-m) = n-(m-p). -intros. -apply sym_eq. -apply plus_to_minus. -rewrite < assoc_plus. -rewrite < plus_minus_m_m. -rewrite < sym_plus. -rewrite < plus_minus_m_m.reflexivity. -assumption.assumption. -qed. diff --git a/helm/matita/library/nat/nat.ma b/helm/matita/library/nat/nat.ma deleted file mode 100644 index b600072c6..000000000 --- a/helm/matita/library/nat/nat.ma +++ /dev/null @@ -1,107 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/nat". - -include "higher_order_defs/functions.ma". - -inductive nat : Set \def - | O : nat - | S : nat \to nat. - -definition pred: nat \to nat \def - \lambda n:nat. match n with - [ O \Rightarrow O - | (S p) \Rightarrow p ]. - -theorem pred_Sn : \forall n:nat.n=(pred (S n)). - intros. reflexivity. -qed. - -theorem injective_S : injective nat nat S. - unfold injective. - intros. - rewrite > pred_Sn. - rewrite > (pred_Sn y). - apply eq_f. assumption. -qed. - -theorem inj_S : \forall n,m:nat.(S n)=(S m) \to n=m \def - injective_S. - -theorem not_eq_S : \forall n,m:nat. - \lnot n=m \to S n \neq S m. - intros. unfold Not. intros. - apply H. apply injective_S. assumption. -qed. - -definition not_zero : nat \to Prop \def - \lambda n: nat. - match n with - [ O \Rightarrow False - | (S p) \Rightarrow True ]. - -theorem not_eq_O_S : \forall n:nat. O \neq S n. - intros. unfold Not. intros. - cut (not_zero O). - exact Hcut. - rewrite > H.exact I. -qed. - -theorem not_eq_n_Sn : \forall n:nat. n \neq S n. - intros.elim n. - apply not_eq_O_S. - apply not_eq_S.assumption. -qed. - -theorem nat_case: - \forall n:nat.\forall P:nat \to Prop. - P O \to (\forall m:nat. P (S m)) \to P n. -intros.elim n - [ assumption - | apply H1 ] -qed. - -theorem nat_case1: - \forall n:nat.\forall P:nat \to Prop. - (n=O \to P O) \to (\forall m:nat. (n=(S m) \to P (S m))) \to P n. -intros 2; elim n - [ apply H;reflexivity - | apply H2;reflexivity ] -qed. - -theorem nat_elim2 : - \forall R:nat \to nat \to Prop. - (\forall n:nat. R O n) - \to (\forall n:nat. R (S n) O) - \to (\forall n,m:nat. R n m \to R (S n) (S m)) - \to \forall n,m:nat. R n m. -intros 5;elim n - [ apply H - | apply (nat_case m) - [ apply H1 - | intro; apply H2; apply H3 ] ] -qed. - -theorem decidable_eq_nat : \forall n,m:nat.decidable (n=m). - intros.unfold decidable. - apply (nat_elim2 (\lambda n,m.(Or (n=m) ((n=m) \to False)))) - [ intro; elim n1 - [ left; reflexivity - | right; apply not_eq_O_S ] - | intro; right; intro; apply (not_eq_O_S n1); apply sym_eq; assumption - | intros; elim H - [ left; apply eq_f; assumption - | right; intro; apply H1; apply inj_S; assumption ] ] -qed. diff --git a/helm/matita/library/nat/nth_prime.ma b/helm/matita/library/nat/nth_prime.ma deleted file mode 100644 index 5330f52ad..000000000 --- a/helm/matita/library/nat/nth_prime.ma +++ /dev/null @@ -1,200 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/nth_prime". - -include "nat/primes.ma". -include "nat/lt_arith.ma". - -(* upper bound by Bertrand's conjecture. *) -(* Too difficult to prove. -let rec nth_prime n \def -match n with - [ O \Rightarrow (S(S O)) - | (S p) \Rightarrow - let previous_prime \def S (nth_prime p) in - min_aux previous_prime ((S(S O))*previous_prime) primeb]. - -theorem example8 : nth_prime (S(S O)) = (S(S(S(S(S O))))). -normalize.reflexivity. -qed. - -theorem example9 : nth_prime (S(S(S O))) = (S(S(S(S(S(S(S O))))))). -normalize.reflexivity. -qed. - -theorem example10 : nth_prime (S(S(S(S O)))) = (S(S(S(S(S(S(S(S(S(S(S O))))))))))). -normalize.reflexivity. -qed. *) - -theorem smallest_factor_fact: \forall n:nat. -n < smallest_factor (S n!). -intros. -apply not_le_to_lt. -change with (smallest_factor (S n!) \le n \to False).intro. -apply (not_divides_S_fact n (smallest_factor(S n!))). -apply lt_SO_smallest_factor. -unfold lt.apply le_S_S.apply le_SO_fact. -assumption. -apply divides_smallest_factor_n. -unfold lt.apply le_S_S.apply le_O_n. -qed. - -theorem ex_prime: \forall n. (S O) \le n \to \exists m. -n < m \land m \le S n! \land (prime m). -intros. -elim H. -apply (ex_intro nat ? (S(S O))). -split.split.apply (le_n (S(S O))). -apply (le_n (S(S O))).apply (primeb_to_Prop (S(S O))). -apply (ex_intro nat ? (smallest_factor (S (S n1)!))). -split.split. -apply smallest_factor_fact. -apply le_smallest_factor_n. -(* Andrea: ancora hint non lo trova *) -apply prime_smallest_factor_n. -change with ((S(S O)) \le S (S n1)!). -apply le_S.apply le_SSO_fact. -unfold lt.apply le_S_S.assumption. -qed. - -let rec nth_prime n \def -match n with - [ O \Rightarrow (S(S O)) - | (S p) \Rightarrow - let previous_prime \def (nth_prime p) in - let upper_bound \def S previous_prime! in - min_aux (upper_bound - (S previous_prime)) upper_bound primeb]. - -(* it works, but nth_prime 4 takes already a few minutes - -it must compute factorial of 7 ... - -theorem example11 : nth_prime (S(S O)) = (S(S(S(S(S O))))). -normalize.reflexivity. -qed. - -theorem example12: nth_prime (S(S(S O))) = (S(S(S(S(S(S(S O))))))). -normalize.reflexivity. -qed. - -theorem example13 : nth_prime (S(S(S(S O)))) = (S(S(S(S(S(S(S(S(S(S(S O))))))))))). -normalize.reflexivity. -*) - -theorem prime_nth_prime : \forall n:nat.prime (nth_prime n). -intro. -apply (nat_case n). -change with (prime (S(S O))). -apply (primeb_to_Prop (S(S O))). -intro. -change with -(let previous_prime \def (nth_prime m) in -let upper_bound \def S previous_prime! in -prime (min_aux (upper_bound - (S previous_prime)) upper_bound primeb)). -apply primeb_true_to_prime. -apply f_min_aux_true. -apply (ex_intro nat ? (smallest_factor (S (nth_prime m)!))). -split.split. -cut (S (nth_prime m)!-(S (nth_prime m)! - (S (nth_prime m))) = (S (nth_prime m))). -rewrite > Hcut.exact (smallest_factor_fact (nth_prime m)). -(* maybe we could factorize this proof *) -apply plus_to_minus. -apply plus_minus_m_m. -apply le_S_S. -apply le_n_fact_n. -apply le_smallest_factor_n. -apply prime_to_primeb_true. -apply prime_smallest_factor_n. -change with ((S(S O)) \le S (nth_prime m)!). -apply le_S_S.apply le_SO_fact. -qed. - -(* properties of nth_prime *) -theorem increasing_nth_prime: increasing nth_prime. -change with (\forall n:nat. (nth_prime n) < (nth_prime (S n))). -intros. -change with -(let previous_prime \def (nth_prime n) in -let upper_bound \def S previous_prime! in -(S previous_prime) \le min_aux (upper_bound - (S previous_prime)) upper_bound primeb). -intros. -cut (upper_bound - (upper_bound -(S previous_prime)) = (S previous_prime)). -rewrite < Hcut in \vdash (? % ?). -apply le_min_aux. -apply plus_to_minus. -apply plus_minus_m_m. -apply le_S_S. -apply le_n_fact_n. -qed. - -variant lt_nth_prime_n_nth_prime_Sn :\forall n:nat. -(nth_prime n) < (nth_prime (S n)) \def increasing_nth_prime. - -theorem injective_nth_prime: injective nat nat nth_prime. -apply increasing_to_injective. -apply increasing_nth_prime. -qed. - -theorem lt_SO_nth_prime_n : \forall n:nat. (S O) \lt nth_prime n. -intros. elim n.unfold lt.apply le_n. -apply (trans_lt ? (nth_prime n1)). -assumption.apply lt_nth_prime_n_nth_prime_Sn. -qed. - -theorem lt_O_nth_prime_n : \forall n:nat. O \lt nth_prime n. -intros.apply (trans_lt O (S O)). -unfold lt. apply le_n.apply lt_SO_nth_prime_n. -qed. - -theorem ex_m_le_n_nth_prime_m: -\forall n: nat. nth_prime O \le n \to -\exists m. nth_prime m \le n \land n < nth_prime (S m). -intros. -apply increasing_to_le2. -exact lt_nth_prime_n_nth_prime_Sn.assumption. -qed. - -theorem lt_nth_prime_to_not_prime: \forall n,m. nth_prime n < m \to m < nth_prime (S n) -\to \lnot (prime m). -intros. -apply primeb_false_to_not_prime. -letin previous_prime \def (nth_prime n). -letin upper_bound \def (S previous_prime!). -apply (lt_min_aux_to_false primeb upper_bound (upper_bound - (S previous_prime)) m). -cut (S (nth_prime n)!-(S (nth_prime n)! - (S (nth_prime n))) = (S (nth_prime n))). -rewrite > Hcut.assumption. -apply plus_to_minus. -apply plus_minus_m_m. -apply le_S_S. -apply le_n_fact_n. -assumption. -qed. - -(* nth_prime enumerates all primes *) -theorem prime_to_nth_prime : \forall p:nat. prime p \to -\exists i. nth_prime i = p. -intros. -cut (\exists m. nth_prime m \le p \land p < nth_prime (S m)). -elim Hcut.elim H1. -cut (nth_prime a < p \lor nth_prime a = p). -elim Hcut1. -absurd (prime p). -assumption. -apply (lt_nth_prime_to_not_prime a).assumption.assumption. -apply (ex_intro nat ? a).assumption. -apply le_to_or_lt_eq.assumption. -apply ex_m_le_n_nth_prime_m. -simplify.unfold prime in H.elim H.assumption. -qed. - diff --git a/helm/matita/library/nat/ord.ma b/helm/matita/library/nat/ord.ma deleted file mode 100644 index 24874c08a..000000000 --- a/helm/matita/library/nat/ord.ma +++ /dev/null @@ -1,193 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/log". - -include "datatypes/constructors.ma". -include "nat/exp.ma". -include "nat/lt_arith.ma". -include "nat/primes.ma". - -(* this definition of log is based on pairs, with a remainder *) - -let rec p_ord_aux p n m \def - match n \mod m with - [ O \Rightarrow - match p with - [ O \Rightarrow pair nat nat O n - | (S p) \Rightarrow - match (p_ord_aux p (n / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r] ] - | (S a) \Rightarrow pair nat nat O n]. - -(* p_ord n m = if m divides n q times, with remainder r *) -definition p_ord \def \lambda n,m:nat.p_ord_aux n n m. - -theorem p_ord_aux_to_Prop: \forall p,n,m. O < m \to - match p_ord_aux p n m with - [ (pair q r) \Rightarrow n = m \sup q *r ]. -intro. -elim p. -change with -match ( -match n \mod m with - [ O \Rightarrow pair nat nat O n - | (S a) \Rightarrow pair nat nat O n] ) -with - [ (pair q r) \Rightarrow n = m \sup q * r ]. -apply (nat_case (n \mod m)). -simplify.apply plus_n_O. -intros. -simplify.apply plus_n_O. -change with -match ( -match n1 \mod m with - [ O \Rightarrow - match (p_ord_aux n (n1 / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r] - | (S a) \Rightarrow pair nat nat O n1] ) -with - [ (pair q r) \Rightarrow n1 = m \sup q * r]. -apply (nat_case1 (n1 \mod m)).intro. -change with -match ( - match (p_ord_aux n (n1 / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r]) -with - [ (pair q r) \Rightarrow n1 = m \sup q * r]. -generalize in match (H (n1 / m) m). -elim (p_ord_aux n (n1 / m) m). -simplify. -rewrite > assoc_times. -rewrite < H3.rewrite > (plus_n_O (m*(n1 / m))). -rewrite < H2. -rewrite > sym_times. -rewrite < div_mod.reflexivity. -assumption.assumption. -intros.simplify.apply plus_n_O. -qed. - -theorem p_ord_aux_to_exp: \forall p,n,m,q,r. O < m \to - (pair nat nat q r) = p_ord_aux p n m \to n = m \sup q * r. -intros. -change with -match (pair nat nat q r) with - [ (pair q r) \Rightarrow n = m \sup q * r ]. -rewrite > H1. -apply p_ord_aux_to_Prop. -assumption. -qed. -(* questo va spostato in primes1.ma *) -theorem p_ord_exp: \forall n,m,i. O < m \to n \mod m \neq O \to -\forall p. i \le p \to p_ord_aux p (m \sup i * n) m = pair nat nat i n. -intros 5. -elim i. -simplify. -rewrite < plus_n_O. -apply (nat_case p). -change with - (match n \mod m with - [ O \Rightarrow pair nat nat O n - | (S a) \Rightarrow pair nat nat O n] - = pair nat nat O n). -elim (n \mod m).simplify.reflexivity.simplify.reflexivity. -intro. -change with - (match n \mod m with - [ O \Rightarrow - match (p_ord_aux m1 (n / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r] - | (S a) \Rightarrow pair nat nat O n] - = pair nat nat O n). -cut (O < n \mod m \lor O = n \mod m). -elim Hcut.apply (lt_O_n_elim (n \mod m) H3). -intros. simplify.reflexivity. -apply False_ind. -apply H1.apply sym_eq.assumption. -apply le_to_or_lt_eq.apply le_O_n. -generalize in match H3. -apply (nat_case p).intro.apply False_ind.apply (not_le_Sn_O n1 H4). -intros. -change with - (match ((m \sup (S n1) *n) \mod m) with - [ O \Rightarrow - match (p_ord_aux m1 ((m \sup (S n1) *n) / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r] - | (S a) \Rightarrow pair nat nat O (m \sup (S n1) *n)] - = pair nat nat (S n1) n). -cut (((m \sup (S n1)*n) \mod m) = O). -rewrite > Hcut. -change with -(match (p_ord_aux m1 ((m \sup (S n1)*n) / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r] - = pair nat nat (S n1) n). -cut ((m \sup (S n1) *n) / m = m \sup n1 *n). -rewrite > Hcut1. -rewrite > (H2 m1). simplify.reflexivity. -apply le_S_S_to_le.assumption. -(* div_exp *) -change with ((m* m \sup n1 *n) / m = m \sup n1 * n). -rewrite > assoc_times. -apply (lt_O_n_elim m H). -intro.apply div_times. -(* mod_exp = O *) -apply divides_to_mod_O. -assumption. -simplify.rewrite > assoc_times. -apply (witness ? ? (m \sup n1 *n)).reflexivity. -qed. - -theorem p_ord_aux_to_Prop1: \forall p,n,m. (S O) < m \to O < n \to n \le p \to - match p_ord_aux p n m with - [ (pair q r) \Rightarrow r \mod m \neq O]. -intro.elim p.absurd (O < n).assumption. -apply le_to_not_lt.assumption. -change with -match - (match n1 \mod m with - [ O \Rightarrow - match (p_ord_aux n(n1 / m) m) with - [ (pair q r) \Rightarrow pair nat nat (S q) r] - | (S a) \Rightarrow pair nat nat O n1]) -with - [ (pair q r) \Rightarrow r \mod m \neq O]. -apply (nat_case1 (n1 \mod m)).intro. -generalize in match (H (n1 / m) m). -elim (p_ord_aux n (n1 / m) m). -apply H5.assumption. -apply eq_mod_O_to_lt_O_div. -apply (trans_lt ? (S O)).unfold lt.apply le_n. -assumption.assumption.assumption. -apply le_S_S_to_le. -apply (trans_le ? n1).change with (n1 / m < n1). -apply lt_div_n_m_n.assumption.assumption.assumption. -intros. -change with (n1 \mod m \neq O). -rewrite > H4. -unfold Not.intro. -apply (not_eq_O_S m1). -rewrite > H5.reflexivity. -qed. - -theorem p_ord_aux_to_not_mod_O: \forall p,n,m,q,r. (S O) < m \to O < n \to n \le p \to - pair nat nat q r = p_ord_aux p n m \to r \mod m \neq O. -intros. -change with - match (pair nat nat q r) with - [ (pair q r) \Rightarrow r \mod m \neq O]. -rewrite > H3. -apply p_ord_aux_to_Prop1. -assumption.assumption.assumption. -qed. - diff --git a/helm/matita/library/nat/orders.ma b/helm/matita/library/nat/orders.ma deleted file mode 100644 index 6ec0c9992..000000000 --- a/helm/matita/library/nat/orders.ma +++ /dev/null @@ -1,312 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/orders". - -include "nat/nat.ma". -include "higher_order_defs/ordering.ma". - -(* definitions *) -inductive le (n:nat) : nat \to Prop \def - | le_n : le n n - | le_S : \forall m:nat. le n m \to le n (S m). - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural 'less or equal to'" 'leq x y = (cic:/matita/nat/orders/le.ind#xpointer(1/1) x y). -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural 'neither less nor equal to'" 'nleq x y = - (cic:/matita/logic/connectives/Not.con - (cic:/matita/nat/orders/le.ind#xpointer(1/1) x y)). - -definition lt: nat \to nat \to Prop \def -\lambda n,m:nat.(S n) \leq m. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural 'less than'" 'lt x y = (cic:/matita/nat/orders/lt.con x y). -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural 'not less than'" 'nless x y = - (cic:/matita/logic/connectives/Not.con (cic:/matita/nat/orders/lt.con x y)). - -definition ge: nat \to nat \to Prop \def -\lambda n,m:nat.m \leq n. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural 'greater or equal to'" 'geq x y = (cic:/matita/nat/orders/ge.con x y). - -definition gt: nat \to nat \to Prop \def -\lambda n,m:nat.m H7. -apply H. -apply le_to_or_lt_eq.apply H6. -qed. diff --git a/helm/matita/library/nat/permutation.ma b/helm/matita/library/nat/permutation.ma deleted file mode 100644 index d71f4fd27..000000000 --- a/helm/matita/library/nat/permutation.ma +++ /dev/null @@ -1,738 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/permutation". - -include "nat/compare.ma". -include "nat/sigma_and_pi.ma". - -definition injn: (nat \to nat) \to nat \to Prop \def -\lambda f:nat \to nat.\lambda n:nat.\forall i,j:nat. -i \le n \to j \le n \to f i = f j \to i = j. - -theorem injn_Sn_n: \forall f:nat \to nat. \forall n:nat. -injn f (S n) \to injn f n.unfold injn. -intros.apply H. -apply le_S.assumption. -apply le_S.assumption. -assumption. -qed. - -theorem injective_to_injn: \forall f:nat \to nat. \forall n:nat. -injective nat nat f \to injn f n. -unfold injective.unfold injn.intros.apply H.assumption. -qed. - -definition permut : (nat \to nat) \to nat \to Prop -\def \lambda f:nat \to nat. \lambda m:nat. -(\forall i:nat. i \le m \to f i \le m )\land injn f m. - -theorem permut_O_to_eq_O: \forall h:nat \to nat. -permut h O \to (h O) = O. -intros.unfold permut in H. -elim H.apply sym_eq.apply le_n_O_to_eq. -apply H1.apply le_n. -qed. - -theorem permut_S_to_permut: \forall f:nat \to nat. \forall m:nat. -permut f (S m) \to f (S m) = (S m) \to permut f m. -unfold permut.intros. -elim H. -split.intros. -cut (f i < S m \lor f i = S m). -elim Hcut. -apply le_S_S_to_le.assumption. -apply False_ind. -apply (not_le_Sn_n m). -cut ((S m) = i). -rewrite > Hcut1.assumption. -apply H3.apply le_n.apply le_S.assumption. -rewrite > H5.assumption. -apply le_to_or_lt_eq.apply H2.apply le_S.assumption. -apply (injn_Sn_n f m H3). -qed. - -(* transpositions *) - -definition transpose : nat \to nat \to nat \to nat \def -\lambda i,j,n:nat. -match eqb n i with - [ true \Rightarrow j - | false \Rightarrow - match eqb n j with - [ true \Rightarrow i - | false \Rightarrow n]]. - -lemma transpose_i_j_i: \forall i,j:nat. transpose i j i = j. -intros.unfold transpose. -rewrite > (eqb_n_n i).simplify. reflexivity. -qed. - -lemma transpose_i_j_j: \forall i,j:nat. transpose i j j = i. -intros.unfold transpose. -apply (eqb_elim j i).simplify.intro.assumption. -rewrite > (eqb_n_n j).simplify. -intros. reflexivity. -qed. - -theorem transpose_i_i: \forall i,n:nat. (transpose i i n) = n. -intros.unfold transpose. -apply (eqb_elim n i). -intro.simplify.apply sym_eq. assumption. -intro.simplify.reflexivity. -qed. - -theorem transpose_i_j_j_i: \forall i,j,n:nat. -transpose i j n = transpose j i n. -intros.unfold transpose. -apply (eqb_elim n i). -apply (eqb_elim n j). -intros. simplify.rewrite < H. rewrite < H1. -reflexivity. -intros.simplify.reflexivity. -apply (eqb_elim n j). -intros.simplify.reflexivity. -intros.simplify.reflexivity. -qed. - -theorem transpose_transpose: \forall i,j,n:nat. -(transpose i j (transpose i j n)) = n. -intros.unfold transpose. unfold transpose. -apply (eqb_elim n i).simplify. -intro. -apply (eqb_elim j i). -simplify.intros.rewrite > H. rewrite > H1.reflexivity. -rewrite > (eqb_n_n j).simplify.intros. -apply sym_eq. -assumption. -apply (eqb_elim n j).simplify. -rewrite > (eqb_n_n i).intros.simplify. -apply sym_eq. assumption. -simplify.intros. -rewrite > (not_eq_to_eqb_false n i H1). -rewrite > (not_eq_to_eqb_false n j H). -simplify.reflexivity. -qed. - -theorem injective_transpose : \forall i,j:nat. -injective nat nat (transpose i j). -unfold injective. -intros. -rewrite < (transpose_transpose i j x). -rewrite < (transpose_transpose i j y). -apply eq_f.assumption. -qed. - -variant inj_transpose: \forall i,j,n,m:nat. -transpose i j n = transpose i j m \to n = m \def -injective_transpose. - -theorem permut_transpose: \forall i,j,n:nat. i \le n \to j \le n \to -permut (transpose i j) n. -unfold permut.intros. -split.unfold transpose. -intros. -elim (eqb i1 i).simplify.assumption. -elim (eqb i1 j).simplify.assumption. -simplify.assumption. -apply (injective_to_injn (transpose i j) n). -apply injective_transpose. -qed. - -theorem permut_fg: \forall f,g:nat \to nat. \forall n:nat. -permut f n \to permut g n \to permut (\lambda m.(f(g m))) n. -unfold permut. intros. -elim H.elim H1. -split.intros.simplify.apply H2. -apply H4.assumption. -simplify.intros. -apply H5.assumption.assumption. -apply H3.apply H4.assumption.apply H4.assumption. -assumption. -qed. - -theorem permut_transpose_l: -\forall f:nat \to nat. \forall m,i,j:nat. -i \le m \to j \le m \to permut f m \to permut (\lambda n.transpose i j (f n)) m. -intros.apply (permut_fg (transpose i j) f m ? ?). -apply permut_transpose.assumption.assumption. -assumption. -qed. - -theorem permut_transpose_r: -\forall f:nat \to nat. \forall m,i,j:nat. -i \le m \to j \le m \to permut f m \to permut (\lambda n.f (transpose i j n)) m. -intros.apply (permut_fg f (transpose i j) m ? ?). -assumption.apply permut_transpose.assumption.assumption. -qed. - -theorem eq_transpose : \forall i,j,k,n:nat. \lnot j=i \to - \lnot i=k \to \lnot j=k \to -transpose i j n = transpose i k (transpose k j (transpose i k n)). -(* uffa: triplo unfold? *) -intros.unfold transpose.unfold transpose.unfold transpose. -apply (eqb_elim n i).intro. -simplify.rewrite > (eqb_n_n k). -simplify.rewrite > (not_eq_to_eqb_false j i H). -rewrite > (not_eq_to_eqb_false j k H2). -reflexivity. -intro.apply (eqb_elim n j). -intro. -cut (\lnot n = k). -cut (\lnot n = i). -rewrite > (not_eq_to_eqb_false n k Hcut). -simplify. -rewrite > (not_eq_to_eqb_false n k Hcut). -rewrite > (eq_to_eqb_true n j H4). -simplify. -rewrite > (not_eq_to_eqb_false k i). -rewrite > (eqb_n_n k). -simplify.reflexivity. -unfold Not.intro.apply H1.apply sym_eq.assumption. -assumption. -unfold Not.intro.apply H2.apply (trans_eq ? ? n). -apply sym_eq.assumption.assumption. -intro.apply (eqb_elim n k).intro. -simplify. -rewrite > (not_eq_to_eqb_false i k H1). -rewrite > (not_eq_to_eqb_false i j). -simplify. -rewrite > (eqb_n_n i). -simplify.assumption. -unfold Not.intro.apply H.apply sym_eq.assumption. -intro.simplify. -rewrite > (not_eq_to_eqb_false n k H5). -rewrite > (not_eq_to_eqb_false n j H4). -simplify. -rewrite > (not_eq_to_eqb_false n i H3). -rewrite > (not_eq_to_eqb_false n k H5). -simplify.reflexivity. -qed. - -theorem permut_S_to_permut_transpose: \forall f:nat \to nat. -\forall m:nat. permut f (S m) \to permut (\lambda n.transpose (f (S m)) (S m) -(f n)) m. -unfold permut.intros. -elim H. -split.intros.simplify.unfold transpose. -apply (eqb_elim (f i) (f (S m))). -intro.apply False_ind. -cut (i = (S m)). -apply (not_le_Sn_n m). -rewrite < Hcut.assumption. -apply H2.apply le_S.assumption.apply le_n.assumption. -intro.simplify. -apply (eqb_elim (f i) (S m)). -intro. -cut (f (S m) \lt (S m) \lor f (S m) = (S m)). -elim Hcut.apply le_S_S_to_le.assumption. -apply False_ind.apply H4.rewrite > H6.assumption. -apply le_to_or_lt_eq.apply H1.apply le_n. -intro.simplify. -cut (f i \lt (S m) \lor f i = (S m)). -elim Hcut.apply le_S_S_to_le.assumption. -apply False_ind.apply H5.assumption. -apply le_to_or_lt_eq.apply H1.apply le_S.assumption. -unfold injn.intros. -apply H2.apply le_S.assumption.apply le_S.assumption. -apply (inj_transpose (f (S m)) (S m)). -apply H5. -qed. - -(* bounded bijectivity *) - -definition bijn : (nat \to nat) \to nat \to Prop \def -\lambda f:nat \to nat. \lambda n. \forall m:nat. m \le n \to -ex nat (\lambda p. p \le n \land f p = m). - -theorem eq_to_bijn: \forall f,g:nat\to nat. \forall n:nat. -(\forall i:nat. i \le n \to (f i) = (g i)) \to -bijn f n \to bijn g n. -intros 4.unfold bijn. -intros.elim (H1 m). -apply (ex_intro ? ? a). -rewrite < (H a).assumption. -elim H3.assumption.assumption. -qed. - -theorem bijn_Sn_n: \forall f:nat \to nat. \forall n:nat. -bijn f (S n) \to f (S n) = (S n) \to bijn f n. -unfold bijn.intros.elim (H m). -elim H3. -apply (ex_intro ? ? a).split. -cut (a < S n \lor a = S n). -elim Hcut.apply le_S_S_to_le.assumption. -apply False_ind. -apply (not_le_Sn_n n). -rewrite < H1.rewrite < H6.rewrite > H5.assumption. -apply le_to_or_lt_eq.assumption.assumption. -apply le_S.assumption. -qed. - -theorem bijn_n_Sn: \forall f:nat \to nat. \forall n:nat. -bijn f n \to f (S n) = (S n) \to bijn f (S n). -unfold bijn.intros. -cut (m < S n \lor m = S n). -elim Hcut. -elim (H m). -elim H4. -apply (ex_intro ? ? a).split. -apply le_S.assumption.assumption. -apply le_S_S_to_le.assumption. -apply (ex_intro ? ? (S n)). -split.apply le_n. -rewrite > H3.assumption. -apply le_to_or_lt_eq.assumption. -qed. - -theorem bijn_fg: \forall f,g:nat\to nat. \forall n:nat. -bijn f n \to bijn g n \to bijn (\lambda p.f(g p)) n. -unfold bijn. -intros.simplify. -elim (H m).elim H3. -elim (H1 a).elim H6. -apply (ex_intro ? ? a1). -split.assumption. -rewrite > H8.assumption. -assumption.assumption. -qed. - -theorem bijn_transpose : \forall n,i,j. i \le n \to j \le n \to -bijn (transpose i j) n. -intros.unfold bijn.unfold transpose.intros. -cut (m = i \lor \lnot m = i). -elim Hcut. -apply (ex_intro ? ? j). -split.assumption. -apply (eqb_elim j i). -intro.simplify.rewrite > H3.rewrite > H4.reflexivity. -rewrite > (eqb_n_n j).simplify. -intros. apply sym_eq.assumption. -cut (m = j \lor \lnot m = j). -elim Hcut1. -apply (ex_intro ? ? i). -split.assumption. -rewrite > (eqb_n_n i).simplify. -apply sym_eq. assumption. -apply (ex_intro ? ? m). -split.assumption. -rewrite > (not_eq_to_eqb_false m i). -rewrite > (not_eq_to_eqb_false m j). -simplify. reflexivity. -assumption. -assumption. -apply (decidable_eq_nat m j). -apply (decidable_eq_nat m i). -qed. - -theorem bijn_transpose_r: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to -bijn f n \to bijn (\lambda p.f (transpose i j p)) n. -intros. -apply (bijn_fg f ?).assumption. -apply (bijn_transpose n i j).assumption.assumption. -qed. - -theorem bijn_transpose_l: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to -bijn f n \to bijn (\lambda p.transpose i j (f p)) n. -intros. -apply (bijn_fg ? f). -apply (bijn_transpose n i j).assumption.assumption. -assumption. -qed. - -theorem permut_to_bijn: \forall n:nat.\forall f:nat\to nat. -permut f n \to bijn f n. -intro. -elim n.unfold bijn.intros. -apply (ex_intro ? ? m). -split.assumption. -apply (le_n_O_elim m ? (\lambda p. f p = p)). -assumption.unfold permut in H. -elim H.apply sym_eq. apply le_n_O_to_eq.apply H2.apply le_n. -apply (eq_to_bijn (\lambda p. -(transpose (f (S n1)) (S n1)) (transpose (f (S n1)) (S n1) (f p))) f). -intros.apply transpose_transpose. -apply (bijn_fg (transpose (f (S n1)) (S n1))). -apply bijn_transpose. -unfold permut in H1. -elim H1.apply H2.apply le_n.apply le_n. -apply bijn_n_Sn. -apply H. -apply permut_S_to_permut_transpose. -assumption.unfold transpose. -rewrite > (eqb_n_n (f (S n1))).simplify.reflexivity. -qed. - -let rec invert_permut n f m \def - match eqb m (f n) with - [true \Rightarrow n - |false \Rightarrow - match n with - [O \Rightarrow O - |(S p) \Rightarrow invert_permut p f m]]. - -theorem invert_permut_f: \forall f:nat \to nat. \forall n,m:nat. -m \le n \to injn f n\to invert_permut n f (f m) = m. -intros 4. -elim H. -apply (nat_case1 m). -intro.simplify. -rewrite > (eqb_n_n (f O)).simplify.reflexivity. -intros.simplify. -rewrite > (eqb_n_n (f (S m1))).simplify.reflexivity. -simplify. -rewrite > (not_eq_to_eqb_false (f m) (f (S n1))). -simplify.apply H2. -apply injn_Sn_n. assumption. -unfold Not.intro.absurd (m = S n1). -apply H3.apply le_S.assumption.apply le_n.assumption. -unfold Not.intro. -apply (not_le_Sn_n n1).rewrite < H5.assumption. -qed. - -theorem injective_invert_permut: \forall f:nat \to nat. \forall n:nat. -permut f n \to injn (invert_permut n f) n. -intros. -unfold injn.intros. -cut (bijn f n). -unfold bijn in Hcut. -generalize in match (Hcut i H1).intro. -generalize in match (Hcut j H2).intro. -elim H4.elim H6. -elim H5.elim H9. -rewrite < H8. -rewrite < H11. -apply eq_f. -rewrite < (invert_permut_f f n a). -rewrite < (invert_permut_f f n a1). -rewrite > H8. -rewrite > H11. -assumption.assumption. -unfold permut in H.elim H. assumption. -assumption. -unfold permut in H.elim H. assumption. -apply permut_to_bijn.assumption. -qed. - -theorem permut_invert_permut: \forall f:nat \to nat. \forall n:nat. -permut f n \to permut (invert_permut n f) n. -intros.unfold permut.split. -intros.simplify.elim n. -simplify.elim (eqb i (f O)).simplify.apply le_n.simplify.apply le_n. -simplify.elim (eqb i (f (S n1))).simplify.apply le_n. -simplify.apply le_S. assumption. -apply injective_invert_permut.assumption. -qed. - -theorem f_invert_permut: \forall f:nat \to nat. \forall n,m:nat. -m \le n \to permut f n\to f (invert_permut n f m) = m. -intros. -apply (injective_invert_permut f n H1). -unfold permut in H1.elim H1. -apply H2. -cut (permut (invert_permut n f) n).unfold permut in Hcut. -elim Hcut.apply H4.assumption. -apply permut_invert_permut.assumption.assumption. -apply invert_permut_f. -cut (permut (invert_permut n f) n).unfold permut in Hcut. -elim Hcut.apply H2.assumption. -apply permut_invert_permut.assumption. -unfold permut in H1.elim H1.assumption. -qed. - -theorem permut_n_to_eq_n: \forall h:nat \to nat.\forall n:nat. -permut h n \to (\forall m:nat. m < n \to h m = m) \to h n = n. -intros.unfold permut in H.elim H. -cut (invert_permut n h n < n \lor invert_permut n h n = n). -elim Hcut. -rewrite < (f_invert_permut h n n) in \vdash (? ? ? %). -apply eq_f. -rewrite < (f_invert_permut h n n) in \vdash (? ? % ?). -apply H1.assumption.apply le_n.assumption.apply le_n.assumption. -rewrite < H4 in \vdash (? ? % ?). -apply (f_invert_permut h).apply le_n.assumption. -apply le_to_or_lt_eq. -cut (permut (invert_permut n h) n). -unfold permut in Hcut.elim Hcut. -apply H4.apply le_n. -apply permut_invert_permut.assumption. -qed. - -theorem permut_n_to_le: \forall h:nat \to nat.\forall k,n:nat. -k \le n \to permut h n \to (\forall m:nat. m < k \to h m = m) \to -\forall j. k \le j \to j \le n \to k \le h j. -intros.unfold permut in H1.elim H1. -cut (h j < k \lor \not(h j < k)). -elim Hcut.absurd (k \le j).assumption. -apply lt_to_not_le. -cut (h j = j).rewrite < Hcut1.assumption. -apply H6.apply H5.assumption.assumption. -apply H2.assumption. -apply not_lt_to_le.assumption. -apply (decidable_lt (h j) k). -qed. - -(* applications *) - -let rec map_iter_i k (g:nat \to nat) f (i:nat) \def - match k with - [ O \Rightarrow g i - | (S k) \Rightarrow f (g (S (k+i))) (map_iter_i k g f i)]. - -theorem eq_map_iter_i: \forall g1,g2:nat \to nat. -\forall f:nat \to nat \to nat. \forall n,i:nat. -(\forall m:nat. i\le m \to m \le n+i \to g1 m = g2 m) \to -map_iter_i n g1 f i = map_iter_i n g2 f i. -intros 5.elim n.simplify.apply H.apply le_n. -apply le_n.simplify.apply eq_f2.apply H1.simplify. -apply le_S.apply le_plus_n.simplify.apply le_n. -apply H.intros.apply H1.assumption.simplify.apply le_S.assumption. -qed. - -(* map_iter examples *) - -theorem eq_map_iter_i_sigma: \forall g:nat \to nat. \forall n,m:nat. -map_iter_i n g plus m = sigma n g m. -intros.elim n.simplify.reflexivity. -simplify. -apply eq_f.assumption. -qed. - -theorem eq_map_iter_i_pi: \forall g:nat \to nat. \forall n,m:nat. -map_iter_i n g times m = pi n g m. -intros.elim n.simplify.reflexivity. -simplify. -apply eq_f.assumption. -qed. - -theorem eq_map_iter_i_fact: \forall n:nat. -map_iter_i n (\lambda m.m) times (S O) = (S n)!. -intros.elim n. -simplify.reflexivity. -change with -(((S n1)+(S O))*(map_iter_i n1 (\lambda m.m) times (S O)) = (S(S n1))*(S n1)!). -rewrite < plus_n_Sm.rewrite < plus_n_O. -apply eq_f.assumption. -qed. - -theorem eq_map_iter_i_transpose_l : \forall f:nat\to nat \to nat.associative nat f \to -symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k:nat. -map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose (k+n) (S k+n) m)) f n. -intros.apply (nat_case1 k). -intros.simplify. -change with -(f (g (S n)) (g n) = -f (g (transpose n (S n) (S n))) (g (transpose n (S n) n))). -rewrite > transpose_i_j_i. -rewrite > transpose_i_j_j. -apply H1. -intros. -change with -(f (g (S (S (m+n)))) (f (g (S (m+n))) (map_iter_i m g f n)) = -f (g (transpose (S m + n) (S (S m) + n) (S (S m)+n))) -(f (g (transpose (S m + n) (S (S m) + n) (S m+n))) -(map_iter_i m (\lambda m1. g (transpose (S m+n) (S (S m)+n) m1)) f n))). -rewrite > transpose_i_j_i. -rewrite > transpose_i_j_j. -rewrite < H. -rewrite < H. -rewrite < (H1 (g (S m + n))). -apply eq_f. -apply eq_map_iter_i. -intros.simplify.unfold transpose. -rewrite > (not_eq_to_eqb_false m1 (S m+n)). -rewrite > (not_eq_to_eqb_false m1 (S (S m)+n)). -simplify. -reflexivity. -apply (lt_to_not_eq m1 (S ((S m)+n))). -unfold lt.apply le_S_S.change with (m1 \leq S (m+n)).apply le_S.assumption. -apply (lt_to_not_eq m1 (S m+n)). -simplify.unfold lt.apply le_S_S.assumption. -qed. - -theorem eq_map_iter_i_transpose_i_Si : \forall f:nat\to nat \to nat.associative nat f \to -symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k,i:nat. n \le i \to i \le k+n \to -map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S i) m)) f n. -intros 6.elim k.cut (i=n). -rewrite > Hcut. -apply (eq_map_iter_i_transpose_l f H H1 g n O). -apply antisymmetric_le.assumption.assumption. -cut (i < S n1 + n \lor i = S n1 + n). -elim Hcut. -change with -(f (g (S (S n1)+n)) (map_iter_i (S n1) g f n) = -f (g (transpose i (S i) (S (S n1)+n))) (map_iter_i (S n1) (\lambda m. g (transpose i (S i) m)) f n)). -apply eq_f2.unfold transpose. -rewrite > (not_eq_to_eqb_false (S (S n1)+n) i). -rewrite > (not_eq_to_eqb_false (S (S n1)+n) (S i)). -simplify.reflexivity. -simplify.unfold Not.intro. -apply (lt_to_not_eq i (S n1+n)).assumption. -apply inj_S.apply sym_eq. assumption. -simplify.unfold Not.intro. -apply (lt_to_not_eq i (S (S n1+n))).simplify.unfold lt. -apply le_S_S.assumption. -apply sym_eq. assumption. -apply H2.assumption.apply le_S_S_to_le. -assumption. -rewrite > H5. -apply (eq_map_iter_i_transpose_l f H H1 g n (S n1)). -apply le_to_or_lt_eq.assumption. -qed. - -theorem eq_map_iter_i_transpose: -\forall f:nat\to nat \to nat. -associative nat f \to symmetric2 nat nat f \to \forall n,k,o:nat. -\forall g:nat \to nat. \forall i:nat. n \le i \to S (o + i) \le S k+n \to -map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S(o + i)) m)) f n. -intros 6. -apply (nat_elim1 o). -intro. -apply (nat_case m ?). -intros. -apply (eq_map_iter_i_transpose_i_Si ? H H1). -exact H3.apply le_S_S_to_le.assumption. -intros. -apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g (transpose i (S(m1 + i)) m)) f n)). -apply H2. -unfold lt. apply le_n.assumption. -apply (trans_le ? (S(S (m1+i)))). -apply le_S.apply le_n.assumption. -apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g -(transpose i (S(m1 + i)) (transpose (S(m1 + i)) (S(S(m1 + i))) m))) f n)). -apply (H2 O ? ? (S(m1+i))). -unfold lt.apply le_S_S.apply le_O_n. -apply (trans_le ? i).assumption. -change with (i \le (S m1)+i).apply le_plus_n. -exact H4. -apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g -(transpose i (S(m1 + i)) -(transpose (S(m1 + i)) (S(S(m1 + i))) -(transpose i (S(m1 + i)) m)))) f n)). -apply (H2 m1). -unfold lt. apply le_n.assumption. -apply (trans_le ? (S(S (m1+i)))). -apply le_S.apply le_n.assumption. -apply eq_map_iter_i. -intros.apply eq_f. -apply sym_eq. apply eq_transpose. -unfold Not. intro. -apply (not_le_Sn_n i). -rewrite < H7 in \vdash (? ? %). -apply le_S_S.apply le_S. -apply le_plus_n. -unfold Not. intro. -apply (not_le_Sn_n i). -rewrite > H7 in \vdash (? ? %). -apply le_S_S. -apply le_plus_n. -unfold Not. intro. -apply (not_eq_n_Sn (S m1+i)). -apply sym_eq.assumption. -qed. - -theorem eq_map_iter_i_transpose1: \forall f:nat\to nat \to nat.associative nat f \to -symmetric2 nat nat f \to \forall n,k,i,j:nat. -\forall g:nat \to nat. n \le i \to i < j \to j \le S k+n \to -map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n. -intros. -simplify in H3. -cut ((S i) < j \lor (S i) = j). -elim Hcut. -cut (j = S ((j - (S i)) + i)). -rewrite > Hcut1. -apply (eq_map_iter_i_transpose f H H1 n k (j - (S i)) g i). -assumption. -rewrite < Hcut1.assumption. -rewrite > plus_n_Sm. -apply plus_minus_m_m.apply lt_to_le.assumption. -rewrite < H5. -apply (eq_map_iter_i_transpose_i_Si f H H1 g). -simplify. -assumption.apply le_S_S_to_le. -apply (trans_le ? j).assumption.assumption. -apply le_to_or_lt_eq.assumption. -qed. - -theorem eq_map_iter_i_transpose2: \forall f:nat\to nat \to nat.associative nat f \to -symmetric2 nat nat f \to \forall n,k,i,j:nat. -\forall g:nat \to nat. n \le i \to i \le (S k+n) \to n \le j \to j \le (S k+n) \to -map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n. -intros. -apply (nat_compare_elim i j). -intro.apply (eq_map_iter_i_transpose1 f H H1 n k i j g H2 H6 H5). -intro.rewrite > H6. -apply eq_map_iter_i.intros. -rewrite > (transpose_i_i j).reflexivity. -intro. -apply (trans_eq ? ? (map_iter_i (S k) (\lambda m:nat.g (transpose j i m)) f n)). -apply (eq_map_iter_i_transpose1 f H H1 n k j i g H4 H6 H3). -apply eq_map_iter_i. -intros.apply eq_f.apply transpose_i_j_j_i. -qed. - -theorem permut_to_eq_map_iter_i:\forall f:nat\to nat \to nat.associative nat f \to -symmetric2 nat nat f \to \forall k,n:nat.\forall g,h:nat \to nat. -permut h (k+n) \to (\forall m:nat. m \lt n \to h m = m) \to -map_iter_i k g f n = map_iter_i k (\lambda m.g(h m)) f n. -intros 4.elim k. -simplify.rewrite > (permut_n_to_eq_n h).reflexivity.assumption.assumption. -apply (trans_eq ? ? (map_iter_i (S n) (\lambda m.g ((transpose (h (S n+n1)) (S n+n1)) m)) f n1)). -unfold permut in H3. -elim H3. -apply (eq_map_iter_i_transpose2 f H H1 n1 n ? ? g). -apply (permut_n_to_le h n1 (S n+n1)). -apply le_plus_n.assumption.assumption.apply le_plus_n.apply le_n. -apply H5.apply le_n.apply le_plus_n.apply le_n. -apply (trans_eq ? ? (map_iter_i (S n) (\lambda m. -(g(transpose (h (S n+n1)) (S n+n1) -(transpose (h (S n+n1)) (S n+n1) (h m)))) )f n1)). -change with -(f (g (transpose (h (S n+n1)) (S n+n1) (S n+n1))) -(map_iter_i n (\lambda m. -g (transpose (h (S n+n1)) (S n+n1) m)) f n1) -= -f -(g(transpose (h (S n+n1)) (S n+n1) -(transpose (h (S n+n1)) (S n+n1) (h (S n+n1))))) -(map_iter_i n -(\lambda m. -(g(transpose (h (S n+n1)) (S n+n1) -(transpose (h (S n+n1)) (S n+n1) (h m))))) f n1)). -apply eq_f2.apply eq_f. -rewrite > transpose_i_j_j. -rewrite > transpose_i_j_i. -rewrite > transpose_i_j_j.reflexivity. -apply (H2 n1 (\lambda m.(g(transpose (h (S n+n1)) (S n+n1) m)))). -apply permut_S_to_permut_transpose. -assumption. -intros. -unfold transpose. -rewrite > (not_eq_to_eqb_false (h m) (h (S n+n1))). -rewrite > (not_eq_to_eqb_false (h m) (S n+n1)). -simplify.apply H4.assumption. -rewrite > H4. -apply lt_to_not_eq.apply (trans_lt ? n1).assumption. -simplify.unfold lt.apply le_S_S.apply le_plus_n.assumption. -unfold permut in H3.elim H3. -simplify.unfold Not.intro. -apply (lt_to_not_eq m (S n+n1)).apply (trans_lt ? n1).assumption. -simplify.unfold lt.apply le_S_S.apply le_plus_n. -unfold injn in H7. -apply (H7 m (S n+n1)).apply (trans_le ? n1). -apply lt_to_le.assumption.apply le_plus_n.apply le_n. -assumption. -apply eq_map_iter_i.intros. -rewrite > transpose_transpose.reflexivity. -qed. \ No newline at end of file diff --git a/helm/matita/library/nat/plus.ma b/helm/matita/library/nat/plus.ma deleted file mode 100644 index d595dad19..000000000 --- a/helm/matita/library/nat/plus.ma +++ /dev/null @@ -1,72 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/plus". - -include "nat/nat.ma". - -let rec plus n m \def - match n with - [ O \Rightarrow m - | (S p) \Rightarrow S (plus p m) ]. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural plus" 'plus x y = (cic:/matita/nat/plus/plus.con x y). - -theorem plus_n_O: \forall n:nat. n = n+O. -intros.elim n. -simplify.reflexivity. -simplify.apply eq_f.assumption. -qed. - -theorem plus_n_Sm : \forall n,m:nat. S (n+m) = n+(S m). -intros.elim n. -simplify.reflexivity. -simplify.apply eq_f.assumption. -qed. - -theorem sym_plus: \forall n,m:nat. n+m = m+n. -intros.elim n. -simplify.apply plus_n_O. -simplify.rewrite > H.apply plus_n_Sm. -qed. - -theorem associative_plus : associative nat plus. -unfold associative.intros.elim x. -simplify.reflexivity. -simplify.apply eq_f.assumption. -qed. - -theorem assoc_plus : \forall n,m,p:nat. (n+m)+p = n+(m+p) -\def associative_plus. - -theorem injective_plus_r: \forall n:nat.injective nat nat (\lambda m.n+m). -intro.simplify.intros 2.elim n. -exact H. -apply H.apply inj_S.apply H1. -qed. - -theorem inj_plus_r: \forall p,n,m:nat. p+n = p+m \to n=m -\def injective_plus_r. - -theorem injective_plus_l: \forall m:nat.injective nat nat (\lambda n.n+m). -intro.simplify.intros. -apply (injective_plus_r m). -rewrite < sym_plus. -rewrite < (sym_plus y). -assumption. -qed. - -theorem inj_plus_l: \forall p,n,m:nat. n+p = m+p \to n=m -\def injective_plus_l. diff --git a/helm/matita/library/nat/primes.ma b/helm/matita/library/nat/primes.ma deleted file mode 100644 index 50b7d1221..000000000 --- a/helm/matita/library/nat/primes.ma +++ /dev/null @@ -1,591 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/primes". - -include "nat/div_and_mod.ma". -include "nat/minimization.ma". -include "nat/sigma_and_pi.ma". -include "nat/factorial.ma". - -inductive divides (n,m:nat) : Prop \def -witness : \forall p:nat.m = times n p \to divides n m. - -interpretation "divides" 'divides n m = (cic:/matita/nat/primes/divides.ind#xpointer(1/1) n m). -interpretation "not divides" 'ndivides n m = - (cic:/matita/logic/connectives/Not.con (cic:/matita/nat/primes/divides.ind#xpointer(1/1) n m)). - -theorem reflexive_divides : reflexive nat divides. -unfold reflexive. -intros. -exact (witness x x (S O) (times_n_SO x)). -qed. - -theorem divides_to_div_mod_spec : -\forall n,m. O < n \to n \divides m \to div_mod_spec m n (m / n) O. -intros.elim H1.rewrite > H2. -constructor 1.assumption. -apply (lt_O_n_elim n H).intros. -rewrite < plus_n_O. -rewrite > div_times.apply sym_times. -qed. - -theorem div_mod_spec_to_divides : -\forall n,m,p. div_mod_spec m n p O \to n \divides m. -intros.elim H. -apply (witness n m p). -rewrite < sym_times. -rewrite > (plus_n_O (p*n)).assumption. -qed. - -theorem divides_to_mod_O: -\forall n,m. O < n \to n \divides m \to (m \mod n) = O. -intros.apply (div_mod_spec_to_eq2 m n (m / n) (m \mod n) (m / n) O). -apply div_mod_spec_div_mod.assumption. -apply divides_to_div_mod_spec.assumption.assumption. -qed. - -theorem mod_O_to_divides: -\forall n,m. O< n \to (m \mod n) = O \to n \divides m. -intros. -apply (witness n m (m / n)). -rewrite > (plus_n_O (n * (m / n))). -rewrite < H1. -rewrite < sym_times. -(* Andrea: perche' hint non lo trova ?*) -apply div_mod. -assumption. -qed. - -theorem divides_n_O: \forall n:nat. n \divides O. -intro. apply (witness n O O).apply times_n_O. -qed. - -theorem divides_n_n: \forall n:nat. n \divides n. -intro. apply (witness n n (S O)).apply times_n_SO. -qed. - -theorem divides_SO_n: \forall n:nat. (S O) \divides n. -intro. apply (witness (S O) n n). simplify.apply plus_n_O. -qed. - -theorem divides_plus: \forall n,p,q:nat. -n \divides p \to n \divides q \to n \divides p+q. -intros. -elim H.elim H1. apply (witness n (p+q) (n2+n1)). -rewrite > H2.rewrite > H3.apply sym_eq.apply distr_times_plus. -qed. - -theorem divides_minus: \forall n,p,q:nat. -divides n p \to divides n q \to divides n (p-q). -intros. -elim H.elim H1. apply (witness n (p-q) (n2-n1)). -rewrite > H2.rewrite > H3.apply sym_eq.apply distr_times_minus. -qed. - -theorem divides_times: \forall n,m,p,q:nat. -n \divides p \to m \divides q \to n*m \divides p*q. -intros. -elim H.elim H1. apply (witness (n*m) (p*q) (n2*n1)). -rewrite > H2.rewrite > H3. -apply (trans_eq nat ? (n*(m*(n2*n1)))). -apply (trans_eq nat ? (n*(n2*(m*n1)))). -apply assoc_times. -apply eq_f. -apply (trans_eq nat ? ((n2*m)*n1)). -apply sym_eq. apply assoc_times. -rewrite > (sym_times n2 m).apply assoc_times. -apply sym_eq. apply assoc_times. -qed. - -theorem transitive_divides: transitive ? divides. -unfold. -intros. -elim H.elim H1. apply (witness x z (n2*n)). -rewrite > H3.rewrite > H2. -apply assoc_times. -qed. - -variant trans_divides: \forall n,m,p. - n \divides m \to m \divides p \to n \divides p \def transitive_divides. - -theorem eq_mod_to_divides:\forall n,m,p. O< p \to -mod n p = mod m p \to divides p (n-m). -intros. -cut (n \le m \or \not n \le m). -elim Hcut. -cut (n-m=O). -rewrite > Hcut1. -apply (witness p O O). -apply times_n_O. -apply eq_minus_n_m_O. -assumption. -apply (witness p (n-m) ((div n p)-(div m p))). -rewrite > distr_times_minus. -rewrite > sym_times. -rewrite > (sym_times p). -cut ((div n p)*p = n - (mod n p)). -rewrite > Hcut1. -rewrite > eq_minus_minus_minus_plus. -rewrite > sym_plus. -rewrite > H1. -rewrite < div_mod.reflexivity. -assumption. -apply sym_eq. -apply plus_to_minus. -rewrite > sym_plus. -apply div_mod. -assumption. -apply (decidable_le n m). -qed. - -theorem antisymmetric_divides: antisymmetric nat divides. -unfold antisymmetric.intros.elim H. elim H1. -apply (nat_case1 n2).intro. -rewrite > H3.rewrite > H2.rewrite > H4. -rewrite < times_n_O.reflexivity. -intros. -apply (nat_case1 n).intro. -rewrite > H2.rewrite > H3.rewrite > H5. -rewrite < times_n_O.reflexivity. -intros. -apply antisymmetric_le. -rewrite > H2.rewrite > times_n_SO in \vdash (? % ?). -apply le_times_r.rewrite > H4.apply le_S_S.apply le_O_n. -rewrite > H3.rewrite > times_n_SO in \vdash (? % ?). -apply le_times_r.rewrite > H5.apply le_S_S.apply le_O_n. -qed. - -(* divides le *) -theorem divides_to_le : \forall n,m. O < m \to n \divides m \to n \le m. -intros. elim H1.rewrite > H2.cut (O < n2). -apply (lt_O_n_elim n2 Hcut).intro.rewrite < sym_times. -simplify.rewrite < sym_plus. -apply le_plus_n. -elim (le_to_or_lt_eq O n2). -assumption. -absurd (O H2.rewrite < H3.rewrite < times_n_O. -apply (not_le_Sn_n O). -apply le_O_n. -qed. - -theorem divides_to_lt_O : \forall n,m. O < m \to n \divides m \to O < n. -intros.elim H1. -elim (le_to_or_lt_eq O n (le_O_n n)). -assumption. -rewrite < H3.absurd (O < m).assumption. -rewrite > H2.rewrite < H3. -simplify.exact (not_le_Sn_n O). -qed. - -(* boolean divides *) -definition divides_b : nat \to nat \to bool \def -\lambda n,m :nat. (eqb (m \mod n) O). - -theorem divides_b_to_Prop : -\forall n,m:nat. O < n \to -match divides_b n m with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m]. -intros. -change with -match eqb (m \mod n) O with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m]. -apply eqb_elim. -intro.simplify.apply mod_O_to_divides.assumption.assumption. -intro.simplify.unfold Not.intro.apply H1.apply divides_to_mod_O.assumption.assumption. -qed. - -theorem divides_b_true_to_divides : -\forall n,m:nat. O < n \to -(divides_b n m = true ) \to n \divides m. -intros. -change with -match true with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m]. -rewrite < H1.apply divides_b_to_Prop. -assumption. -qed. - -theorem divides_b_false_to_not_divides : -\forall n,m:nat. O < n \to -(divides_b n m = false ) \to n \ndivides m. -intros. -change with -match false with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m]. -rewrite < H1.apply divides_b_to_Prop. -assumption. -qed. - -theorem decidable_divides: \forall n,m:nat.O < n \to -decidable (n \divides m). -intros.change with ((n \divides m) \lor n \ndivides m). -cut -(match divides_b n m with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m] \to n \divides m \lor n \ndivides m). -apply Hcut.apply divides_b_to_Prop.assumption. -elim (divides_b n m).left.apply H1.right.apply H1. -qed. - -theorem divides_to_divides_b_true : \forall n,m:nat. O < n \to -n \divides m \to divides_b n m = true. -intros. -cut (match (divides_b n m) with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m] \to ((divides_b n m) = true)). -apply Hcut.apply divides_b_to_Prop.assumption. -elim (divides_b n m).reflexivity. -absurd (n \divides m).assumption.assumption. -qed. - -theorem not_divides_to_divides_b_false: \forall n,m:nat. O < n \to -\lnot(n \divides m) \to (divides_b n m) = false. -intros. -cut (match (divides_b n m) with -[ true \Rightarrow n \divides m -| false \Rightarrow n \ndivides m] \to ((divides_b n m) = false)). -apply Hcut.apply divides_b_to_Prop.assumption. -elim (divides_b n m). -absurd (n \divides m).assumption.assumption. -reflexivity. -qed. - -(* divides and pi *) -theorem divides_f_pi_f : \forall f:nat \to nat.\forall n,m,i:nat. -m \le i \to i \le n+m \to f i \divides pi n f m. -intros 5.elim n.simplify. -cut (i = m).rewrite < Hcut.apply divides_n_n. -apply antisymmetric_le.assumption.assumption. -simplify. -cut (i < S n1+m \lor i = S n1 + m). -elim Hcut. -apply (transitive_divides ? (pi n1 f m)). -apply H1.apply le_S_S_to_le. assumption. -apply (witness ? ? (f (S n1+m))).apply sym_times. -rewrite > H3. -apply (witness ? ? (pi n1 f m)).reflexivity. -apply le_to_or_lt_eq.assumption. -qed. - -(* -theorem mod_S_pi: \forall f:nat \to nat.\forall n,i:nat. -i < n \to (S O) < (f i) \to (S (pi n f)) \mod (f i) = (S O). -intros.cut (pi n f) \mod (f i) = O. -rewrite < Hcut. -apply mod_S.apply trans_lt O (S O).apply le_n (S O).assumption. -rewrite > Hcut.assumption. -apply divides_to_mod_O.apply trans_lt O (S O).apply le_n (S O).assumption. -apply divides_f_pi_f.assumption. -qed. -*) - -(* divides and fact *) -theorem divides_fact : \forall n,i:nat. -O < i \to i \le n \to i \divides n!. -intros 3.elim n.absurd (O H3. -apply (witness ? ? n1!).reflexivity. -qed. - -theorem mod_S_fact: \forall n,i:nat. -(S O) < i \to i \le n \to (S n!) \mod i = (S O). -intros.cut (n! \mod i = O). -rewrite < Hcut. -apply mod_S.apply (trans_lt O (S O)).apply (le_n (S O)).assumption. -rewrite > Hcut.assumption. -apply divides_to_mod_O.apply (trans_lt O (S O)).apply (le_n (S O)).assumption. -apply divides_fact.apply (trans_lt O (S O)).apply (le_n (S O)).assumption. -assumption. -qed. - -theorem not_divides_S_fact: \forall n,i:nat. -(S O) < i \to i \le n \to i \ndivides S n!. -intros. -apply divides_b_false_to_not_divides. -apply (trans_lt O (S O)).apply (le_n (S O)).assumption. -change with ((eqb ((S n!) \mod i) O) = false). -rewrite > mod_S_fact.simplify.reflexivity. -assumption.assumption. -qed. - -(* prime *) -definition prime : nat \to Prop \def -\lambda n:nat. (S O) < n \land -(\forall m:nat. m \divides n \to (S O) < m \to m = n). - -theorem not_prime_O: \lnot (prime O). -unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_O (S O) H1). -qed. - -theorem not_prime_SO: \lnot (prime (S O)). -unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_n (S O) H1). -qed. - -(* smallest factor *) -definition smallest_factor : nat \to nat \def -\lambda n:nat. -match n with -[ O \Rightarrow O -| (S p) \Rightarrow - match p with - [ O \Rightarrow (S O) - | (S q) \Rightarrow min_aux q (S(S q)) (\lambda m.(eqb ((S(S q)) \mod m) O))]]. - -(* it works ! -theorem example1 : smallest_prime_factor (S(S(S O))) = (S(S(S O))). -normalize.reflexivity. -qed. - -theorem example2: smallest_prime_factor (S(S(S(S O)))) = (S(S O)). -normalize.reflexivity. -qed. - -theorem example3 : smallest_prime_factor (S(S(S(S(S(S(S O))))))) = (S(S(S(S(S(S(S O))))))). -simplify.reflexivity. -qed. *) - -theorem lt_SO_smallest_factor: -\forall n:nat. (S O) < n \to (S O) < (smallest_factor n). -intro. -apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S O) H). -intro.apply (nat_case m).intro. apply False_ind.apply (not_le_Sn_n (S O) H). -intros. -change with -(S O < min_aux m1 (S(S m1)) (\lambda m.(eqb ((S(S m1)) \mod m) O))). -apply (lt_to_le_to_lt ? (S (S O))). -apply (le_n (S(S O))). -cut ((S(S O)) = (S(S m1)) - m1). -rewrite > Hcut. -apply le_min_aux. -apply sym_eq.apply plus_to_minus. -rewrite < sym_plus.simplify.reflexivity. -qed. - -theorem lt_O_smallest_factor: \forall n:nat. O < n \to O < (smallest_factor n). -intro. -apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_n O H). -intro.apply (nat_case m).intro. -simplify.unfold lt.apply le_n. -intros.apply (trans_lt ? (S O)). -unfold lt.apply le_n. -apply lt_SO_smallest_factor.unfold lt. apply le_S_S. -apply le_S_S.apply le_O_n. -qed. - -theorem divides_smallest_factor_n : -\forall n:nat. O < n \to smallest_factor n \divides n. -intro. -apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O O H). -intro.apply (nat_case m).intro. simplify. -apply (witness ? ? (S O)). simplify.reflexivity. -intros. -apply divides_b_true_to_divides. -apply (lt_O_smallest_factor ? H). -change with -(eqb ((S(S m1)) \mod (min_aux m1 (S(S m1)) - (\lambda m.(eqb ((S(S m1)) \mod m) O)))) O = true). -apply f_min_aux_true. -apply (ex_intro nat ? (S(S m1))). -split.split. -apply le_minus_m.apply le_n. -rewrite > mod_n_n.reflexivity. -apply (trans_lt ? (S O)).apply (le_n (S O)).unfold lt. -apply le_S_S.apply le_S_S.apply le_O_n. -qed. - -theorem le_smallest_factor_n : -\forall n:nat. smallest_factor n \le n. -intro.apply (nat_case n).simplify.reflexivity. -intro.apply (nat_case m).simplify.reflexivity. -intro.apply divides_to_le. -unfold lt.apply le_S_S.apply le_O_n. -apply divides_smallest_factor_n. -unfold lt.apply le_S_S.apply le_O_n. -qed. - -theorem lt_smallest_factor_to_not_divides: \forall n,i:nat. -(S O) < n \to (S O) < i \to i < (smallest_factor n) \to i \ndivides n. -intros 2. -apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S O) H). -intro.apply (nat_case m).intro. apply False_ind.apply (not_le_Sn_n (S O) H). -intros. -apply divides_b_false_to_not_divides. -apply (trans_lt O (S O)).apply (le_n (S O)).assumption. -change with ((eqb ((S(S m1)) \mod i) O) = false). -apply (lt_min_aux_to_false -(\lambda i:nat.eqb ((S(S m1)) \mod i) O) (S(S m1)) m1 i). -cut ((S(S O)) = (S(S m1)-m1)). -rewrite < Hcut.exact H1. -apply sym_eq. apply plus_to_minus. -rewrite < sym_plus.simplify.reflexivity. -exact H2. -qed. - -theorem prime_smallest_factor_n : -\forall n:nat. (S O) < n \to prime (smallest_factor n). -intro. change with ((S(S O)) \le n \to (S O) < (smallest_factor n) \land -(\forall m:nat. m \divides smallest_factor n \to (S O) < m \to m = (smallest_factor n))). -intro.split. -apply lt_SO_smallest_factor.assumption. -intros. -cut (le m (smallest_factor n)). -elim (le_to_or_lt_eq m (smallest_factor n) Hcut). -absurd (m \divides n). -apply (transitive_divides m (smallest_factor n)). -assumption. -apply divides_smallest_factor_n. -apply (trans_lt ? (S O)). unfold lt. apply le_n. exact H. -apply lt_smallest_factor_to_not_divides. -exact H.assumption.assumption.assumption. -apply divides_to_le. -apply (trans_lt O (S O)). -apply (le_n (S O)). -apply lt_SO_smallest_factor. -exact H. -assumption. -qed. - -theorem prime_to_smallest_factor: \forall n. prime n \to -smallest_factor n = n. -intro.apply (nat_case n).intro.apply False_ind.apply (not_prime_O H). -intro.apply (nat_case m).intro.apply False_ind.apply (not_prime_SO H). -intro. -change with -((S O) < (S(S m1)) \land -(\forall m:nat. m \divides S(S m1) \to (S O) < m \to m = (S(S m1))) \to -smallest_factor (S(S m1)) = (S(S m1))). -intro.elim H.apply H2. -apply divides_smallest_factor_n. -apply (trans_lt ? (S O)).unfold lt. apply le_n.assumption. -apply lt_SO_smallest_factor. -assumption. -qed. - -(* a number n > O is prime iff its smallest factor is n *) -definition primeb \def \lambda n:nat. -match n with -[ O \Rightarrow false -| (S p) \Rightarrow - match p with - [ O \Rightarrow false - | (S q) \Rightarrow eqb (smallest_factor (S(S q))) (S(S q))]]. - -(* it works! -theorem example4 : primeb (S(S(S O))) = true. -normalize.reflexivity. -qed. - -theorem example5 : primeb (S(S(S(S(S(S O)))))) = false. -normalize.reflexivity. -qed. - -theorem example6 : primeb (S(S(S(S((S(S(S(S(S(S(S O)))))))))))) = true. -normalize.reflexivity. -qed. - -theorem example7 : primeb (S(S(S(S(S(S((S(S(S(S((S(S(S(S(S(S(S O))))))))))))))))))) = true. -normalize.reflexivity. -qed. *) - -theorem primeb_to_Prop: \forall n. -match primeb n with -[ true \Rightarrow prime n -| false \Rightarrow \lnot (prime n)]. -intro. -apply (nat_case n).simplify.unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_O (S O) H1). -intro.apply (nat_case m).simplify.unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_n (S O) H1). -intro. -change with -match eqb (smallest_factor (S(S m1))) (S(S m1)) with -[ true \Rightarrow prime (S(S m1)) -| false \Rightarrow \lnot (prime (S(S m1)))]. -apply (eqb_elim (smallest_factor (S(S m1))) (S(S m1))). -intro.change with (prime (S(S m1))). -rewrite < H. -apply prime_smallest_factor_n. -unfold lt.apply le_S_S.apply le_S_S.apply le_O_n. -intro.change with (\lnot (prime (S(S m1)))). -change with (prime (S(S m1)) \to False). -intro.apply H. -apply prime_to_smallest_factor. -assumption. -qed. - -theorem primeb_true_to_prime : \forall n:nat. -primeb n = true \to prime n. -intros.change with -match true with -[ true \Rightarrow prime n -| false \Rightarrow \lnot (prime n)]. -rewrite < H. -apply primeb_to_Prop. -qed. - -theorem primeb_false_to_not_prime : \forall n:nat. -primeb n = false \to \lnot (prime n). -intros.change with -match false with -[ true \Rightarrow prime n -| false \Rightarrow \lnot (prime n)]. -rewrite < H. -apply primeb_to_Prop. -qed. - -theorem decidable_prime : \forall n:nat.decidable (prime n). -intro.change with ((prime n) \lor \lnot (prime n)). -cut -(match primeb n with -[ true \Rightarrow prime n -| false \Rightarrow \lnot (prime n)] \to (prime n) \lor \lnot (prime n)). -apply Hcut.apply primeb_to_Prop. -elim (primeb n).left.apply H.right.apply H. -qed. - -theorem prime_to_primeb_true: \forall n:nat. -prime n \to primeb n = true. -intros. -cut (match (primeb n) with -[ true \Rightarrow prime n -| false \Rightarrow \lnot (prime n)] \to ((primeb n) = true)). -apply Hcut.apply primeb_to_Prop. -elim (primeb n).reflexivity. -absurd (prime n).assumption.assumption. -qed. - -theorem not_prime_to_primeb_false: \forall n:nat. -\lnot(prime n) \to primeb n = false. -intros. -cut (match (primeb n) with -[ true \Rightarrow prime n -| false \Rightarrow \lnot (prime n)] \to ((primeb n) = false)). -apply Hcut.apply primeb_to_Prop. -elim (primeb n). -absurd (prime n).assumption.assumption. -reflexivity. -qed. - diff --git a/helm/matita/library/nat/primes1.ma b/helm/matita/library/nat/primes1.ma deleted file mode 100644 index 3ec61ee4a..000000000 --- a/helm/matita/library/nat/primes1.ma +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/primes1". - -include "datatypes/constructors.ma". -include "nat/primes.ma". - -(* p is just an upper bound, acc is an accumulator *) -let rec n_divides_aux p n m acc \def - match n \mod m with - [ O \Rightarrow - match p with - [ O \Rightarrow pair nat nat acc n - | (S p) \Rightarrow n_divides_aux p (n / m) m (S acc)] - | (S a) \Rightarrow pair nat nat acc n]. - -(* n_divides n m = if m divides n q times, with remainder r *) -definition n_divides \def \lambda n,m:nat.n_divides_aux n n m O. - -(* -theorem n_divides_to_Prop: \forall n,m,p,a. - match n_divides_aux p n m a with - [ (pair q r) \Rightarrow n = m \sup a *r]. -intros. -apply nat_case (n \mod m). *) - diff --git a/helm/matita/library/nat/relevant_equations.ma b/helm/matita/library/nat/relevant_equations.ma deleted file mode 100644 index f4cf43775..000000000 --- a/helm/matita/library/nat/relevant_equations.ma +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* __ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/relevant_equations.ma". - -include "nat/times.ma". -include "nat/minus.ma". - -theorem times_plus_l: \forall n,m,p:nat. (n+m)*p = n*p + m*p. -intros. -apply (trans_eq ? ? (p*(n+m))). -apply sym_times. -apply (trans_eq ? ? (p*n+p*m)). -apply distr_times_plus. -apply eq_f2. -apply sym_times. -apply sym_times. -qed. - -theorem times_minus_l: \forall n,m,p:nat. (n-m)*p = n*p - m*p. -intros. -apply (trans_eq ? ? (p*(n-m))). -apply sym_times. -apply (trans_eq ? ? (p*n-p*m)). -apply distr_times_minus. -apply eq_f2. -apply sym_times. -apply sym_times. -qed. - -theorem times_plus_plus: \forall n,m,p,q:nat. (n + m)*(p + q) = -n*p + n*q + m*p + m*q. -intros. -apply (trans_eq nat ? ((n*(p+q) + m*(p+q)))). -apply times_plus_l. -rewrite > distr_times_plus. -rewrite > distr_times_plus. -rewrite < assoc_plus.reflexivity. -qed. diff --git a/helm/matita/library/nat/sigma_and_pi.ma b/helm/matita/library/nat/sigma_and_pi.ma deleted file mode 100644 index 4f5f6cba0..000000000 --- a/helm/matita/library/nat/sigma_and_pi.ma +++ /dev/null @@ -1,79 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / Matita is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/sigma_and_pi". - -include "nat/factorial.ma". -include "nat/lt_arith.ma". -include "nat/exp.ma". - -let rec sigma n f m \def - match n with - [ O \Rightarrow (f m) - | (S p) \Rightarrow (f (S p+m))+(sigma p f m)]. - -let rec pi n f m \def - match n with - [ O \Rightarrow f m - | (S p) \Rightarrow (f (S p+m))*(pi p f m)]. - -theorem eq_sigma: \forall f,g:nat \to nat. -\forall n,m:nat. -(\forall i:nat. m \le i \to i \le m+n \to f i = g i) \to -(sigma n f m) = (sigma n g m). -intros 3.elim n. -simplify.apply H.apply le_n.rewrite < plus_n_O.apply le_n. -simplify. -apply eq_f2.apply H1. -change with (m \le (S n1)+m).apply le_plus_n. -rewrite > (sym_plus m).apply le_n. -apply H.intros.apply H1.assumption. -rewrite < plus_n_Sm. -apply le_S.assumption. -qed. - -theorem eq_pi: \forall f,g:nat \to nat. -\forall n,m:nat. -(\forall i:nat. m \le i \to i \le m+n \to f i = g i) \to -(pi n f m) = (pi n g m). -intros 3.elim n. -simplify.apply H.apply le_n.rewrite < plus_n_O.apply le_n. -simplify. -apply eq_f2.apply H1. -change with (m \le (S n1)+m).apply le_plus_n. -rewrite > (sym_plus m).apply le_n. -apply H.intros.apply H1.assumption. -rewrite < plus_n_Sm. -apply le_S.assumption. -qed. - -theorem eq_fact_pi: \forall n. (S n)! = pi n (\lambda m.m) (S O). -intro.elim n. -simplify.reflexivity. -change with ((S(S n1))*(S n1)! = ((S n1)+(S O))*(pi n1 (\lambda m.m) (S O))). -rewrite < plus_n_Sm.rewrite < plus_n_O. -apply eq_f.assumption. -qed. - -theorem exp_pi_l: \forall f:nat\to nat.\forall n,m,a:nat. -(exp a (S n))*pi n f m= pi n (\lambda p.a*(f p)) m. -intros.elim n.simplify.rewrite < times_n_SO.reflexivity. -simplify. -rewrite < H. -rewrite > assoc_times. -rewrite > assoc_times in\vdash (? ? ? %). -apply eq_f.rewrite < assoc_times. -rewrite < assoc_times. -apply eq_f2.apply sym_times.reflexivity. -qed. diff --git a/helm/matita/library/nat/times.ma b/helm/matita/library/nat/times.ma deleted file mode 100644 index 2ae5ffd74..000000000 --- a/helm/matita/library/nat/times.ma +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* __ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/times". - -include "nat/plus.ma". - -let rec times n m \def - match n with - [ O \Rightarrow O - | (S p) \Rightarrow m+(times p m) ]. - -(*CSC: the URI must disappear: there is a bug now *) -interpretation "natural times" 'times x y = (cic:/matita/nat/times/times.con x y). - -theorem times_n_O: \forall n:nat. O = n*O. -intros.elim n. -simplify.reflexivity. -simplify.assumption. -qed. - -theorem times_n_Sm : -\forall n,m:nat. n+(n*m) = n*(S m). -intros.elim n. -simplify.reflexivity. -simplify.apply eq_f.rewrite < H. -transitivity ((n1+m)+n1*m).symmetry.apply assoc_plus. -transitivity ((m+n1)+n1*m). -apply eq_f2. -apply sym_plus. -reflexivity. -apply assoc_plus. -qed. - -theorem times_n_SO : \forall n:nat. n = n * S O. -intros. -rewrite < times_n_Sm. -rewrite < times_n_O. -rewrite < plus_n_O. -reflexivity. -qed. - -theorem symmetric_times : symmetric nat times. -unfold symmetric. -intros.elim x. -simplify.apply times_n_O. -simplify.rewrite > H.apply times_n_Sm. -qed. - -variant sym_times : \forall n,m:nat. n*m = m*n \def -symmetric_times. - -theorem distributive_times_plus : distributive nat times plus. -unfold distributive. -intros.elim x. -simplify.reflexivity. -simplify.rewrite > H. rewrite > assoc_plus.rewrite > assoc_plus. -apply eq_f.rewrite < assoc_plus. rewrite < (sym_plus ? z). -rewrite > assoc_plus.reflexivity. -qed. - -variant distr_times_plus: \forall n,m,p:nat. n*(m+p) = n*m + n*p -\def distributive_times_plus. - -theorem associative_times: associative nat times. -unfold associative.intros. -elim x.simplify.apply refl_eq. -simplify.rewrite < sym_times. -rewrite > distr_times_plus. -rewrite < sym_times. -rewrite < (sym_times (times n y) z). -rewrite < H.apply refl_eq. -qed. - -variant assoc_times: \forall n,m,p:nat. (n*m)*p = n*(m*p) \def -associative_times. diff --git a/helm/matita/library/nat/totient.ma b/helm/matita/library/nat/totient.ma deleted file mode 100644 index 24c3920ed..000000000 --- a/helm/matita/library/nat/totient.ma +++ /dev/null @@ -1,102 +0,0 @@ -(**************************************************************************) -(* __ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| A.Asperti, C.Sacerdoti Coen, *) -(* ||A|| E.Tassi, S.Zacchiroli *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU Lesser General Public License Version 2.1 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/nat/totient". - -include "nat/count.ma". -include "nat/chinese_reminder.ma". - -definition totient : nat \to nat \def -\lambda n. count n (\lambda m. eqb (gcd m n) (S O)). - -theorem totient3: totient (S(S(S O))) = (S(S O)). -reflexivity. -qed. - -theorem totient6: totient (S(S(S(S(S(S O)))))) = (S(S O)). -reflexivity. -qed. - -theorem totient_times: \forall n,m:nat. (gcd m n) = (S O) \to -totient (n*m) = (totient n)*(totient m). -intro. -apply (nat_case n). -intro.simplify.intro.reflexivity. -intros 2.apply (nat_case m1). -rewrite < sym_times. -rewrite < (sym_times (totient O)). -simplify.intro.reflexivity. -intros. -unfold totient. -apply (count_times m m2 ? ? ? -(\lambda b,a. cr_pair (S m) (S m2) a b) (\lambda x. x \mod (S m)) (\lambda x. x \mod (S m2))). -intros.unfold cr_pair. -apply (le_to_lt_to_lt ? (pred ((S m)*(S m2)))). -unfold min. -apply le_min_aux_r. -change with ((S (pred ((S m)*(S m2)))) \le ((S m)*(S m2))). -apply (nat_case ((S m)*(S m2))).apply le_n. -intro.apply le_n. -intros. -generalize in match (mod_cr_pair (S m) (S m2) a b H1 H2 H). -intro.elim H3. -apply H4. -intros. -generalize in match (mod_cr_pair (S m) (S m2) a b H1 H2 H). -intro.elim H3. -apply H5. -intros. -generalize in match (mod_cr_pair (S m) (S m2) a b H1 H2 H). -intro.elim H3. -apply eqb_elim. -intro. -rewrite > eq_to_eqb_true. -rewrite > eq_to_eqb_true. -reflexivity. -rewrite < H4. -rewrite > sym_gcd. -rewrite > gcd_mod. -apply (gcd_times_SO_to_gcd_SO ? ? (S m2)). -unfold lt.apply le_S_S.apply le_O_n. -unfold lt.apply le_S_S.apply le_O_n. -assumption. -unfold lt.apply le_S_S.apply le_O_n. -rewrite < H5. -rewrite > sym_gcd. -rewrite > gcd_mod. -apply (gcd_times_SO_to_gcd_SO ? ? (S m)). -unfold lt.apply le_S_S.apply le_O_n. -unfold lt.apply le_S_S.apply le_O_n. -rewrite > sym_times. -assumption. -unfold lt.apply le_S_S.apply le_O_n. -intro. -apply eqb_elim. -intro.apply eqb_elim. -intro.apply False_ind. -apply H6. -apply eq_gcd_times_SO. -unfold lt.apply le_S_S.apply le_O_n. -unfold lt.apply le_S_S.apply le_O_n. -rewrite < gcd_mod. -rewrite > H4. -rewrite > sym_gcd.assumption. -unfold lt.apply le_S_S.apply le_O_n. -rewrite < gcd_mod. -rewrite > H5. -rewrite > sym_gcd.assumption. -unfold lt.apply le_S_S.apply le_O_n. -intro.reflexivity. -intro.reflexivity. -qed. \ No newline at end of file diff --git a/helm/matita/matita.conf.xml b/helm/matita/matita.conf.xml deleted file mode 120000 index 7f7b7b8e1..000000000 --- a/helm/matita/matita.conf.xml +++ /dev/null @@ -1 +0,0 @@ -matita.conf.xml.devel \ No newline at end of file diff --git a/helm/matita/matita.conf.xml.build.in b/helm/matita/matita.conf.xml.build.in deleted file mode 100644 index 0ee624540..000000000 --- a/helm/matita/matita.conf.xml.build.in +++ /dev/null @@ -1,27 +0,0 @@ - - -

- $(HOME) -
-
- .matita - nobody -
-
- @DBHOST@ - helm - matita -
-
- .matita/getter/cache - - cic:/matita/ - file://.matita/xml/matita/ - - - cic:/ - file:///does_not_exists/ - legacy - -
- diff --git a/helm/matita/matita.conf.xml.devel.in b/helm/matita/matita.conf.xml.devel.in deleted file mode 100644 index 3a4e7bb70..000000000 --- a/helm/matita/matita.conf.xml.devel.in +++ /dev/null @@ -1,68 +0,0 @@ - - -
- - $(HOME) - - -
-
- - - - - $(user.home)/.matita - - $(user.name) - - -
-
- - @DBHOST@ - helm - matita -
-
- - $(user.home)/.matita/getter/cache - - - cic:/matita/ - file://$(user.home)/.matita/xml/matita/ - - - cic:/ - file:///projects/helm/library/coq_contribs/ - legacy - -
- diff --git a/helm/matita/matita.conf.xml.user.in b/helm/matita/matita.conf.xml.user.in deleted file mode 100644 index ff4be401e..000000000 --- a/helm/matita/matita.conf.xml.user.in +++ /dev/null @@ -1,73 +0,0 @@ - - -
- - $(HOME) - - -
-
- - - - - $(user.home)/.matita - - $(user.name) - - -
-
- - @DBHOST@ - helm - matita -
-
- - $(user.home)/.matita/getter/cache - - - cic:/matita/ - file://@RT_BASE_DIR@/library/ - ro - - - cic:/matita/$(user.name)/ - file://$(user.home)/.matita/xml/matita/ - - - cic:/ - file://@RT_BASE_DIR@/legacy/coq/ - legacy - -
- diff --git a/helm/matita/matita.glade b/helm/matita/matita.glade deleted file mode 100644 index 436dd7b26..000000000 --- a/helm/matita/matita.glade +++ /dev/null @@ -1,3952 +0,0 @@ - - - - - - - True - Cic browser - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_CENTER_ON_PARENT - False - 500 - 500 - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_NORMAL - GDK_GRAVITY_NORTH_WEST - True - - - - True - True - False - - - - True - False - 0 - - - - True - 0 - 0 - GTK_SHADOW_NONE - - - - True - False - 0 - - - - True - True - GTK_RELIEF_NONE - True - - - - True - gtk-new - 4 - 0.5 - 0.5 - 0 - 0 - - - - - 0 - False - False - - - - - - True - True - GTK_RELIEF_NONE - True - - - - True - gtk-go-back - 4 - 0.5 - 0.5 - 0 - 0 - - - - - 0 - False - False - - - - - - True - True - GTK_RELIEF_NONE - True - - - - True - gtk-go-forward - 4 - 0.5 - 0.5 - 0 - 0 - - - - - 0 - False - False - - - - - - True - refresh - True - True - GTK_RELIEF_NONE - True - - - - True - gtk-refresh - 4 - 0.5 - 0.5 - 0 - 0 - - - - - 0 - False - False - - - - - - True - home - True - True - GTK_RELIEF_NONE - True - - - - True - gtk-home - 4 - 0.5 - 0.5 - 0 - 0 - - - - - 0 - False - False - - - - - - True - gtk-jump-to - 2 - 0.5 - 0.5 - 0 - 0 - - - 3 - False - False - - - - - - True - False - 0 - - - - - - - 0 - True - True - - - - - - - 0 - False - True - - - - - - 3 - True - False - 6 - - - - True - 0.5 - 0.5 - 0 - 0 - - - 0 - False - True - - - - - - True - True - True - True - 0 - - True - * - False - - - 0 - True - True - - - - - - True - False - 0 - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - False - False - - - - - 0 - False - True - - - - - 0 - False - True - - - - - - True - True - True - True - GTK_POS_TOP - False - False - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_NONE - GTK_CORNER_TOP_LEFT - - - - - - - False - True - - - - - - True - MathView - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - False - False - False - True - False - False - False - - - - - False - True - - - - - - True - WhelpResults - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - - True - 0.5 - 0.5 - 0 - 0 - - - False - True - - - - - - True - WhelpEasterEgg - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - 0 - True - True - - - - - - - - - - DUMMY - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_CENTER - True - False - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - True - - - - True - False - 0 - - - - True - GTK_BUTTONBOX_END - - - - True - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - -6 - - - - - - True - True - True - gtk-ok - True - GTK_RELIEF_NORMAL - True - -5 - - - - - 0 - False - True - GTK_PACK_END - - - - - - True - DUMMY - False - False - GTK_JUSTIFY_CENTER - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - True - DUMMY - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - False - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - True - - - - True - False - 0 - - - - True - GTK_BUTTONBOX_END - - - - True - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - -6 - - - - - - True - True - True - gtk-ok - True - GTK_RELIEF_NORMAL - True - -5 - - - - - 0 - False - True - GTK_PACK_END - - - - - - True - DUMMY - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - - - - - 10 - Select File - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_CENTER - True - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - True - - - - True - True - True - GTK_RELIEF_NORMAL - True - - - - - - True - True - True - GTK_RELIEF_NORMAL - True - - - - - - 350 - 250 - title - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - True - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - True - - - - True - False - 0 - - - - True - GTK_BUTTONBOX_END - - - - True - True - True - gtk-help - True - GTK_RELIEF_NORMAL - True - -11 - - - - - - True - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - -6 - - - - - - True - True - True - gtk-ok - True - GTK_RELIEF_NORMAL - True - -5 - - - - - 0 - False - True - GTK_PACK_END - - - - - - True - False - 0 - - - - True - some informative message here ... - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - False - False - False - True - False - False - False - - - - - 0 - True - True - - - - - 0 - True - True - - - - - - - - Matita - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - False - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_NORMAL - GDK_GRAVITY_NORTH_WEST - True - - - - True - True - False - - - - True - False - 0 - - - - True - GTK_SHADOW_OUT - GTK_POS_LEFT - GTK_POS_TOP - - - - True - - - - True - _File - True - - - - - - - True - _New - True - - - - - True - gtk-new - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - _Open... - True - - - - - True - gtk-open - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - _Save - True - - - - - True - gtk-save - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - Save _As ... - True - - - - - True - gtk-save-as - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - _Developments... - True - - - - - True - gtk-execute - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - - - - - - True - _Quit - True - - - - - True - gtk-quit - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - - - - - True - _Edit - True - - - - - - - True - False - _Undo - True - - - - - True - gtk-undo - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - False - _Redo - True - - - - - True - gtk-redo - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - - - - - - True - Cu_t - True - - - - - True - gtk-cut - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - _Copy - True - - - - - True - gtk-copy - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - _Paste - True - - - - - True - gtk-paste - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - Paste as pattern - True - - - - - - True - _Delete - True - - - - True - gtk-delete - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - - - - - - True - Select _All - True - - - - - - True - - - - - - True - _Find & Replace ... - True - - - - - True - gtk-find-and-replace - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - - - - - - True - Next ligature - True - - - - - - - True - Edit with E_xternal Editor - True - - - - - - - - - - True - _Script - True - - - - - - - True - Execute 1 phrase - True - - - - - - - True - Retract 1 phrase - True - - - - - - - True - - - - - - True - Execute all - True - - - - - - - True - Restart - True - - - - - - - True - - - - - - True - Execute until cursor - True - - - - - - - - - - - True - _View - True - - - - - - - True - Show _Tactics Bar - True - True - - - - - - - True - New Cic _Browser - True - - - - - - - True - - - - - - True - _Fullscreen - True - False - - - - - - - True - - - - - - True - Zoom _In - True - - - - - - True - gtk-zoom-in - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - Zoom _Out - True - - - - - - True - gtk-zoom-out - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - True - _Normal Size - True - - - - - True - gtk-zoom-100 - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - - - - - True - _Debug - True - - - - - - - True - - - - - - - - - - True - _Help - True - - - - - - - True - _About - True - - - - True - gtk-about - 1 - 0.5 - 0.5 - 0 - 0 - - - - - - - - - - - - - 0 - False - False - - - - - - True - False - 0 - - - - True - True - - - - True - False - 0 - - - - True - GTK_SHADOW_OUT - GTK_POS_TOP - GTK_POS_TOP - - - - True - 17 - 2 - False - 4 - 0 - - - - True - Apply - True - apply - True - GTK_RELIEF_NORMAL - True - - - 1 - 2 - 0 - 1 - fill - - - - - - - True - Intros - True - intro - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 0 - 1 - fill - - - - - - - True - Exact - True - exact - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 2 - 3 - fill - - - - - - - True - Elim - True - elim - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 4 - 5 - fill - - - - - - - True - Reflexivity - True - refl - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 8 - 9 - fill - - - - - - - True - Symmetry - True - sym - True - GTK_RELIEF_NORMAL - True - - - 1 - 2 - 8 - 9 - fill - - - - - - - True - Transitivity - True - trans - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 9 - 10 - fill - - - - - - - True - Simplify - True - simpl - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 11 - 12 - fill - - - - - - - True - Reduce - True - red - True - GTK_RELIEF_NORMAL - True - - - 1 - 2 - 11 - 12 - fill - - - - - - - True - Whd - True - whd - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 12 - 13 - fill - - - - - - - True - Assumption - True - assum - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 14 - 15 - fill - - - - - - - True - Auto - True - auto - True - GTK_RELIEF_NORMAL - True - - - 1 - 2 - 14 - 15 - fill - - - - - - - True - Cut - True - cut - True - GTK_RELIEF_NORMAL - True - - - 0 - 1 - 16 - 17 - fill - - - - - - - True - Replace - True - repl - True - GTK_RELIEF_NORMAL - True - - - 1 - 2 - 16 - 17 - fill - - - - - - - True - ElimType - True - elimTy - True - GTK_RELIEF_NORMAL - True - - - 1 - 2 - 4 - 5 - fill - - - - - - - True - True - 0 - - - - True - Right - True - R - True - GTK_RELIEF_NORMAL - True - - - 0 - True - True - - - - - - True - Exists - True - ∃ - True - GTK_RELIEF_NORMAL - True - - - 0 - True - True - - - - - 1 - 2 - 6 - 7 - fill - fill - - - - - - True - True - 0 - - - - True - Split - True - ∧ - True - GTK_RELIEF_NORMAL - True - - - 0 - True - True - - - - - - True - Left - True - L - True - GTK_RELIEF_NORMAL - True - - - 0 - True - True - - - - - 0 - 1 - 6 - 7 - fill - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 1 - 2 - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 3 - 4 - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 5 - 6 - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 7 - 8 - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 10 - 11 - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 13 - 14 - fill - - - - - - True - 0.5 - 0.5 - 1 - 1 - 0 - 0 - 0 - 0 - - - - - - - 0 - 1 - 15 - 16 - fill - - - - - - - 0 - False - True - - - - - - 400 - True - False - 0 - - - - True - GTK_ORIENTATION_HORIZONTAL - GTK_TOOLBAR_BOTH - True - True - - - - True - True - True - False - - - - True - Restart - True - GTK_RELIEF_NONE - True - - - - True - gtk-goto-top - 4 - 0.5 - 0.5 - 0 - 0 - - - - - - - False - False - - - - - - True - True - True - False - - - - True - Retract 1 phrase - True - GTK_RELIEF_NONE - True - - - - True - gtk-go-up - 4 - 0.5 - 0.5 - 0 - 0 - - - - - - - False - False - - - - - - True - True - True - False - - - - True - Execute until point - True - GTK_RELIEF_NONE - True - - - - True - gtk-jump-to - 4 - 0.5 - 0.5 - 0 - 0 - - - - - - - False - False - - - - - - True - True - True - False - - - - True - Execute 1 phrase - True - GTK_RELIEF_NONE - True - - - - True - gtk-go-down - 4 - 0.5 - 0.5 - 0 - 0 - - - - - - - False - False - - - - - - True - True - True - False - - - - True - Execute all - True - GTK_RELIEF_NONE - True - - - - True - gtk-goto-bottom - 4 - 0.5 - 0.5 - 0 - 0 - - - - - - - False - False - - - - - 0 - False - False - - - - - - True - True - True - True - GTK_POS_BOTTOM - False - False - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_NONE - GTK_CORNER_TOP_LEFT - - - - - - - False - True - - - - - - True - script - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_NONE - GTK_CORNER_TOP_LEFT - - - - True - True - False - False - False - True - False - False - False - - - - - False - True - - - - - - True - outline - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - 0 - True - True - - - - - 0 - True - True - - - - - True - False - - - - - - 250 - 500 - True - True - 380 - - - - True - True - True - True - GTK_POS_TOP - False - False - - - True - False - - - - - - True - False - 0 - - - - True - True - GTK_POLICY_NEVER - GTK_POLICY_ALWAYS - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - False - False - True - GTK_JUSTIFY_LEFT - GTK_WRAP_CHAR - False - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - 0 - True - True - - - - - True - True - - - - - True - True - - - - - 0 - True - True - - - - - 0 - True - True - - - - - - True - False - 0 - - - - True - False - - - 0 - True - True - - - - - - True - False - True - GTK_POS_TOP - False - False - - - - True - 0.5 - 0.5 - 0 - 0 - - - False - True - - - - - - True - label14 - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - - True - 0.5 - 0.5 - 0 - 0 - - - False - True - - - - - - True - label15 - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - - True - 0.5 - 0.5 - 0 - 0 - - - False - True - - - - - - True - label16 - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - tab - - - - - 0 - False - True - - - - - 0 - False - False - - - - - - - - - - DUMMY - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - False - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - True - - - - True - False - 0 - - - - True - GTK_BUTTONBOX_END - - - - True - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - -6 - - - - - - True - True - True - gtk-ok - True - GTK_RELIEF_NORMAL - True - -5 - - - - - 0 - False - True - GTK_PACK_END - - - - - - True - DUMMY - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - True - False - True - GTK_JUSTIFY_LEFT - GTK_WRAP_NONE - True - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - 0 - True - True - - - - - - - - 280 - Uri choice - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_CENTER - True - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - True - - - - True - False - 4 - - - - True - GTK_BUTTONBOX_END - - - - True - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - -6 - - - - - - True - True - True - GTK_RELIEF_NORMAL - True - 0 - - - - True - 0.5 - 0.5 - 0 - 0 - 0 - 0 - 0 - 0 - - - - True - False - 2 - - - - True - gtk-index - 4 - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - Try _Selected - True - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - - - - - True - False - True - True - Try Constants - True - GTK_RELIEF_NORMAL - True - 0 - - - - - - True - True - gtk-copy - True - GTK_RELIEF_NORMAL - True - 0 - - - - - - True - True - True - GTK_RELIEF_NORMAL - True - 0 - - - - True - 0.5 - 0.5 - 0 - 0 - 0 - 0 - 0 - 0 - - - - True - False - 2 - - - - True - gtk-ok - 4 - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - bla bla bla - True - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - - - - 0 - False - True - GTK_PACK_END - - - - - - True - False - 3 - - - - True - some informative message here ... - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - 400 - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_NONE - GTK_CORNER_TOP_LEFT - - - - True - True - False - False - False - True - False - False - False - - - - - 0 - True - True - - - - - - True - False - 0 - - - - True - URI: - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - True - True - True - True - 0 - - True - * - False - - - 0 - True - True - - - - - 0 - False - True - - - - - 0 - True - True - - - - - - - - 5 - Find & Replace - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_MOUSE - False - False - False - True - False - False - GDK_WINDOW_TYPE_HINT_DIALOG - GDK_GRAVITY_NORTH_WEST - True - - - - True - 3 - 2 - False - 5 - 0 - - - - True - Find: - False - False - GTK_JUSTIFY_LEFT - False - False - 0 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - 1 - 0 - 1 - fill - - - - - - - True - Replace with: - False - False - GTK_JUSTIFY_LEFT - False - False - 0 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - 1 - 1 - 2 - fill - - - - - - - True - True - True - True - True - True - True - 0 - - True - * - False - - - 1 - 2 - 0 - 1 - - - - - - - True - True - True - True - 0 - - True - * - False - - - 1 - 2 - 1 - 2 - - - - - - - True - False - 5 - - - - True - False - 0 - - - - - - - - - - - 0 - True - True - - - - - - True - True - gtk-find - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - - True - True - GTK_RELIEF_NORMAL - True - - - - True - 0.5 - 0.5 - 0 - 0 - 0 - 0 - 0 - 0 - - - - True - False - 2 - - - - True - gtk-find-and-replace - 4 - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - _Replace - True - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - - 0 - False - False - - - - - - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - 0 - 2 - 2 - 3 - 5 - - - - - - - - Create development - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_CENTER_ALWAYS - True - False - False - True - False - False - GDK_WINDOW_TYPE_HINT_UTILITY - GDK_GRAVITY_NORTH_WEST - True - - - - True - False - 0 - - - - 3 - True - 2 - 3 - False - 5 - 5 - - - - True - Name - False - False - GTK_JUSTIFY_LEFT - False - False - 0 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - 1 - 0 - 1 - fill - - - - - - - True - Root directory - False - False - GTK_JUSTIFY_LEFT - False - False - 0 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - 1 - 1 - 2 - fill - - - - - - - True - True - True - True - 0 - - True - * - False - - - 1 - 2 - 0 - 1 - - - - - - - True - True - True - True - 0 - - True - * - False - - - 1 - 2 - 1 - 2 - - - - - - - True - True - ... - True - GTK_RELIEF_NORMAL - True - - - 2 - 3 - 1 - 2 - fill - - - - - - 0 - False - True - - - - - - True - - - 2 - False - True - - - - - - 3 - True - False - 5 - - - - True - False - 0 - - - - - - - - - - - 0 - True - True - - - - - - True - True - gtk-add - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - - True - True - gtk-cancel - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - 0 - False - True - - - - - - - - Developments - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_CENTER - False - True - False - True - False - False - GDK_WINDOW_TYPE_HINT_NORMAL - GDK_GRAVITY_NORTH_WEST - True - - - - True - False - 0 - - - - True - True - GTK_POLICY_AUTOMATIC - GTK_POLICY_AUTOMATIC - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - False - False - False - True - False - False - False - - - - - 0 - True - True - - - - - - True - - - 2 - False - True - - - - - - 3 - True - False - 4 - - - - True - False - 0 - - - - - - - - - - - 0 - True - True - - - - - - True - True - gtk-new - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - - True - True - gtk-delete - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - - True - True - GTK_RELIEF_NORMAL - True - - - - True - 0.5 - 0.5 - 0 - 0 - 0 - 0 - 0 - 0 - - - - True - False - 2 - - - - True - gtk-execute - 4 - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - _Build - True - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - - 0 - False - False - - - - - - True - True - GTK_RELIEF_NORMAL - True - - - - True - 0.5 - 0.5 - 0 - 0 - 0 - 0 - 0 - 0 - - - - True - False - 2 - - - - True - gtk-clear - 4 - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - C_lean - True - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - PANGO_ELLIPSIZE_NONE - -1 - False - 0 - - - 0 - False - False - - - - - - - - - 0 - False - False - - - - - - True - True - gtk-close - True - GTK_RELIEF_NORMAL - True - - - 0 - False - False - - - - - 0 - False - True - - - - - - - diff --git a/helm/matita/matita.gtkrc b/helm/matita/matita.gtkrc deleted file mode 100644 index 91081c311..000000000 --- a/helm/matita/matita.gtkrc +++ /dev/null @@ -1,80 +0,0 @@ -# Based on /usr/share/themes/Emacs/gtk-2.0-key/, -# modified by Zack for matita - -# -# A keybinding set implementing emacs-like keybindings -# - -# -# Bindings for GtkTextView and GtkEntry -# -binding "gtk-emacs-text-entry" -{ - bind "b" { "move-cursor" (logical-positions, -1, 0) } - bind "b" { "move-cursor" (logical-positions, -1, 1) } - bind "f" { "move-cursor" (logical-positions, 1, 0) } - bind "f" { "move-cursor" (logical-positions, 1, 1) } - - bind "b" { "move-cursor" (words, -1, 0) } - bind "b" { "move-cursor" (words, -1, 1) } - bind "f" { "move-cursor" (words, 1, 0) } - bind "f" { "move-cursor" (words, 1, 1) } - - bind "a" { "move-cursor" (paragraph-ends, -1, 0) } - bind "a" { "move-cursor" (paragraph-ends, -1, 1) } - bind "e" { "move-cursor" (paragraph-ends, 1, 0) } - bind "e" { "move-cursor" (paragraph-ends, 1, 1) } - - bind "w" { "cut-clipboard" () } - bind "y" { "paste-clipboard" () } - - bind "d" { "delete-from-cursor" (chars, 1) } - bind "d" { "delete-from-cursor" (word-ends, 1) } - bind "k" { "delete-from-cursor" (paragraph-ends, 1) } - bind "backslash" { "delete-from-cursor" (whitespace, 1) } - - bind "space" { "delete-from-cursor" (whitespace, 1) - "insert-at-cursor" (" ") } - bind "KP_Space" { "delete-from-cursor" (whitespace, 1) - "insert-at-cursor" (" ") } - - # - # Some non-Emacs keybindings people are attached to - # - bind "u" { - "move-cursor" (paragraph-ends, -1, 0) - "delete-from-cursor" (paragraph-ends, 1) - } - bind "h" { "delete-from-cursor" (chars, -1) } - bind "w" { "delete-from-cursor" (word-ends, -1) } -} - -# -# Bindings for GtkTextView -# -binding "gtk-emacs-text-view" -{ -# bind "p" { "move-cursor" (display-lines, -1, 0) } - bind "p" { "move-cursor" (display-lines, -1, 1) } -# bind "n" { "move-cursor" (display-lines, 1, 0) } - bind "n" { "move-cursor" (display-lines, 1, 1) } - - bind "space" { "set-anchor" () } - bind "KP_Space" { "set-anchor" () } -} - -# -# Bindings for GtkTreeView -# -binding "gtk-emacs-tree-view" -{ - bind "s" { "start-interactive-search" () } - bind "f" { "move-cursor" (logical-positions, 1) } - bind "b" { "move-cursor" (logical-positions, -1) } -} - -class "GtkEntry" binding "gtk-emacs-text-entry" -class "GtkTextView" binding "gtk-emacs-text-entry" -class "GtkTextView" binding "gtk-emacs-text-view" -class "GtkTreeView" binding "gtk-emacs-tree-view" - diff --git a/helm/matita/matita.lang b/helm/matita/matita.lang deleted file mode 100644 index 0c181ee44..000000000 --- a/helm/matita/matita.lang +++ /dev/null @@ -1,186 +0,0 @@ - - - - - \ - - - \(\* - \*\) - - - - \(\*\* - \*\*\) - - - - theorem - definition - lemma - fact - remark - variant - - - - alias - and - as - coercion - coinductive - corec - default - for - include - inductive - in - interpretation - let - match - names - notation - on - qed - rec - record - return - to - using - with - - - - \[ - - - \| - - - \] - - - \{ - - - \} - - - @ - - - \$ - - - - Set - Prop - Type - - - - absurd - apply - assumption - auto - paramodulation - clear - clearbody - change - compare - constructor - contradiction - cut - decide equality - decompose - discriminate - elim - elimType - exact - exists - fail - fold - fourier - fwd - generalize - goal - id - injection - intro - intros - lapply - left - letin - normalize - reduce - reflexivity - replace - rewrite - ring - right - symmetry - simplify - split - to - transitivity - unfold - whd - - - - try - solve - do - repeat - first - - - - - print - check - hint - quit - set - - - - elim - hint - instance - locate - match - - - - def - forall - lambda - to - exists - Rightarrow - Assign - land - lor - lnot - liff - subst - vdash - iforall - iexists - - - - " - " - - - diff --git a/helm/matita/matita.ma.templ b/helm/matita/matita.ma.templ deleted file mode 100644 index ec1bc8006..000000000 --- a/helm/matita/matita.ma.templ +++ /dev/null @@ -1,16 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/test/". - diff --git a/helm/matita/matita.ml b/helm/matita/matita.ml deleted file mode 100644 index 07f7f900a..000000000 --- a/helm/matita/matita.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open MatitaGtkMisc -open GrafiteTypes - -(** {2 Initialization} *) - -let _ = MatitaInit.initialize_all () -(* let _ = Saturation.init () (* ALB to link paramodulation *) *) - -(** {2 GUI callbacks} *) - -let gui = MatitaGui.instance () - -let script = - let s = - MatitaScript.script - ~source_view:gui#sourceView - ~mathviewer:(MatitaMathView.mathViewer ()) - ~urichooser:(fun uris -> - try - MatitaGui.interactive_uri_choice ~selection_mode:`SINGLE - ~title:"Matita: URI chooser" - ~msg:"Select the URI" ~hide_uri_entry:true - ~hide_try:true ~ok_label:"_Apply" ~ok_action:`SELECT - ~copy_cb:(fun s -> gui#sourceView#buffer#insert ("\n"^s^"\n")) - () ~id:"boh?" uris - with MatitaTypes.Cancel -> []) - ~set_star:gui#setStar - ~ask_confirmation: - (fun ~title ~message -> - MatitaGtkMisc.ask_confirmation ~title ~message - ~parent:gui#main#toplevel ()) - ~develcreator:gui#createDevelopment - () - in - gui#sourceView#source_buffer#begin_not_undoable_action (); - s#reset (); - s#template (); - gui#sourceView#source_buffer#end_not_undoable_action (); - s - - (* math viewers *) -let _ = - let cic_math_view = MatitaMathView.cicMathView_instance () in - let sequents_viewer = MatitaMathView.sequentsViewer_instance () in - sequents_viewer#load_logo; - cic_math_view#set_href_callback - (Some (fun uri -> (MatitaMathView.cicBrowser ())#load - (`Uri (UriManager.uri_of_string uri)))); - let browser_observer _ _ = MatitaMathView.refresh_all_browsers () in - let sequents_observer _ grafite_status = - sequents_viewer#reset; - match grafite_status.proof_status with - | Incomplete_proof ({ stack = stack } as incomplete_proof) -> - sequents_viewer#load_sequents incomplete_proof; - (try - script#setGoal (Some (Continuationals.Stack.find_goal stack)); - let goal = - match script#goal with - None -> assert false - | Some n -> n - in - sequents_viewer#goto_sequent goal - with Failure _ -> script#setGoal None); - | Proof proof -> sequents_viewer#load_logo_with_qed - | No_proof -> sequents_viewer#load_logo - | Intermediate _ -> assert false (* only the engine may be in this state *) - in - script#addObserver sequents_observer; - script#addObserver browser_observer - - (** {{{ Debugging *) -let _ = - if BuildTimeConf.debug then begin - gui#main#debugMenu#misc#show (); - let addDebugItem ~label callback = - let item = - GMenu.menu_item ~packing:gui#main#debugMenu_menu#append ~label () - in - ignore (item#connect#activate callback) - in - addDebugItem "dump environment to \"env.dump\"" (fun _ -> - let oc = open_out "env.dump" in - CicEnvironment.dump_to_channel oc; - close_out oc); - addDebugItem "load environment from \"env.dump\"" (fun _ -> - let ic = open_in "env.dump" in - CicEnvironment.restore_from_channel ic; - close_in ic); - addDebugItem "dump universes" (fun _ -> - List.iter (fun (u,_,g) -> - prerr_endline (UriManager.string_of_uri u); - CicUniv.print_ugraph g) (CicEnvironment.list_obj ()) - ); - addDebugItem "dump environment content" (fun _ -> - List.iter (fun (u,_,_) -> - prerr_endline (UriManager.string_of_uri u)) - (CicEnvironment.list_obj ())); -(* addDebugItem "print selections" (fun () -> - let cicMathView = MatitaMathView.cicMathView_instance () in - List.iter HLog.debug (cicMathView#string_of_selections)); *) - addDebugItem "dump script status" script#dump; - addDebugItem "dump configuration file to ./foo.conf.xml" (fun _ -> - Helm_registry.save_to "./foo.conf.xml"); - addDebugItem "dump metasenv" - (fun _ -> - if script#onGoingProof () then - HLog.debug (CicMetaSubst.ppmetasenv [] script#proofMetasenv)); - addDebugItem "dump coercions Db" (fun _ -> - List.iter - (fun (s,t,u) -> - HLog.debug - (UriManager.name_of_uri u ^ ":" - ^ CoercDb.name_of_carr s ^ " -> " ^ CoercDb.name_of_carr t)) - (CoercDb.to_list ())); - addDebugItem "print top-level grammar entries" - CicNotationParser.print_l2_pattern; - addDebugItem "dump moo to stderr" (fun _ -> - let grafite_status = (MatitaScript.current ())#grafite_status in - let moo = grafite_status.moo_content_rev in - List.iter - (fun cmd -> - prerr_endline (GrafiteAstPp.pp_command ~obj_pp:(fun _ -> assert false) - cmd)) - (List.rev moo)); - addDebugItem "print metasenv goals and stack to stderr" - (fun _ -> - prerr_endline ("metasenv goals: " ^ String.concat " " - (List.map (fun (g, _, _) -> string_of_int g) - (MatitaScript.current ())#proofMetasenv)); - prerr_endline ("stack: " ^ Continuationals.Stack.pp - (GrafiteTypes.get_stack (MatitaScript.current ())#grafite_status))); -(* addDebugItem "ask record choice" - (fun _ -> - HLog.debug (string_of_int - (MatitaGtkMisc.ask_record_choice ~gui ~title:"title" ~message:"msg" - ~fields:["a"; "b"; "c"] - ~records:[ - ["0"; "0"; "0"]; ["0"; "0"; "1"]; ["0"; "1"; "0"]; ["0"; "1"; "1"]; - ["1"; "0"; "0"]; ["1"; "0"; "1"]; ["1"; "1"; "0"]; ["1"; "1"; "1"]] - ()))); *) - addDebugItem "rotate light bulbs" - (fun _ -> - let nb = gui#main#hintNotebook in - nb#goto_page ((nb#current_page + 1) mod 3)); - addDebugItem "print runtime dir" - (fun _ -> - prerr_endline BuildTimeConf.runtime_base_dir); - addDebugItem "disable all (pretty printing) notations" - (fun _ -> CicNotation.set_active_notations []); - addDebugItem "enable all (pretty printing) notations" - (fun _ -> - CicNotation.set_active_notations - (List.map fst (CicNotation.get_all_notations ()))); - end - (** Debugging }}} *) - - (** {2 Command line parsing} *) - -let set_matita_mode () = - let matita_mode = - if Filename.basename Sys.argv.(0) = "cicbrowser" || - Filename.basename Sys.argv.(0) = "cicbrowser.opt" - then "cicbrowser" - else "matita" - in - Helm_registry.set "matita.mode" matita_mode - - (** {2 Main} *) - -let _ = - set_matita_mode (); - at_exit (fun () -> print_endline "\nThanks for using Matita!\n"); - Sys.catch_break true; - let args = Helm_registry.get_list Helm_registry.string "matita.args" in - if Helm_registry.get "matita.mode" = "cicbrowser" then (* cicbrowser *) - let browser = MatitaMathView.cicBrowser () in - let uri = match args with [] -> "cic:/" | _ -> String.concat " " args in - browser#loadInput uri - else begin (* matita *) - (try gui#loadScript (List.hd args) with Failure _ -> ()); - gui#main#mainWin#show (); - end; - try - GtkThread.main () - with Sys.Break -> () - -(* vim:set foldmethod=marker: *) diff --git a/helm/matita/matita.txt b/helm/matita/matita.txt deleted file mode 100644 index ce34e404c..000000000 --- a/helm/matita/matita.txt +++ /dev/null @@ -1,426 +0,0 @@ - Ferruccio ha cambiato matita.lang: - > iforall - > iexists - -TODO - NUCLEO - - http://mowgli.cs.unibo.it:58084/proofCheck?uri=cic:/Coq/Reals/Rtopology/interior_P3.con - - i files di coq non hanno gli universi e hanno Type senza l'id numerico - per ora vengono considerati come con grafo vuoto... - - limit_mul non compila (usare test_library per testare l'intera libreria) - (15:06:07) Zack: http://www.cs.unibo.it/cgi-bin/viewcvs.cgi/helm/gTopLevel/testlibrary.ml?rev=1.20&hideattic=0&content-type=text/vnd.viewcvs-markup - - PREOCCUPANTE: per - inductive i : Prop := K : True (*-> i*) -> i. - noi generiamo i_rec e i_rect con e senza il commento qui sopra; Coq NON - genera i_rec e i_rect quando c'e' un argomento ricorsivo. - (CSC: manca vincolo aggiuntivo non dipendente dalla sorta per il caso in - questione) -> CSC, parzialmente risolto, da finire - - Set predicativo - - bug universi e tipi induttivi (anche in cicElim.ml!!!) - - TATTICHE - - coercions verso sorte: - 1. coercere a una sorta in posizione controvariante: andare verso Prop, - altrimenti verso {Type,Set,CProp} (indifferentemente?) - 2. coercere a una sorta in posizione covariante: la scelta piu' safe e' - andare verso Type, poi verso CProp, poi verso Set, poi verso Prop. - Unico problema: la scelta piu' safe e' anche quella pessima dal punto - di vista dell'estrazione di codice :-( - - fare normalize_pattern : pattern -> goal -> pattern e usarla per - abilitare fase 2 in fold e rewrite - - apply puo' generare termini non ben tipati. - Esempio: p = q e fare apply eq_ind' di p! - - generazione di principi di co-induzione per co-induttivi - - ARGOMENTI IMPLICIT: li vogliamo? come? come disabilitarli localmente? - - file elim.ma: vengono creati lambda dummy e referenziati nell'outtype di - un case - - tattiche e fallimenti: una tattica che non progredisce dovrebbe fallire - - comportamento di tutte le tattiche nei confronti dei let-in - - elim con pattern - - assiomi (manca sintassi concreta e AST). - - Dare errore significativo al posto di NotWellTypedInterpreation -> CSC - - elim_intros_simpl e rewrite_simpl: ora non viene usata dal - ^^^^^^ ^^^^^^ - toplevel la variante che semplifica. Capire quali sono i problemi - e/o cosa fare delle varianti con semplificazione. - (con sintassi concreta alla \section*, analogamente cut e similia che fanno - intros... ) -> CSC - - eta_expand non usata da nessuno? (ask Andrea?) - - eliminare eta_fix? (aspettare notazione) (correlato con sopra?) - - bug di ferruccio: fare un refresh dei nomi dopo l'applicazione - di una tattica. Di quali nomi fare refresh? (Andrea) di quelli - veramente ambigui, ovvero dell'ultimo binder tale che sotto di - esso un nome viene usato in maniera ambigua. Esempio: - \lambda x. \lambda x. (x x) (dove una x e' -2) ==> fare refresh - \lambda x. \lambda x. (x x) (dove entrambe sono -1) ==> non fare refresh - Capita quando un tipo dall'environment (e.g. \lambda x.T) - viene inserito in un contesto (e.g. x:nat) dove le variabili - sono gia' state legate in precedenza. - - GUI GRAFICA - - cut & paste di pattern profondi nelle ipotesi - - cut & paste di inner-types non chiusi non funzionanti - - cut & paste di congetture nello script delle prove non funzionante - - keybinding globali: CTRL-{su,giu,...} devono fungere anche quando altre - finestre hanno il focus (e.g. cicBrowser). C'e' gia' da qualche parte il - codice che aggiunge i keybinding a tutte le eventBox, e' da ripristinare - - la finestrella per i development ha i pulsanti non sensitive. - - l'entry "Save" da menu non e' context sensitive (ti fa salvare anche - quando il file non e' stato modificato) - - non semplificherebbe le cose fare in modo che matitaScript sia un widget - (cosi' come lo e' matitaMathView) che eredita da GtkSourceView e mantiene - internamente lo status di matita etc. Appositi segnali permetterebbero di - evitare tutte le chiamate al singleton #instance di matitaScript, che - verrebbe creato dentro a matitaGui (o forse meglio dentro a matita e passato - a matitaGui). Si semplificherebbe forse anche la gestione di script - multipli? Forse no, perche' comunque ci puo' essere sempre solamente uno - ed un solo matitaScript (da spostare da un tab a un altro). - - la barra di stato: c'e' ma non funziona? - - - feedback su hyperlink nei sequenti e nel browser: rendere visibili gli - hyperlink (cursore a "manina"? hyperlink evidenziati?). La maction che - collassa la prova e' fastidiosa: la prova si chiude se non si clicca - correttamente su un hyperlink (anche tooltip sui bottoni) - - - che farne della palette delle tattiche? - - script outline, o meglio: modulo per la gestione del testo dello script - -> Zack - - riattaccare hbugs (brrr...) -> Zack - - - supportare l'apertura di piu' script contemporaneamente in tab/finestre - diversi/e - - GUI LOGICA - - -nodb non usato da disambiguazione: dopo il primo errore si ottiene - un errore di identificatore non trovato (dalla locate?) - - generazione di dipendenze verso .moo di Coq (non esistenti!) -> Zack - - proposta di Zack: NON calcolare (ed esportare) per default gli inner-types; - aggiungere un'opzione per questo a matitac (riduce drasticamente il tempo - di qed) - - la funzione alias_diff e' lentissima (anche se CSC l'ha accellerata di - un fattore 3x) e puo' essere evitata: chi vuole aggiungere alias (la - disambiguazione, il comando "alias" e l'add_obj) deve indicare - esplicitamente quali sono i nuovi alias, evitando cosi' la diff per - scoprirlo - - matitac deve fallire quando matita vuole aggiungere un alias! - - default equality e famiglia non e' undo-aware - - le coercion non sono undo-aware - - nuovo pretty-printer testuale: non stampa usando la notazione - (e.g. guardare output di matitac) - - matitamake foo/a.ma non funziona; bisogna chiamarlo con - matitamake /x/y/z/foo/a.ma - - notazione per i numeri -> Luca e Zack - - non chiudere transitivamente i moo ?? - - DEMONI E ALTRO - - compilare Whelp - -DONE -- in MatitaEngine unificare/rimuovere eval_string, eval_from_stream e - eval_from_stream_greedy -> CSC -- menu contestuale (tasto dx) nel sequent viewer -> Zack -- in generale: invece di spiegare gli errori nel momento in cui si sollevano - le eccezioni, farlo quando vengono presentate all'utente. Motivo: il calcolo - del messaggio di errore puo' essere estremamente costoso (e' gia' successo!) - quando poi il messaggio non serve!!! -> CSC -- matitaclean all (non troglie i moo?) -> Gares -- matitaclean (e famiglia) non cancellano le directory vuote - (e per giunta il cicbrowser le mostra :-) -> Gares -- missing feature unification: applicazione di teoremi (~A) quando il goal - e' False o di teoremi $symmetric R P$ quando il goal e' $P(x,y)$. - Fare un passo di delta[-beta?][-iota-etc.] quando da una parte c'e' una - testa rigida (che si espande in una freccia)? Ma il punto e' che il bug - non e' di unificazione, bensi' nella fase di preparazione del goal per - la apply -> CSC, Gares -- Guardare il commento - (*CSC: this code is suspect and/or bugged: we try first without reduction - and then using whd. However, the saturate_term always tries with full - reduction without delta. *) - in primitiveTactics.ml. Potrebbe essere causa di rallentamento della apply - oltre che di bug! -> CSC, Gares -- codice di inizializzazione di matita, matitac, matitatop replicato e non - in sync -> Gares -- tutte gli script che parsano (e.g. matitaclean, matitadep) debbono - processare la notazione per evitare errori di parsing (visibili ora - che e' stata committata la contrib list)! -> Gares -- E' possibile fare "Build" senza selezionare nulla, ottenendo un - assert false -> Gares -- disambiguazione: attualmente io (CSC) ho committato la versione di - disambiguate.ml che NON ricorda gli alias in caso di disambiguazione - univoca (senza scelte per l'utente). [ cercare commento "Experimental" ] - Il problema di questa soluzione e' che rallenta in maniera significativa - l'esecuzione degli script. DOMANDA: quanto costano le fasi di - fetch/decode/execute delle linee dello script? - Una possibile alternativa e' avere alias "soft": se la disambiguazione - fallisce gli alias soft vengono ripuliti e si riprova. - Altra soluzione (Gares): avere alias multipli e provare tutti gli alias - multipli. Da combinare con il "ritenta con istanze multiple in caso di - fallimento". - SOLUZIONE PENSATA CON ANDREA: 1. la interpretate aggiunge un alias - implicito; 2. gli alias vengono ricordati come nella soluzione originale - (e veloce); 3. se la disambiguazione fallisce, allora gli alias vengono - dimenticati (quali? tutti? tutti tranne quelli chiesti all'utente?) - e si ritenta; se fallisce ancora si generano - istanze differenti e si ritenta; 4. ritentare anche senza e poi con - coercions? oppure ordinare preferendo la soluzione che non ha introdotto - coercions?; 5. che fare se alla fine restano piu' scelte? se si mettono - gli alias nello script viene un paciugo, credo! in particolare quando - vengono usate n istanze -> Zack, CSC -- theorem t: True. elim O. ==> BOOM! unificazione di una testa flessibile con - True -> Gares -- parsing contestuale (tattiche replace, change e forse altre) - capire dove fare la select per avere i contesti in cui disambiguare gli - altri argomenti. -> Zack -- tattica unfold su rel a let-in bound variables: c'e' ancora un bug - aperto: "unfold x in H:..." la x passata alla unfold vive nel contesto - del goal e non in quello del pattern. Pertanto invece di cercare di - fare unfolding di x viene fatto unfolding di altro. - Soluzione: la funzione ProofEngineHelpers.select deve tornare una - funzione per rilocare i termini nel contesto giusto. - Esempio: - theorem t: let uno \def S O in uno + uno = S uno \to uno=uno. - intros. unfold uno in H. - NOTA: questo bug e' legato a quello di parsing in presenza di tattiche - con pattern, visto che in tal caso e' l'intero parsing a dover essere - fatto in un contesto differente. Risolvendo quel bug si risolve - automaticamente anche questo. - -> Zack -- Usare il cicbrowser per fare "Whelp instance": lui riscrive la barra - con la notazione alla Coq V7.0 che non riesce piu' a riparsare! -> Zack -- implementare inclusione file di configurazione (perche' ora tutti - i demoni scopiazzano venti righe per via del getter embedded :-( -> Zack -- simplify non debbono zeta-espandere i let-in -> CSC, Gares -- integrare nuova contrib ferruccio nel bench notturno e rilocarla in - contribs o qualcosa del genere -> CSC -- CRITICO: quando l'environment non e' trusted non compila la library di - matita!!! -> Gares, CSC -- bug di unsharing -> CSC -- CRITICO (trovato anche da Ferruccio): typechecking di - cic:/Coq/ring/Quote/index_eq_prop.con - asserzione del nucleo (applicazione senza argomenti). -> CSC -- verificare se tutte le query sono ora ottimizzate (usando il comando - explain) e usano gli indici in maniera ottimale; inoltre migliorare gli - indici sulle tabelle hits and count -> CSC -- ???????????? Perche'? - mowgli:~# du -s /var/lib/mysql/mowgli/ - 250696 /var/lib/mysql/mowgli/ - mowgli:~# du -s /var/lib/mysql/matita/ - 455096 /var/lib/mysql/matita/ -> CSC -- library/nat/primes.ma: ex_prime ci mette un secolo il db (binding) a fare - la Mysql.exec che ritorna una lista vuota di risultati. Investigare. - Anche peggio in library/nat/minimization/f_max_true. -> CSC -- integrare il famoso logo mancante (anche nell'About dialog) -> CSC -- invertibilita' dell'inserimento automatico di alias: quando si torna - su bisognerebbe tornare su di un passo e non fare undo degli alias - (Zack: nella history ci sono anche gli offset per sapere a che pezzo di - script uno stato appartiene) -> CSC -- bug di refresh del widget quando si avanza ("swap" tra la finestra dei - sequenti e la finestra dello script) -> CSC -- sensitiveness per goto begin/end/etc. (???) -> Gares -- cut&paste stile "X": rimane la parte blu e lockata! -> CSC -- highlight degli errori di parsing nello script -> CSC -- quando si fa una locate nel cicbrowser viene mangiato un pezzo di testo - dalla finestra principale!!! -> CSC -- sensitiveness per copy/paste/cut/delete nel menu Edit -> CSC -- fare "matita foo" (dove foo non esiste), cambiare qualcosa e uscire senza - salvare. In verita' foo e' stato scritto lo stesso! -> CSC -- matitaclean deve rimuovere anche i .moo; in alternativa il makefile - non deve basarsi sui .moo per decidere se qualcosa e' stato compilato o meno - -> CSC, Gares -- matitaclean all (o matitamake cleanall) dovrebbe radere al suolo la - directory .matita -> CSC, Gares -- icone standard per zoom-in/out/= e piu' aderenza alle Gnome Interface - Guidelines (e.g. about dialog) -> CSC -- salvare la parte di testo lockata dagli effetti di undo/redo con - (shift-)ctrl-Z e anche usando il menu che si apre con il tasto destro -> CSC -- fare in modo che il testo caricato inizialmente da matita non sia - undoable (usando i metodi begin/end_not_undoable_action di gtk_source_view) - -> Gares -- Implementare menu edit: cut/copy/undo/etc. -> CSC -- gestione dei path per include: il path deve essere assoluto? da decidere ... - ( -I ?? o chiedere a matitamake la root e farci una find? ) -> Gares -- freeze durante avanzamento -> Gares, CSC -- tornare indietro (verso il cursore) in matita dovrebbe essere O(1) e non un - Undo passo passo (sembra che il collo di bottiglia sia fare iterare su ogni - uri da togliere (accorpare almeno il lavoro sul db magari aiuta) -> Gares, CSC -- quando si sposta il punto di esecuzione dello script cambiare la parte di - script visibile nella finestra dello script -> Gares, CSC -- find & replace -> Gares -- Bug di cut&paste: se si fa cut&paste di testo lockato si ottiene testo - lockato! -> Gares -- Bug: non disambigua - inductive i (x:nat) : bool \to Prop \def K : bool \to (i x true) \to (i x false). - perche' non inserisce nat nel domain di disambiguazione. Deve esserci un bug - stupido da qualche parte -> CSC -- Bug vari nella generazione dei principi di eliminazione: - 1. generazione nomi (usa ref incrementata localmente) -> Andrea - 2. prodotti dipendenti come non-dipendenti (visibili eseguendo passo - passo il test inversion.ma) -> CSC, Gares - 3. usato trucco outtype non dipendenti per il case -> CSC, Gares -- controllo per script modificato o meno prima di uscire -> Gares -- LApply deve prendere in input gli identificatori che va a generare; - lascio a Ferruccio la scelta della sintassi concreta -> Ferruccio -- fare tornare a matitac -1 quando lo stato finale e' - diverso da No_proof, non eseguire comandi quando lo - stato e' diverso da No_proof -> CSC -- uri_of_term and term_of_uri: cambiare il tipo per far - tornare delle uri!!! -> CSC -- intro = intros 1 -> Gares -- timetravel (urimanager) -> Gares -- implementare macro in matitaScript.ml -> Gares -- history deve aggiornare anche la whelp bar -> Gares -- commenti exeguibili (forse devono essere una lista e non - un singolo executable e forse devono contenere anche Note - e non solo Executable) -> Gares -- spostare il codice di creazione delle tabelle da - MatitaDb, al momento quelle create da matita possono - andare out of sync con quelle create dai file .sql -> Gares -- tree update in background -> Gares -- update del getter in background -> Zack -- agganciare href_callback del sequent_viewer -> Zack -- shortcut varie per script handling -> Zack -- operazioni rimanenti su script (top, bottom, jump) -> Zack -- lighting-ls-getter in matita -> Gares -- riagganciare toolbar -> Zack -- evitare che n-mila tattiche Goal siano nello script - (una per ogni cambio di tab) -> Zack -- implementazione comandi rimanenti in matitaEngine.ml -> Gares -- sintassi per gli alias -> Gares -- implementazione script handling (sopra engine) -> Zack -- matitaSync all'indietro -> Gares -- riagganciare GUI -> Zack - -(**********************************************************************) - -comandi: - - interattivi (solo da gui) - - Macro/Comandi (check, print, hint, undo, locate, match) - potrebbero anche non avere sintassi concreta, del tipo che - check e' solo un bottone che apre una finetra in cui puoi - scrivere un termine o selezionarlo dalla prova corrente - - batch (sono gli unici che stanno nel .ma) - - Tattiche, theorem, alias (cambiano la prova) - - - MOUSE --------------------------------------------+ - gui (macro: hint) | SHELL - (disambiguatore) | - +-----------------+---------------+----------------------------------- - | matita (status) | | matitac - | (log) (sync) | but2log | fold ( fun s l -> engine l s) file - +-----------------+---------------+----------------------------------- - | lingua:/sintassi concreta non ambigua delle tattiche+Qed,Thm,alias/ - +---------------------------------------------------------- - | engine: TacticAst (cic) -> status -> status - | ma non usa il campo alias dello status ----------+---------------------------------------------------------- - ocaml --------------------------------------------------------------------- - - -engine: - - accetta solo linee non ambigue - - alias: - alias ident nat = "cic:/matita/gares/nat.ind#(1/1)". - alias number = (natural|real|positive|integer). - - - -matita: - - mantiene uno stack di stati - - mantiene un log sync con gli stati - - offre delle api per generare la sintassi concreta che puo' servire - alla gui (la gui fa una chiamata a funzione e matita genera "auto." - cosi' la sintassi la gui non la vede mai e la tratta al massimo come un - testo semplice e basta (insomma, metterei in matita il generatore di - sintassi concreta) but2log - - ha il controllo... ovvero anche la gui viene usata da matita, o per sapere - la prossima azione o per chidere di scegliere il termine tra una lista - - (stato :: tl) (log , (start,end) :: tl) - - +----------+ - | | - +----------+ - -gui: - - step - - choose - -stato: - - alias - - proof status option - - metadati relativi allo script per il sync - - settings "baseuri/url/" eccc - - - -alias - - sintassi concreta - -engine prende in input - - AST di Cic (tactic ast) - -sync: - - presi 2 stati fa il diff e lo somma/sottrae al DB - -(**********************************************************************) - -script handling -- ad ogni script sul quale l'utente sta lavorando corrispondono - - un modello (vedi sotto) - - un buffer di testo gtk + attributi (usati principalmente per distinguere la - parte di testo immodificabile da quella modificabile) - - una lista di observer che vengono notificati ad ogni cambiamento di stato -- un modello di script e' composto da: - - una lista di stringhe (inizialmente vuota) detta "statement list". Ogni - elemento della lista corrisponde ad uno statement (nel senso di - TacticAst.statement) gia' valutato dall'engine. La parte immodificabile del - buffer di testo corrisponde con le stringhe contenute nella lista - - una lista di stati (inizialmente contenente lo stato vuoto) detta "state - list". Si ha l'invariante che la lunghezza di tale lista e' uguale alla - lunghezza della statements list + 1. Lo stato i-esimo della lista di stati - e' lo stato di matita _prima_ dell'esecuzione dell i-esimo statement - - una stringa, detta "future text", corrispondente alla parte di testo dello - script non ancora valutata. L'ultimo stato della state list e' lo stato - corrente di matita -- relazione tra modello e buffer di testo gtk - - le modifiche al testo del buffer sono possibili solo nella parta non ancora - valutata. Ognuna di esse viene apportata _anche_ al future text - - invariante: e' sempre possibile riscrivere ("redraw") l'intero contenuto del - buffer di testo a partire dal modello, attributi compresi -- oggetto script - - metodi - - new: gtk_text_buffer -> script - - redraw: unit (* ridisegna il contenuto del buffer di testo *) - - advance: ?statement:string -> unit -> unit - (* valuta il primo statement del future text (usando eval_statement - (puo' fallire con una eccezione)), rimuove il testo corrispondente dal - future text, aggiunge alla statement list una entry per ogni statement - ritornato da eval_statement, aggiunge il nuovo stato alla state list, - invoka tutti gli observer - Se c'e' l'argomento opzionale statement, quello e' il testo che viene - passato ad eval_statement, se ha successo nessuna rimozione dal future - text viene effettuata *) - - retract: unit -> unit - (* sposta l'ultimo statement della statement list al future text, toglie - l'ultimo stato della state list, MatitaSync.time_travel - ~present:ultimo_stato ~past:stato_precedente *) - - private eval_statement: string -> MatitaTypes.status * string list - (* parsa lo statement - - se e' un Command o un Tactical (vedi TacticAst) invoca MatitaEngine - passando lo stato corrente - - se e' una Macro la gestisce (= tutte le Macro sono implementate qua) - Ritorna una lista di coppie . La proiezione sulla - prima componente rappresenta gli stati da aggiungere alla state list; - quella sulla seconda gli statement da aggiungere alla statement list. - *) - (* gestione degli observer *) - - add_observer: (MatitaTypes.status -> unit) -> observer_id - - remove_observer: observer_id -> unit - (* gestione del salvataggio *) - - save_to: string -> unit (* ridisegna su file *) - - load_from: string -> unit - (* retract fino allo stato zero, nuovo stato con future text pari al - contenuto del file passato *) - diff --git a/helm/matita/matitaEngine.ml b/helm/matita/matitaEngine.ml deleted file mode 100644 index f0d8ee46c..000000000 --- a/helm/matita/matitaEngine.ml +++ /dev/null @@ -1,142 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let debug = false ;; -let debug_print = if debug then prerr_endline else ignore ;; - -let disambiguate_tactic lexicon_status_ref grafite_status goal tac = - let metasenv,tac = - GrafiteDisambiguate.disambiguate_tactic - lexicon_status_ref - (GrafiteTypes.get_proof_context grafite_status goal) - (GrafiteTypes.get_proof_metasenv grafite_status) - tac - in - GrafiteTypes.set_metasenv metasenv grafite_status,tac - -let disambiguate_command lexicon_status_ref grafite_status cmd = - let lexicon_status,metasenv,cmd = - GrafiteDisambiguate.disambiguate_command - ~baseuri:( - try - Some (GrafiteTypes.get_string_option grafite_status "baseuri") - with - GrafiteTypes.Option_error _ -> None) - !lexicon_status_ref (GrafiteTypes.get_proof_metasenv grafite_status) cmd - in - lexicon_status_ref := lexicon_status; - GrafiteTypes.set_metasenv metasenv grafite_status,cmd - -let disambiguate_macro lexicon_status_ref grafite_status macro context = - let metasenv,macro = - GrafiteDisambiguate.disambiguate_macro - lexicon_status_ref - (GrafiteTypes.get_proof_metasenv grafite_status) - context macro - in - GrafiteTypes.set_metasenv metasenv grafite_status,macro - -let eval_ast ?do_heavy_checks ?clean_baseuri lexicon_status - grafite_status ast -= - let lexicon_status_ref = ref lexicon_status in - let new_grafite_status,new_objs = - GrafiteEngine.eval_ast - ~disambiguate_tactic:(disambiguate_tactic lexicon_status_ref) - ~disambiguate_command:(disambiguate_command lexicon_status_ref) - ~disambiguate_macro:(disambiguate_macro lexicon_status_ref) - ?do_heavy_checks ?clean_baseuri grafite_status ast in - let new_lexicon_status = - LexiconSync.add_aliases_for_objs !lexicon_status_ref new_objs in - let new_aliases = - LexiconSync.alias_diff ~from:lexicon_status new_lexicon_status in - let _,intermediate_states = - let baseuri = GrafiteTypes.get_string_option new_grafite_status "baseuri" in - List.fold_left - (fun (lexicon_status,acc) (k,((v,_) as value)) -> - let b = - try - UriManager.buri_of_uri (UriManager.uri_of_string v) = baseuri - with - UriManager.IllFormedUri _ -> false (* v is a description, not a URI *) - in - if b then - lexicon_status,acc - else - let new_lexicon_status = - LexiconEngine.set_proof_aliases lexicon_status [k,value] - in - new_lexicon_status, - ((new_grafite_status,new_lexicon_status),Some (k,value))::acc - ) (lexicon_status,[]) new_aliases - in - ((new_grafite_status,new_lexicon_status),None)::intermediate_states - -let eval_from_stream ~first_statement_only ~include_paths ?(prompt=false) - ?do_heavy_checks ?clean_baseuri lexicon_status grafite_status str cb -= - let rec loop lexicon_status grafite_status statuses = - let loop = - if first_statement_only then - fun _ _ _ -> raise End_of_file - else - loop - in - if prompt then (print_string "matita> "; flush stdout); - try - let lexicon_status,ast = - GrafiteParser.parse_statement ~include_paths str lexicon_status - in - (match ast with - GrafiteParser.LNone _ -> - loop lexicon_status grafite_status - (((grafite_status,lexicon_status),None)::statuses) - | GrafiteParser.LSome ast -> - cb grafite_status ast; - let new_statuses = - eval_ast ?do_heavy_checks ?clean_baseuri lexicon_status - grafite_status ast in - let grafite_status,lexicon_status = - match new_statuses with - [] -> assert false - | (s,_)::_ -> s - in - loop lexicon_status grafite_status (new_statuses @ statuses)) - with - End_of_file -> statuses - in - loop lexicon_status grafite_status [] -;; - -let eval_string ~first_statement_only ~include_paths ?do_heavy_checks - ?clean_baseuri lexicon_status status str -= - eval_from_stream ~first_statement_only ~include_paths ?do_heavy_checks - ?clean_baseuri lexicon_status status (Ulexing.from_utf8_string str) - (fun _ _ -> ()) diff --git a/helm/matita/matitaEngine.mli b/helm/matita/matitaEngine.mli deleted file mode 100644 index a3c54dea6..000000000 --- a/helm/matita/matitaEngine.mli +++ /dev/null @@ -1,68 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val eval_ast : - ?do_heavy_checks:bool -> - ?clean_baseuri:bool -> - LexiconEngine.status -> - GrafiteTypes.status -> - (CicNotationPt.term, CicNotationPt.term, - CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) - GrafiteAst.statement -> - ((GrafiteTypes.status * LexiconEngine.status) * - (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) option - ) list - - -(* heavy checks slow down the compilation process but give you some interesting - * infos like if the theorem is a duplicate *) -val eval_string : - first_statement_only:bool -> - include_paths:string list -> - ?do_heavy_checks:bool -> - ?clean_baseuri:bool -> - LexiconEngine.status -> - GrafiteTypes.status -> - string -> - ((GrafiteTypes.status * LexiconEngine.status) * - (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) option - ) list - -val eval_from_stream : - first_statement_only:bool -> - include_paths:string list -> - ?prompt:bool -> - ?do_heavy_checks:bool -> - ?clean_baseuri:bool -> - LexiconEngine.status -> - GrafiteTypes.status -> - Ulexing.lexbuf -> - (GrafiteTypes.status -> - (CicNotationPt.term, CicNotationPt.term, - CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) - GrafiteAst.statement -> unit) -> - ((GrafiteTypes.status * LexiconEngine.status) * - (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) option - ) list diff --git a/helm/matita/matitaExcPp.ml b/helm/matita/matitaExcPp.ml deleted file mode 100644 index 28f25fd5c..000000000 --- a/helm/matita/matitaExcPp.ml +++ /dev/null @@ -1,111 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let rec to_string = - function - | HExtlib.Localized (floc,exn) -> - let _,msg = to_string exn in - let (x, y) = HExtlib.loc_of_floc floc in - Some floc, sprintf "Error at %d-%d: %s" x y msg - | GrafiteTypes.Option_error ("baseuri", "not found" ) -> - None, - "Baseuri not set for this script. " - ^ "Use 'set \"baseuri\" \"\".' to set it." - | GrafiteTypes.Command_error msg -> None, "Error: " ^ msg - | CicNotationParser.Parse_error err -> - None, sprintf "Parse error: %s" err - | UriManager.IllFormedUri uri -> None, sprintf "invalid uri: %s" uri - | CicEnvironment.Object_not_found uri -> - None, sprintf "object not found: %s" (UriManager.string_of_uri uri) - | Unix.Unix_error (code, api, param) -> - let err = Unix.error_message code in - None, "Unix Error (" ^ api ^ "): " ^ err - | HMarshal.Corrupt_file fname -> None, sprintf "file '%s' is corrupt" fname - | HMarshal.Format_mismatch fname - | HMarshal.Version_mismatch fname -> - None, - sprintf "format/version mismatch for file '%s', please recompile it'" - fname - | ProofEngineTypes.Fail msg -> None, "Tactic error: " ^ Lazy.force msg - | Continuationals.Error s -> None, "Tactical error: " ^ Lazy.force s - | CicTypeChecker.TypeCheckerFailure msg -> - None, "Type checking error: " ^ Lazy.force msg - | CicTypeChecker.AssertFailure msg -> - None, "Type checking assertion failed: " ^ Lazy.force msg - | LibrarySync.AlreadyDefined s -> - None, "Already defined: " ^ UriManager.string_of_uri s - | GrafiteDisambiguator.DisambiguationError (offset,errorll) -> - let rec aux n ?(dummy=false) (prev_msg,phases) = - function - [] -> [prev_msg,phases] - | phase::tl -> - let msg = - String.concat "\n\n\n" - (List.map (fun (floc,msg) -> - let loc_descr = - match floc with - None -> "" - | Some floc -> - let (x, y) = HExtlib.loc_of_floc floc in - sprintf " at %d-%d" (x+offset) (y+offset) - in - "*Error" ^ loc_descr ^ ": " ^ Lazy.force msg) phase) - in - if msg = prev_msg then - aux (n+1) (msg,phases@[n]) tl - else - (if not dummy then [prev_msg,phases] else []) @ - (aux (n+1) (msg,[n]) tl) in - let loc = - match errorll with - ((Some floc,_)::_)::_ -> - let (x, y) = HExtlib.loc_of_floc floc in - let x = x + offset in - let y = y + offset in - let flocb,floce = floc in - let floc = - {flocb with Lexing.pos_cnum = x}, {floce with Lexing.pos_cnum = y} - in - Some floc - | _ -> None in - let rec explain = - function - [] -> "" - | (msg,phases)::tl -> - explain tl ^ - "***** Errors obtained during phase" ^ - (if phases = [] then " " else "s ") ^ - String.concat "," (List.map string_of_int phases) ^": *****\n"^ - msg ^ "\n\n" - in - loc, - "********** DISAMBIGUATION ERRORS: **********\n" ^ - explain (aux 1 ~dummy:true ("",[]) errorll) - | exn -> None, "Uncaught exception: " ^ Printexc.to_string exn - diff --git a/helm/matita/matitaExcPp.mli b/helm/matita/matitaExcPp.mli deleted file mode 100644 index 9d8c7739f..000000000 --- a/helm/matita/matitaExcPp.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val to_string: exn -> Token.flocation option * string - diff --git a/helm/matita/matitaGtkMisc.ml b/helm/matita/matitaGtkMisc.ml deleted file mode 100644 index 553406635..000000000 --- a/helm/matita/matitaGtkMisc.ml +++ /dev/null @@ -1,439 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception PopupClosed -open Printf - -let wrap_callback f = f - -let connect_button (button: #GButton.button) callback = - ignore (button#connect#clicked (wrap_callback callback)) - -let connect_toggle_button (button: #GButton.toggle_button) callback = - ignore (button#connect#toggled (wrap_callback callback)) - -let connect_menu_item (menu_item: #GMenu.menu_item) callback = - ignore (menu_item#connect#activate (wrap_callback callback)) - -let connect_key (ev:GObj.event_ops) ?(modifiers = []) ?(stop = false) key - callback -= - ignore (ev#connect#key_press (fun key' -> - let modifiers' = GdkEvent.Key.state key' in - (match key' with - | key' when GdkEvent.Key.keyval key' = key - && List.for_all (fun m -> List.mem m modifiers') modifiers -> - callback (); - stop - | _ -> false))) - -let toggle_widget_visibility ~(widget: GObj.widget) - ~(check: GMenu.check_menu_item) -= - ignore (check#connect#toggled (fun _ -> - if check#active then widget#misc#show () else widget#misc#hide ())) - -let toggle_window_visibility ~(window: GWindow.window) - ~(check: GMenu.check_menu_item) -= - ignore (check#connect#toggled (fun _ -> - if check#active then window#show () else window#misc#hide ())); - ignore (window#event#connect#delete (fun _ -> - window#misc#hide (); - check#set_active false; - true)) - -let toggle_win ?(check: GMenu.check_menu_item option) (win: GWindow.window) () = - if win#is_active then win#misc#hide () else win#show (); - match check with - | None -> () - | Some check -> check#set_active (not check#active) - -let toggle_callback ~callback ~(check: GMenu.check_menu_item) = - ignore (check#connect#toggled (fun _ -> callback check#active)) - -let add_key_binding key callback (evbox: GBin.event_box) = - ignore (evbox#event#connect#key_press (function - | key' when GdkEvent.Key.keyval key' = key -> - callback (); - false - | _ -> false)) - -class multiStringListModel ~cols (tree_view: GTree.view) = - let column_list = new GTree.column_list in - let text_columns = - let rec aux = function - | 0 -> [] - | n -> column_list#add Gobject.Data.string :: aux (n - 1) - in - aux cols - in - let list_store = GTree.list_store column_list in - let renderers = - List.map - (fun text_column -> - (GTree.cell_renderer_text [], ["text", text_column])) - text_columns - in - let view_columns = - List.map - (fun renderer -> GTree.view_column ~renderer ()) - renderers - in - object (self) - val text_columns = text_columns - - initializer - tree_view#set_model (Some (list_store :> GTree.model)); - List.iter - (fun view_column -> ignore (tree_view#append_column view_column)) - view_columns - - method list_store = list_store - - method easy_mappend slist = - let tree_iter = list_store#append () in - List.iter2 - (fun s text_column -> - list_store#set ~row:tree_iter ~column:text_column s) - slist text_columns - - method easy_minsert pos s = - let tree_iter = list_store#insert pos in - List.iter2 - (fun s text_column -> - list_store#set ~row:tree_iter ~column:text_column s) - s text_columns - - method easy_mselection () = - List.map - (fun tree_path -> - let iter = list_store#get_iter tree_path in - List.map - (fun text_column -> - list_store#get ~row:iter ~column:text_column) - text_columns) - tree_view#selection#get_selected_rows - end - -class stringListModel (tree_view: GTree.view) = - object (self) - inherit multiStringListModel ~cols:1 tree_view as multi - - method list_store = multi#list_store - - method easy_append s = - multi#easy_mappend [s] - - method easy_insert pos s = - multi#easy_minsert pos [s] - - method easy_selection () = - let m = List.map - (fun tree_path -> - let iter = self#list_store#get_iter tree_path in - List.map - (fun text_column -> - self#list_store#get ~row:iter ~column:text_column) - text_columns) - tree_view#selection#get_selected_rows - in - List.map (function [x] -> x | _ -> assert false) m - end - -class taggedStringListModel ~(tags:(string * GdkPixbuf.pixbuf) list) - (tree_view: GTree.view) -= - let column_list = new GTree.column_list in - let tag_column = column_list#add Gobject.Data.gobject in - let text_column = column_list#add Gobject.Data.string in - let list_store = GTree.list_store column_list in - let text_renderer = (GTree.cell_renderer_text [], ["text", text_column]) in - let tag_renderer = (GTree.cell_renderer_pixbuf [], ["pixbuf", tag_column]) in - let text_vcolumn = GTree.view_column ~renderer:text_renderer () in - let tag_vcolumn = GTree.view_column ~renderer:tag_renderer () in - let lookup_pixbuf tag = - try List.assoc tag tags with Not_found -> assert false - in - object (self) - initializer - tree_view#set_model (Some (list_store :> GTree.model)); - ignore (tree_view#append_column tag_vcolumn); - ignore (tree_view#append_column text_vcolumn) - - method list_store = list_store - - method easy_append ~tag s = - let tree_iter = list_store#append () in - list_store#set ~row:tree_iter ~column:text_column s; - list_store#set ~row:tree_iter ~column:tag_column (lookup_pixbuf tag) - - method easy_insert pos ~tag s = - let tree_iter = list_store#insert pos in - list_store#set ~row:tree_iter ~column:text_column s; - list_store#set ~row:tree_iter ~column:tag_column (lookup_pixbuf tag) - - method easy_selection () = - List.map - (fun tree_path -> - let iter = list_store#get_iter tree_path in - list_store#get ~row:iter ~column:text_column) - tree_view#selection#get_selected_rows - end - -class recordModel (tree_view:GTree.view) = - let cols_list = new GTree.column_list in - let text_col = cols_list#add Gobject.Data.string in -(* let combo_col = cols_list#add (Gobject.Data.gobject_by_name "GtkListStore") in *) - let combo_col = cols_list#add Gobject.Data.int in - let toggle_col = cols_list#add Gobject.Data.boolean in - let list_store = GTree.list_store cols_list in - let text_rend = (GTree.cell_renderer_text [], ["text", text_col]) in - let combo_rend = GTree.cell_renderer_combo [] in -(* let combo_rend = (GTree.cell_renderer_combo [], [|+"model", combo_col+|]) in *) - let toggle_rend = - (GTree.cell_renderer_toggle [`ACTIVATABLE true], ["active", toggle_col]) - in - let text_vcol = GTree.view_column ~renderer:text_rend () in - let combo_vcol = GTree.view_column ~renderer:(combo_rend, []) () in - let _ = - combo_vcol#set_cell_data_func combo_rend - (fun _ _ -> - prerr_endline "qui"; - let model, col = - GTree.store_of_list Gobject.Data.string ["a"; "b"; "c"] - in - combo_rend#set_properties [ - `MODEL (Some (model :> GTree.model)); - `TEXT_COLUMN col - ]) - in - let toggle_vcol = GTree.view_column ~renderer:toggle_rend () in - object (self) - initializer - tree_view#set_model (Some (list_store :> GTree.model)); - ignore (tree_view#append_column text_vcol); - ignore (tree_view#append_column combo_vcol); - ignore (tree_view#append_column toggle_vcol) - - method list_store = list_store - - method easy_append s (combo:int) (toggle:bool) = - let tree_iter = list_store#append () in - list_store#set ~row:tree_iter ~column:text_col s; - list_store#set ~row:tree_iter ~column:combo_col combo; - list_store#set ~row:tree_iter ~column:toggle_col toggle - end - -class type gui = - object - method newUriDialog: unit -> MatitaGeneratedGui.uriChoiceDialog - method newRecordDialog: unit -> MatitaGeneratedGui.recordChoiceDialog - method newConfirmationDialog: unit -> MatitaGeneratedGui.confirmationDialog - method newEmptyDialog: unit -> MatitaGeneratedGui.emptyDialog - end - -let popup_message - ~title ~message ~buttons ~callback - ?(message_type=`QUESTION) ?parent ?(use_markup=true) - ?(destroy_with_parent=true) ?(allow_grow=false) ?(allow_shrink=false) - ?icon ?(modal=true) ?(resizable=false) ?screen ?type_hint - ?(position=`CENTER_ON_PARENT) ?wm_name ?wm_class ?border_width ?width - ?height ?(show=true) () -= - let m = - GWindow.message_dialog - ~message ~use_markup ~message_type ~buttons ?parent ~destroy_with_parent - ~title ~allow_grow ~allow_shrink ?icon ~modal ~resizable ?screen - ?type_hint ~position ?wm_name ?wm_class ?border_width ?width ?height - ~show () - in - ignore(m#connect#response - ~callback:(fun a -> GMain.Main.quit ();callback a)); - ignore(m#connect#close - ~callback:(fun _ -> GMain.Main.quit ();raise PopupClosed)); - GtkThread.main (); - m#destroy () - -let popup_message_lowlevel - ~title ~message ?(no_separator=true) ~callback ~message_type ~buttons - ?parent ?(destroy_with_parent=true) ?(allow_grow=false) ?(allow_shrink=false) - ?icon ?(modal=true) ?(resizable=false) ?screen ?type_hint - ?(position=`CENTER_ON_PARENT) ?wm_name ?wm_class ?border_width ?width - ?height ?(show=true) () -= - let m = - GWindow.dialog - ~no_separator - ?parent ~destroy_with_parent - ~title ~allow_grow ~allow_shrink ?icon ~modal ~resizable ?screen - ?type_hint ~position ?wm_name ?wm_class ?border_width ?width ?height - ~show:false () - in - let stock = - match message_type with - | `WARNING -> `DIALOG_WARNING - | `INFO -> `DIALOG_INFO - | `ERROR ->`DIALOG_ERROR - | `QUESTION -> `DIALOG_QUESTION - in - let image = GMisc.image ~stock ~icon_size:`DIALOG () in - let label = GMisc.label ~markup:message () in - label#set_line_wrap true; - let hbox = GPack.hbox ~spacing:10 () in - hbox#pack ~from:`START ~expand:true ~fill:true (image:>GObj.widget); - hbox#pack ~from:`START ~expand:true ~fill:true (label:>GObj.widget); - m#vbox#pack ~from:`START - ~padding:20 ~expand:true ~fill:true (hbox:>GObj.widget); - List.iter (fun (x, y) -> - m#add_button_stock x y; - if y = `CANCEL then - m#set_default_response y - ) buttons; - ignore(m#connect#response - ~callback:(fun a -> GMain.Main.quit ();callback a)); - ignore(m#connect#close - ~callback:(fun _ -> GMain.Main.quit ();callback `POPUPCLOSED)); - if show = true then - m#show (); - GtkThread.main (); - m#destroy () - - -let ask_confirmation ~title ~message ?parent () = - let rc = ref `YES in - let callback = - function - | `YES -> rc := `YES - | `NO -> rc := `NO - | `CANCEL -> rc := `CANCEL - | `DELETE_EVENT -> rc := `CANCEL - | `POPUPCLOSED -> rc := `CANCEL - in - let buttons = [`YES,`YES ; `NO,`NO ; `CANCEL,`CANCEL] in - popup_message_lowlevel - ~title ~message ~message_type:`WARNING ~callback ~buttons ?parent (); - !rc - -let report_error ~title ~message ?parent () = - let callback _ = () in - let buttons = GWindow.Buttons.ok in - try - popup_message - ~title ~message ~message_type:`ERROR ~callback ~buttons ?parent () - with - | PopupClosed -> () - - -let ask_text ~(gui:#gui) ?(title = "") ?(message = "") ?(multiline = false) - ?default () -= - let dialog = gui#newEmptyDialog () in - dialog#emptyDialog#set_title title; - dialog#emptyDialogLabel#set_label message; - let result = ref None in - let return r = - result := r; - dialog#emptyDialog#destroy (); - GMain.Main.quit () - in - ignore (dialog#emptyDialog#event#connect#delete (fun _ -> true)); - if multiline then begin (* multiline input required: use a TextView widget *) - let win = - GBin.scrolled_window ~width:400 ~height:150 ~hpolicy:`NEVER - ~vpolicy:`ALWAYS ~packing:dialog#emptyDialogVBox#add () - in - let view = GText.view ~wrap_mode:`CHAR ~packing:win#add () in - let buffer = view#buffer in - (match default with - | None -> () - | Some text -> - buffer#set_text text; - buffer#select_range buffer#start_iter buffer#end_iter); - view#misc#grab_focus (); - connect_button dialog#emptyDialogOkButton (fun _ -> - return (Some (buffer#get_text ()))) - end else begin (* monoline input required: use a TextEntry widget *) - let entry = GEdit.entry ~packing:dialog#emptyDialogVBox#add () in - (match default with - | None -> () - | Some text -> - entry#set_text text; - entry#select_region ~start:0 ~stop:max_int); - entry#misc#grab_focus (); - connect_button dialog#emptyDialogOkButton (fun _ -> - return (Some entry#text)) - end; - connect_button dialog#emptyDialogCancelButton (fun _ ->return None); - dialog#emptyDialog#show (); - GtkThread.main (); - (match !result with None -> raise MatitaTypes.Cancel | Some r -> r) - -let ask_record_choice ~(gui:#gui) ?(title= "") ?(message = "") - ~fields ~records () -= - let fields = Array.of_list fields in - let fields_no = Array.length fields in - assert (fields_no > 0); - let dialog = gui#newRecordDialog () in - dialog#recordChoiceDialog#set_title title; - dialog#recordChoiceDialogLabel#set_label message; - let model = new recordModel dialog#recordChoiceTreeView in - dialog#recordChoiceTreeView#set_headers_visible true; - let combos = - Array.init fields_no - (fun _ -> GTree.store_of_list Gobject.Data.string ["a"; "b"; "c"]) - in - let (store, col) = combos.(0) in - store#set ~row:(store#append ()) ~column:col "uno"; - store#set ~row:(store#append ()) ~column:col "due"; - let toggles = Array.init fields_no (fun _ -> false) in - Array.iteri - (fun i f -> model#easy_append f i toggles.(i)) - fields; - let record_no = ref None in - let return _ = - dialog#recordChoiceDialog#destroy (); - GMain.Main.quit () - in - let fail _ = record_no := None; return () in - ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true)); - connect_button dialog#recordChoiceOkButton (fun _ -> - match !record_no with None -> () | Some _ -> return ()); - connect_button dialog#recordChoiceCancelButton fail; -(* ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ -> - interp_no := Some (model#get_interp_no path); - return ())); - let selection = dialog#recordChoiceTreeView#selection in - ignore (selection#connect#changed (fun _ -> - match selection#get_selected_rows with - | [path] -> interp_no := Some (model#get_interp_no path) - | _ -> assert false)); *) - dialog#recordChoiceDialog#show (); - GtkThread.main (); - (match !record_no with Some n -> n | _ -> raise MatitaTypes.Cancel) - diff --git a/helm/matita/matitaGtkMisc.mli b/helm/matita/matitaGtkMisc.mli deleted file mode 100644 index 1affd2a39..000000000 --- a/helm/matita/matitaGtkMisc.mli +++ /dev/null @@ -1,157 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** {2 Gtk helpers} *) - - (** given a window and a check menu item it links the two so that the former - * is only hidden on delete and the latter toggle show/hide of the former *) -val toggle_window_visibility: - window:GWindow.window -> check:GMenu.check_menu_item -> unit - - (** given a window and a check menu item it links the two so that the former - * is only hidden on delete and the latter toggle show/hide of the former *) -val toggle_widget_visibility: - widget:GObj.widget -> check:GMenu.check_menu_item -> unit - -val toggle_callback: - callback:(bool -> unit) -> check:GMenu.check_menu_item -> unit - -val toggle_win: - ?check:GMenu.check_menu_item -> GWindow.window -> unit -> unit - -val add_key_binding: Gdk.keysym -> (unit -> 'a) -> GBin.event_box -> unit - -(** Connect a callback to the clicked signal of a button, ignoring its return - * value *) -val connect_button: #GButton.button -> (unit -> unit) -> unit - - -(** Connect a callback to the toggled signal of a button, ignoring its return - * value *) -val connect_toggle_button: #GButton.toggle_button -> (unit -> unit) -> unit - -(** Like connect_button above, but connects a callback to the activate signal of - * a menu item *) -val connect_menu_item: #GMenu.menu_item -> (unit -> unit) -> unit - - (** connect a unit -> unit callback to a particular key press event. Event can - * be specified using its keysym and a list of modifiers which must be in - * effect for the callback to be executed. Further signal processing of other - * key press events remains unchanged; further signal processing of the - * specified key press depends on the stop parameter *) -val connect_key: - GObj.event_ops -> - ?modifiers:Gdk.Tags.modifier list -> - ?stop:bool -> (* stop signal handling when the given key has been pressed? - * Defaults to false *) - Gdk.keysym -> (* (= int) the key, see GdkKeysyms.ml *) - (unit -> unit) -> (* callback *) - unit - - (** n-ary string column list *) -class multiStringListModel: - cols:int -> - GTree.view -> - object - method list_store: GTree.list_store (** list_store forwarding *) - - method easy_mappend: string list -> unit (** append + set *) - method easy_minsert: int -> string list -> unit (** insert + set *) - method easy_mselection: unit -> string list list - end - - (** single string column list *) -class stringListModel: - GTree.view -> - object - inherit multiStringListModel - - method easy_append: string -> unit (** append + set *) - method easy_insert: int -> string -> unit (** insert + set *) - method easy_selection: unit -> string list - end - - - (** as above with Pixbuf associated to each row. Each time an insert is - * performed a string tag should be specified, the corresponding pixbuf in the - * tags associative list will be shown on the left of the inserted row *) -class taggedStringListModel: - tags:((string * GdkPixbuf.pixbuf) list) -> - GTree.view -> - object - method list_store: GTree.list_store (** list_store forwarding *) - - method easy_append: tag:string -> string -> unit - method easy_insert: int -> tag:string -> string -> unit - method easy_selection: unit -> string list - end - -(** {2 Matita GUI components} *) - -class type gui = - object (* minimal gui object requirements *) - method newUriDialog: unit -> MatitaGeneratedGui.uriChoiceDialog - method newRecordDialog: unit -> MatitaGeneratedGui.recordChoiceDialog - method newConfirmationDialog: unit -> MatitaGeneratedGui.confirmationDialog - method newEmptyDialog: unit -> MatitaGeneratedGui.emptyDialog - end - - (** {3 Dialogs} - * In functions below: - * @param title window title - * @param message content of the text label shown to the user *) - - (** @param parent to center the window on it *) -val ask_confirmation: - title:string -> message:string -> - ?parent:#GWindow.window_skel -> - unit -> - [`YES | `NO | `CANCEL] - - (** @param multiline (default: false) if true a TextView widget will be used - * for prompting the user otherwise a TextEntry widget will be - * @return the string given by the user *) -val ask_text: - gui:#gui -> - ?title:string -> ?message:string -> - ?multiline:bool -> ?default:string -> unit -> - string - - (** @param fields field names - * @param records list of records, each record is a list of [fields] strings - * @return number of the chosen record, 0 for the first one *) -val ask_record_choice: - gui:#gui -> - ?title:string -> ?message:string -> - fields:string list -> records:string list list -> - unit -> - int - -val report_error: - title:string -> message:string -> - ?parent:#GWindow.window_skel -> - unit -> - unit - diff --git a/helm/matita/matitaGui.ml b/helm/matita/matitaGui.ml deleted file mode 100644 index ed739eefb..000000000 --- a/helm/matita/matitaGui.ml +++ /dev/null @@ -1,1280 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open MatitaGeneratedGui -open MatitaGtkMisc -open MatitaMisc - -exception Found of int - -let gui_instance = ref None - -class type browserWin = - (* this class exists only because GEdit.combo_box_entry is not supported by - * lablgladecc :-(((( *) -object - inherit MatitaGeneratedGui.browserWin - method browserUri: GEdit.combo_box_entry -end - -class console ~(buffer: GText.buffer) () = - object (self) - val error_tag = buffer#create_tag [ `FOREGROUND "red" ] - val warning_tag = buffer#create_tag [ `FOREGROUND "orange" ] - val message_tag = buffer#create_tag [] - val debug_tag = buffer#create_tag [ `FOREGROUND "#888888" ] - method message s = buffer#insert ~iter:buffer#end_iter ~tags:[message_tag] s - method error s = buffer#insert ~iter:buffer#end_iter ~tags:[error_tag] s - method warning s = buffer#insert ~iter:buffer#end_iter ~tags:[warning_tag] s - method debug s = buffer#insert ~iter:buffer#end_iter ~tags:[debug_tag] s - method clear () = - buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter - method log_callback (tag: HLog.log_tag) s = - match tag with - | `Debug -> self#debug (s ^ "\n") - | `Error -> self#error (s ^ "\n") - | `Message -> self#message (s ^ "\n") - | `Warning -> self#warning (s ^ "\n") - end - -let clean_current_baseuri grafite_status = - try - let baseuri = GrafiteTypes.get_string_option grafite_status "baseuri" in - let basedir = Helm_registry.get "matita.basedir" in - LibraryClean.clean_baseuris ~basedir [baseuri] - with GrafiteTypes.Option_error _ -> () - -let ask_and_save_moo_if_needed parent fname lexicon_status grafite_status = - let basedir = Helm_registry.get "matita.basedir" in - let baseuri = DependenciesParser.baseuri_of_script ~include_paths:[] fname in - let moo_fname = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in - let save () = - let metadata_fname = - LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri in - let lexicon_fname = - LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri - in - GrafiteMarshal.save_moo moo_fname - grafite_status.GrafiteTypes.moo_content_rev; - LibraryNoDb.save_metadata metadata_fname - lexicon_status.LexiconEngine.metadata; - LexiconMarshal.save_lexicon lexicon_fname - lexicon_status.LexiconEngine.lexicon_content_rev - in - if (MatitaScript.current ())#eos && - grafite_status.GrafiteTypes.proof_status = GrafiteTypes.No_proof - then - begin - let rc = - MatitaGtkMisc.ask_confirmation - ~title:"A .moo can be generated" - ~message:(Printf.sprintf - "%s can be generated for %s.\nShould I generate it?" - (Filename.basename moo_fname) (Filename.basename fname)) - ~parent () - in - let b = - match rc with - | `YES -> true - | `NO -> false - | `CANCEL -> raise MatitaTypes.Cancel - in - if b then - save () - else - clean_current_baseuri grafite_status - end - else - clean_current_baseuri grafite_status - -let ask_unsaved parent = - MatitaGtkMisc.ask_confirmation - ~parent ~title:"Unsaved work!" - ~message:("Your work is unsaved!\n\n"^ - "Do you want to save the script before continuing?") - () - -(** Selection handling - * Two clipboards are used: "clipboard" and "primary". - * "primary" is used by X, when you hit the middle button mouse is content is - * pasted between applications. In Matita this selection always contain the - * textual version of the selected term. - * "clipboard" is used inside Matita only and support ATM two different targets: - * "TERM" and "PATTERN", in the future other targets like "MATHMLCONTENT" may - * be added - *) - -class gui () = - (* creation order _is_ relevant for windows placement *) - let main = new mainWin () in - let fileSel = new fileSelectionWin () in - let findRepl = new findReplWin () in - let develList = new develListWin () in - let newDevel = new newDevelWin () in - let keyBindingBoxes = (* event boxes which should receive global key events *) - [ main#mainWinEventBox ] - in - let console = new console ~buffer:main#logTextView#buffer () in - let (source_view: GSourceView.source_view) = - GSourceView.source_view - ~auto_indent:true - ~insert_spaces_instead_of_tabs:true ~tabs_width:2 - ~margin:80 ~show_margin:true - ~smart_home_end:true - ~packing:main#scriptScrolledWin#add - () - in - let default_font_size = - Helm_registry.get_opt_default Helm_registry.int - ~default:BuildTimeConf.default_font_size "matita.font_size" - in - let source_buffer = source_view#source_buffer in - object (self) - val mutable chosen_file = None - val mutable _ok_not_exists = false - val mutable _only_directory = false - val mutable script_fname = None - val mutable font_size = default_font_size - val mutable next_devel_must_contain = None - val mutable next_ligatures = [] - val clipboard = GData.clipboard Gdk.Atom.clipboard - val primary = GData.clipboard Gdk.Atom.primary - - initializer - (* glade's check widgets *) - List.iter (fun w -> w#check_widgets ()) - (let c w = (w :> unit>) in - [ c fileSel; c main; c findRepl]); - (* key bindings *) - List.iter (* global key bindings *) - (fun (key, callback) -> self#addKeyBinding key callback) -(* - [ GdkKeysyms._F3, - toggle_win ~check:main#showProofMenuItem proof#proofWin; - GdkKeysyms._F4, - toggle_win ~check:main#showCheckMenuItem check#checkWin; -*) - [ ]; - (* about win *) - let parse_txt_file file = - let ch = open_in (BuildTimeConf.runtime_base_dir ^ "/" ^ file) in - let l_rev = ref [] in - try - while true do - l_rev := input_line ch :: !l_rev; - done; - assert false - with - End_of_file -> - close_in ch; - List.rev !l_rev in - let about_dialog = - GWindow.about_dialog - ~authors:(parse_txt_file "AUTHORS") - (*~comments:"comments"*) - ~copyright:"Copyright (C) 2005, the HELM team" - ~license:(String.concat "\n" (parse_txt_file "LICENSE")) - ~logo:(GdkPixbuf.from_file (MatitaMisc.image_path "/matita_medium.png")) - ~name:"Matita" - ~version:BuildTimeConf.version - ~website:"http://helm.cs.unibo.it" - () - in - connect_menu_item main#aboutMenuItem about_dialog#present; - (* findRepl win *) - let show_find_Repl () = - findRepl#toplevel#misc#show (); - findRepl#toplevel#misc#grab_focus () - in - let hide_find_Repl () = findRepl#toplevel#misc#hide () in - let find_forward _ = - let highlight start end_ = - source_buffer#move_mark `INSERT ~where:start; - source_buffer#move_mark `SEL_BOUND ~where:end_; - source_view#scroll_mark_onscreen `INSERT - in - let text = findRepl#findEntry#text in - let iter = source_buffer#get_iter `SEL_BOUND in - match iter#forward_search text with - | None -> - (match source_buffer#start_iter#forward_search text with - | None -> () - | Some (start,end_) -> highlight start end_) - | Some (start,end_) -> highlight start end_ - in - let replace _ = - let text = findRepl#replaceEntry#text in - let ins = source_buffer#get_iter `INSERT in - let sel = source_buffer#get_iter `SEL_BOUND in - if ins#compare sel < 0 then - begin - ignore(source_buffer#delete_selection ()); - source_buffer#insert text - end - in - connect_button findRepl#findButton find_forward; - connect_button findRepl#findReplButton replace; - connect_button findRepl#cancelButton (fun _ -> hide_find_Repl ()); - ignore(findRepl#toplevel#event#connect#delete - ~callback:(fun _ -> hide_find_Repl ();true)); - let safe_undo = - fun () -> - (* phase 1: we save the actual status of the marks and we undo *) - let locked_mark = `MARK ((MatitaScript.current ())#locked_mark) in - let locked_iter = source_view#buffer#get_iter_at_mark locked_mark in - let locked_iter_offset = locked_iter#offset in - let mark2 = - `MARK - (source_view#buffer#create_mark ~name:"lock_point" - ~left_gravity:true locked_iter) in - source_view#source_buffer#undo (); - (* phase 2: we save the cursor position and we redo, restoring - the previous status of all the marks *) - let cursor_iter = source_view#buffer#get_iter_at_mark `INSERT in - let mark = - `MARK - (source_view#buffer#create_mark ~name:"undo_point" - ~left_gravity:true cursor_iter) - in - source_view#source_buffer#redo (); - let mark_iter = source_view#buffer#get_iter_at_mark mark in - let mark2_iter = source_view#buffer#get_iter_at_mark mark2 in - let mark2_iter = mark2_iter#set_offset locked_iter_offset in - source_view#buffer#move_mark locked_mark ~where:mark2_iter; - source_view#buffer#delete_mark mark; - source_view#buffer#delete_mark mark2; - (* phase 3: if after the undo the cursor was in the locked area, - then we move it there again and we perform a goto *) - if mark_iter#offset < locked_iter_offset then - begin - source_view#buffer#move_mark `INSERT ~where:mark_iter; - (MatitaScript.current ())#goto `Cursor (); - end; - (* phase 4: we perform again the undo. This time we are sure that - the text to undo is not locked *) - source_view#source_buffer#undo (); - source_view#misc#grab_focus () in - let safe_redo = - fun () -> - (* phase 1: we save the actual status of the marks, we redo and - we undo *) - let locked_mark = `MARK ((MatitaScript.current ())#locked_mark) in - let locked_iter = source_view#buffer#get_iter_at_mark locked_mark in - let locked_iter_offset = locked_iter#offset in - let mark2 = - `MARK - (source_view#buffer#create_mark ~name:"lock_point" - ~left_gravity:true locked_iter) in - source_view#source_buffer#redo (); - source_view#source_buffer#undo (); - (* phase 2: we save the cursor position and we restore - the previous status of all the marks *) - let cursor_iter = source_view#buffer#get_iter_at_mark `INSERT in - let mark = - `MARK - (source_view#buffer#create_mark ~name:"undo_point" - ~left_gravity:true cursor_iter) - in - let mark_iter = source_view#buffer#get_iter_at_mark mark in - let mark2_iter = source_view#buffer#get_iter_at_mark mark2 in - let mark2_iter = mark2_iter#set_offset locked_iter_offset in - source_view#buffer#move_mark locked_mark ~where:mark2_iter; - source_view#buffer#delete_mark mark; - source_view#buffer#delete_mark mark2; - (* phase 3: if after the undo the cursor is in the locked area, - then we move it there again and we perform a goto *) - if mark_iter#offset < locked_iter_offset then - begin - source_view#buffer#move_mark `INSERT ~where:mark_iter; - (MatitaScript.current ())#goto `Cursor (); - end; - (* phase 4: we perform again the redo. This time we are sure that - the text to redo is not locked *) - source_view#source_buffer#redo (); - source_view#misc#grab_focus () - in - connect_menu_item main#undoMenuItem safe_undo; - ignore(source_view#source_buffer#connect#can_undo - ~callback:main#undoMenuItem#misc#set_sensitive); - connect_menu_item main#redoMenuItem safe_redo; - ignore(source_view#source_buffer#connect#can_redo - ~callback:main#redoMenuItem#misc#set_sensitive); - ignore(source_view#connect#after#populate_popup - ~callback:(fun pre_menu -> - let menu = new GMenu.menu pre_menu in - let menuItems = menu#children in - let undoMenuItem, redoMenuItem = - match menuItems with - [undo;redo;sep1;cut;copy;paste;delete;sep2; - selectall;sep3;inputmethod;insertunicodecharacter] -> - List.iter menu#remove [ copy; cut; delete; paste ]; - undo,redo - | _ -> assert false in - let add_menu_item = - let i = ref 2 in (* last occupied position *) - fun ?label ?stock () -> - incr i; - GMenu.image_menu_item ?label ?stock ~packing:(menu#insert ~pos:!i) - () - in - let copy = add_menu_item ~stock:`COPY () in - let cut = add_menu_item ~stock:`CUT () in - let delete = add_menu_item ~stock:`DELETE () in - let paste = add_menu_item ~stock:`PASTE () in - let paste_pattern = add_menu_item ~label:"Paste as pattern" () in - copy#misc#set_sensitive self#canCopy; - cut#misc#set_sensitive self#canCut; - delete#misc#set_sensitive self#canDelete; - paste#misc#set_sensitive self#canPaste; - paste_pattern#misc#set_sensitive self#canPastePattern; - connect_menu_item copy self#copy; - connect_menu_item cut self#cut; - connect_menu_item delete self#delete; - connect_menu_item paste self#paste; - connect_menu_item paste_pattern self#pastePattern; - let new_undoMenuItem = - GMenu.image_menu_item - ~image:(GMisc.image ~stock:`UNDO ()) - ~use_mnemonic:true - ~label:"_Undo" - ~packing:(menu#insert ~pos:0) () in - new_undoMenuItem#misc#set_sensitive - (undoMenuItem#misc#get_flag `SENSITIVE); - menu#remove (undoMenuItem :> GMenu.menu_item); - connect_menu_item new_undoMenuItem safe_undo; - let new_redoMenuItem = - GMenu.image_menu_item - ~image:(GMisc.image ~stock:`REDO ()) - ~use_mnemonic:true - ~label:"_Redo" - ~packing:(menu#insert ~pos:1) () in - new_redoMenuItem#misc#set_sensitive - (redoMenuItem#misc#get_flag `SENSITIVE); - menu#remove (redoMenuItem :> GMenu.menu_item); - connect_menu_item new_redoMenuItem safe_redo)); - - connect_menu_item main#editMenu (fun () -> - main#copyMenuItem#misc#set_sensitive self#canCopy; - main#cutMenuItem#misc#set_sensitive self#canCut; - main#deleteMenuItem#misc#set_sensitive self#canDelete; - main#pasteMenuItem#misc#set_sensitive self#canPaste; - main#pastePatternMenuItem#misc#set_sensitive self#canPastePattern); - connect_menu_item main#copyMenuItem self#copy; - connect_menu_item main#cutMenuItem self#cut; - connect_menu_item main#deleteMenuItem self#delete; - connect_menu_item main#pasteMenuItem self#paste; - connect_menu_item main#pastePatternMenuItem self#pastePattern; - connect_menu_item main#selectAllMenuItem (fun () -> - source_buffer#move_mark `INSERT source_buffer#start_iter; - source_buffer#move_mark `SEL_BOUND source_buffer#end_iter); - connect_menu_item main#findReplMenuItem show_find_Repl; - connect_menu_item main#externalEditorMenuItem self#externalEditor; - connect_menu_item main#ligatureButton self#nextLigature; - ignore (findRepl#findEntry#connect#activate find_forward); - (* interface lockers *) - let lock_world _ = - main#buttonsToolbar#misc#set_sensitive false; - develList#buttonsHbox#misc#set_sensitive false; - source_view#set_editable false - in - let unlock_world _ = - main#buttonsToolbar#misc#set_sensitive true; - develList#buttonsHbox#misc#set_sensitive true; - source_view#set_editable true - in - let locker f = - fun () -> - lock_world (); - try f ();unlock_world () with exc -> unlock_world (); raise exc in - let keep_focus f = - fun () -> - try - f (); source_view#misc#grab_focus () - with - exc -> source_view#misc#grab_focus (); raise exc in - (* developments win *) - let model = - new MatitaGtkMisc.multiStringListModel - ~cols:2 develList#developmentsTreeview - in - let refresh_devels_win () = - model#list_store#clear (); - List.iter - (fun (name, root) -> model#easy_mappend [name;root]) - (MatitamakeLib.list_known_developments ()) - in - let get_devel_selected () = - match model#easy_mselection () with - | [[name;_]] -> MatitamakeLib.development_for_name name - | _ -> None - in - let refresh () = - while Glib.Main.pending () do - ignore(Glib.Main.iteration false); - done - in - connect_button develList#newButton - (fun () -> - next_devel_must_contain <- None; - newDevel#toplevel#misc#show()); - connect_button develList#deleteButton - (locker (fun () -> - (match get_devel_selected () with - | None -> () - | Some d -> MatitamakeLib.destroy_development_in_bg refresh d); - refresh_devels_win ())); - connect_button develList#buildButton - (locker (fun () -> - match get_devel_selected () with - | None -> () - | Some d -> - let build = locker - (fun () -> MatitamakeLib.build_development_in_bg refresh d) - in - ignore(build ()))); - connect_button develList#cleanButton - (locker (fun () -> - match get_devel_selected () with - | None -> () - | Some d -> - let clean = locker - (fun () -> MatitamakeLib.clean_development_in_bg refresh d) - in - ignore(clean ()))); - connect_button develList#closeButton - (fun () -> develList#toplevel#misc#hide()); - ignore(develList#toplevel#event#connect#delete - (fun _ -> develList#toplevel#misc#hide();true)); - connect_menu_item main#developmentsMenuItem - (fun () -> refresh_devels_win ();develList#toplevel#misc#show ()); - - (* add development win *) - let check_if_root_contains root = - match next_devel_must_contain with - | None -> true - | Some path -> - let is_prefix_of d1 d2 = - let len1 = String.length d1 in - let len2 = String.length d2 in - if len2 < len1 then - false - else - let pref = String.sub d2 0 len1 in - pref = d1 - in - is_prefix_of root path - in - connect_button newDevel#addButton - (fun () -> - let name = newDevel#nameEntry#text in - let root = newDevel#rootEntry#text in - if check_if_root_contains root then - begin - ignore (MatitamakeLib.initialize_development name root); - refresh_devels_win (); - newDevel#nameEntry#set_text ""; - newDevel#rootEntry#set_text ""; - newDevel#toplevel#misc#hide() - end - else - HLog.error ("The selected root does not contain " ^ - match next_devel_must_contain with - | Some x -> x - | _ -> assert false)); - connect_button newDevel#chooseRootButton - (fun () -> - let path = self#chooseDir () in - match path with - | Some path -> newDevel#rootEntry#set_text path - | None -> ()); - connect_button newDevel#cancelButton - (fun () -> newDevel#toplevel#misc#hide ()); - ignore(newDevel#toplevel#event#connect#delete - (fun _ -> newDevel#toplevel#misc#hide();true)); - - (* file selection win *) - ignore (fileSel#fileSelectionWin#event#connect#delete (fun _ -> true)); - ignore (fileSel#fileSelectionWin#connect#response (fun event -> - let return r = - chosen_file <- r; - fileSel#fileSelectionWin#misc#hide (); - GMain.Main.quit () - in - match event with - | `OK -> - let fname = fileSel#fileSelectionWin#filename in - if Sys.file_exists fname then - begin - if HExtlib.is_regular fname && not (_only_directory) then - return (Some fname) - else if _only_directory && HExtlib.is_dir fname then - return (Some fname) - end - else - begin - if _ok_not_exists then - return (Some fname) - end - | `CANCEL -> return None - | `HELP -> () - | `DELETE_EVENT -> return None)); - (* menus *) - List.iter (fun w -> w#misc#set_sensitive false) [ main#saveMenuItem ]; - (* console *) - let adj = main#logScrolledWin#vadjustment in - ignore (adj#connect#changed - (fun _ -> adj#set_value (adj#upper -. adj#page_size))); - console#message (sprintf "\tMatita version %s\n" BuildTimeConf.version); - (* toolbar *) - let module A = GrafiteAst in - let hole = CicNotationPt.UserInput in - let loc = HExtlib.dummy_floc in - let tac ast _ = - if (MatitaScript.current ())#onGoingProof () then - (MatitaScript.current ())#advance - ~statement:("\n" - ^ GrafiteAstPp.pp_tactical ~term_pp:CicNotationPp.pp_term - ~lazy_term_pp:CicNotationPp.pp_term (A.Tactic (loc, ast))) - () - in - let tac_w_term ast _ = - if (MatitaScript.current ())#onGoingProof () then - let buf = source_buffer in - buf#insert ~iter:(buf#get_iter_at_mark (`NAME "locked")) - ("\n" - ^ GrafiteAstPp.pp_tactic ~term_pp:CicNotationPp.pp_term - ~lazy_term_pp:CicNotationPp.pp_term ast) - in - let tbar = main in - connect_button tbar#introsButton (tac (A.Intros (loc, None, []))); - connect_button tbar#applyButton (tac_w_term (A.Apply (loc, hole))); - connect_button tbar#exactButton (tac_w_term (A.Exact (loc, hole))); - connect_button tbar#elimButton (tac_w_term - (A.Elim (loc, hole, None, None, []))); - connect_button tbar#elimTypeButton (tac_w_term - (A.ElimType (loc, hole, None, None, []))); - connect_button tbar#splitButton (tac (A.Split loc)); - connect_button tbar#leftButton (tac (A.Left loc)); - connect_button tbar#rightButton (tac (A.Right loc)); - connect_button tbar#existsButton (tac (A.Exists loc)); - connect_button tbar#reflexivityButton (tac (A.Reflexivity loc)); - connect_button tbar#symmetryButton (tac (A.Symmetry loc)); - connect_button tbar#transitivityButton - (tac_w_term (A.Transitivity (loc, hole))); - connect_button tbar#assumptionButton (tac (A.Assumption loc)); - connect_button tbar#cutButton (tac_w_term (A.Cut (loc, None, hole))); - connect_button tbar#autoButton (tac (A.Auto (loc,None,None,None,None))); - MatitaGtkMisc.toggle_widget_visibility - ~widget:(main#tacticsButtonsHandlebox :> GObj.widget) - ~check:main#tacticsBarMenuItem; - let module Hr = Helm_registry in - if - not (Hr.get_opt_default Hr.bool ~default:false "matita.tactics_bar") - then - main#tacticsBarMenuItem#set_active false; - MatitaGtkMisc.toggle_callback - ~callback:(function - | true -> main#toplevel#fullscreen () - | false -> main#toplevel#unfullscreen ()) - ~check:main#fullscreenMenuItem; - main#fullscreenMenuItem#set_active false; - (* log *) - HLog.set_log_callback self#console#log_callback; - GtkSignal.user_handler := - (function - | MatitaScript.ActionCancelled -> () - | exn -> - if not (Helm_registry.get_bool "matita.debug") then - let floc, msg = MatitaExcPp.to_string exn in - begin - match floc with - None -> () - | Some floc -> - let (x, y) = HExtlib.loc_of_floc floc in - let script = MatitaScript.current () in - let locked_mark = script#locked_mark in - let error_tag = script#error_tag in - let baseoffset = - (source_buffer#get_iter_at_mark (`MARK locked_mark))#offset in - let x' = baseoffset + x in - let y' = baseoffset + y in - let x_iter = source_buffer#get_iter (`OFFSET x') in - let y_iter = source_buffer#get_iter (`OFFSET y') in - source_buffer#apply_tag error_tag ~start:x_iter ~stop:y_iter; - let id = ref None in - id := Some (source_buffer#connect#changed ~callback:(fun () -> - source_buffer#remove_tag error_tag - ~start:source_buffer#start_iter - ~stop:source_buffer#end_iter; - match !id with - | None -> assert false (* a race condition occurred *) - | Some id -> - (new GObj.gobject_ops source_buffer#as_buffer)#disconnect id)); - source_buffer#place_cursor - (source_buffer#get_iter (`OFFSET x')); - end; - HLog.error msg - else raise exn); - (* script *) - ignore (source_buffer#connect#mark_set (fun _ _ -> next_ligatures <- [])); - let _ = - match GSourceView.source_language_from_file BuildTimeConf.lang_file with - | None -> - HLog.warn (sprintf "can't load language file %s" - BuildTimeConf.lang_file) - | Some matita_lang -> - source_buffer#set_language matita_lang; - source_buffer#set_highlight true - in - let s () = MatitaScript.current () in - let disableSave () = - script_fname <- None; - main#saveMenuItem#misc#set_sensitive false - in - let saveAsScript () = - let script = s () in - match self#chooseFile ~ok_not_exists:true () with - | Some f -> - script#assignFileName f; - script#saveToFile (); - console#message ("'"^f^"' saved.\n"); - self#_enableSaveTo f - | None -> () - in - let saveScript () = - match script_fname with - | None -> saveAsScript () - | Some f -> - (s ())#assignFileName f; - (s ())#saveToFile (); - console#message ("'"^f^"' saved.\n"); - in - let abandon_script () = - let lexicon_status = (s ())#lexicon_status in - let grafite_status = (s ())#grafite_status in - if source_view#buffer#modified then - (match ask_unsaved main#toplevel with - | `YES -> saveScript () - | `NO -> () - | `CANCEL -> raise MatitaTypes.Cancel); - (match script_fname with - | None -> () - | Some fname -> - ask_and_save_moo_if_needed main#toplevel fname - lexicon_status grafite_status); - in - let loadScript () = - let script = s () in - try - match self#chooseFile () with - | Some f -> - abandon_script (); - script#reset (); - script#assignFileName f; - source_view#source_buffer#begin_not_undoable_action (); - script#loadFromFile f; - source_view#source_buffer#end_not_undoable_action (); - console#message ("'"^f^"' loaded.\n"); - self#_enableSaveTo f - | None -> () - with MatitaTypes.Cancel -> () - in - let newScript () = - abandon_script (); - source_view#source_buffer#begin_not_undoable_action (); - (s ())#reset (); - (s ())#template (); - source_view#source_buffer#end_not_undoable_action (); - disableSave (); - script_fname <- None - in - let cursor () = - source_buffer#place_cursor - (source_buffer#get_iter_at_mark (`NAME "locked")) in - let advance _ = (MatitaScript.current ())#advance (); cursor () in - let retract _ = (MatitaScript.current ())#retract (); cursor () in - let top _ = (MatitaScript.current ())#goto `Top (); cursor () in - let bottom _ = (MatitaScript.current ())#goto `Bottom (); cursor () in - let jump _ = (MatitaScript.current ())#goto `Cursor (); cursor () in - let advance = locker (keep_focus advance) in - let retract = locker (keep_focus retract) in - let top = locker (keep_focus top) in - let bottom = locker (keep_focus bottom) in - let jump = locker (keep_focus jump) in - (* quit *) - self#setQuitCallback (fun () -> - let lexicon_status = (MatitaScript.current ())#lexicon_status in - let grafite_status = (MatitaScript.current ())#grafite_status in - if source_view#buffer#modified then - begin - let rc = ask_unsaved main#toplevel in - try - match rc with - | `YES -> saveScript (); - if not source_view#buffer#modified then - begin - (match script_fname with - | None -> () - | Some fname -> - ask_and_save_moo_if_needed main#toplevel - fname lexicon_status grafite_status); - GMain.Main.quit () - end - | `NO -> GMain.Main.quit () - | `CANCEL -> raise MatitaTypes.Cancel - with MatitaTypes.Cancel -> () - end - else - begin - (match script_fname with - | None -> clean_current_baseuri grafite_status; GMain.Main.quit () - | Some fname -> - try - ask_and_save_moo_if_needed main#toplevel fname lexicon_status - grafite_status; - GMain.Main.quit () - with MatitaTypes.Cancel -> ()) - end); - connect_button main#scriptAdvanceButton advance; - connect_button main#scriptRetractButton retract; - connect_button main#scriptTopButton top; - connect_button main#scriptBottomButton bottom; - connect_button main#scriptJumpButton jump; - connect_menu_item main#scriptAdvanceMenuItem advance; - connect_menu_item main#scriptRetractMenuItem retract; - connect_menu_item main#scriptTopMenuItem top; - connect_menu_item main#scriptBottomMenuItem bottom; - connect_menu_item main#scriptJumpMenuItem jump; - connect_menu_item main#openMenuItem loadScript; - connect_menu_item main#saveMenuItem saveScript; - connect_menu_item main#saveAsMenuItem saveAsScript; - connect_menu_item main#newMenuItem newScript; - (* script monospace font stuff *) - self#updateFontSize (); - (* debug menu *) - main#debugMenu#misc#hide (); - (* status bar *) - main#hintLowImage#set_file (image_path "matita-bulb-low.png"); - main#hintMediumImage#set_file (image_path "matita-bulb-medium.png"); - main#hintHighImage#set_file (image_path "matita-bulb-high.png"); - (* focus *) - self#sourceView#misc#grab_focus (); - (* main win dimension *) - let width = Gdk.Screen.width () in - let height = Gdk.Screen.height () in - let main_w = width * 90 / 100 in - let main_h = height * 80 / 100 in - let script_w = main_w * 6 / 10 in - main#toplevel#resize ~width:main_w ~height:main_h; - main#hpaneScriptSequent#set_position script_w; - (* source_view *) - ignore(source_view#connect#after#paste_clipboard - ~callback:(fun () -> (MatitaScript.current ())#clean_dirty_lock)); - (* clean_locked is set to true only "during" a PRIMARY paste - operation (i.e. by clicking with the second mouse button) *) - let clean_locked = ref false in - ignore(source_view#event#connect#button_press - ~callback: - (fun button -> - if GdkEvent.Button.button button = 2 then - clean_locked := true; - false - )); - ignore(source_view#event#connect#button_release - ~callback:(fun button -> clean_locked := false; false)); - ignore(source_view#buffer#connect#after#apply_tag - ~callback:( - fun tag ~start:_ ~stop:_ -> - if !clean_locked && - tag#get_oid = (MatitaScript.current ())#locked_tag#get_oid - then - begin - clean_locked := false; - (MatitaScript.current ())#clean_dirty_lock; - clean_locked := true - end)); - (* math view handling *) - connect_menu_item main#newCicBrowserMenuItem (fun () -> - ignore (MatitaMathView.cicBrowser ())); - connect_menu_item main#increaseFontSizeMenuItem (fun () -> - self#increaseFontSize (); - MatitaMathView.increase_font_size (); - MatitaMathView.update_font_sizes ()); - connect_menu_item main#decreaseFontSizeMenuItem (fun () -> - self#decreaseFontSize (); - MatitaMathView.decrease_font_size (); - MatitaMathView.update_font_sizes ()); - connect_menu_item main#normalFontSizeMenuItem (fun () -> - self#resetFontSize (); - MatitaMathView.reset_font_size (); - MatitaMathView.update_font_sizes ()); - MatitaMathView.reset_font_size (); - - (** selections / clipboards handling *) - - method markupSelected = MatitaMathView.has_selection () - method private textSelected = - (source_buffer#get_iter_at_mark `INSERT)#compare - (source_buffer#get_iter_at_mark `SEL_BOUND) <> 0 - method private somethingSelected = self#markupSelected || self#textSelected - method private markupStored = MatitaMathView.has_clipboard () - method private textStored = clipboard#text <> None - method private somethingStored = self#markupStored || self#textStored - - method canCopy = self#somethingSelected - method canCut = self#textSelected - method canDelete = self#textSelected - method canPaste = self#somethingStored - method canPastePattern = self#markupStored - - method copy () = - if self#textSelected - then begin - MatitaMathView.empty_clipboard (); - source_view#buffer#copy_clipboard clipboard; - end else - MatitaMathView.copy_selection () - method cut () = - source_view#buffer#cut_clipboard clipboard; - MatitaMathView.empty_clipboard () - method delete () = ignore (source_view#buffer#delete_selection ()) - method paste () = - if MatitaMathView.has_clipboard () - then source_view#buffer#insert (MatitaMathView.paste_clipboard `Term) - else source_view#buffer#paste_clipboard clipboard; - (MatitaScript.current ())#clean_dirty_lock - method pastePattern () = - source_view#buffer#insert (MatitaMathView.paste_clipboard `Pattern) - - method private nextLigature () = - let iter = source_buffer#get_iter_at_mark `INSERT in - let write_ligature len s = - source_buffer#delete ~start:iter ~stop:(iter#copy#backward_chars len); - source_buffer#insert ~iter:(source_buffer#get_iter_at_mark `INSERT) s - in - let get_ligature word = - let len = String.length word in - let aux_tex () = - try - for i = len - 1 downto 0 do - if HExtlib.is_alpha word.[i] then () - else - (if word.[i] = '\\' then raise (Found i) else raise (Found ~-1)) - done; - None - with Found i -> - if i = ~-1 then None else Some (String.sub word i (len - i)) - in - let aux_ligature () = - try - for i = len - 1 downto 0 do - if CicNotationLexer.is_ligature_char word.[i] then () - else raise (Found (i+1)) - done; - raise (Found 0) - with - | Found i -> - (try - Some (String.sub word i (len - i)) - with Invalid_argument _ -> None) - in - match aux_tex () with - | Some macro -> macro - | None -> (match aux_ligature () with Some l -> l | None -> word) - in - (match next_ligatures with - | [] -> (* find ligatures and fill next_ligatures, then try again *) - let last_word = - iter#get_slice - ~stop:(iter#copy#backward_find_char Glib.Unichar.isspace) - in - let ligature = get_ligature last_word in - (match CicNotationLexer.lookup_ligatures ligature with - | [] -> () - | hd :: tl -> - write_ligature (String.length ligature) hd; - next_ligatures <- tl @ [ hd ]) - | hd :: tl -> - write_ligature 1 hd; - next_ligatures <- tl @ [ hd ]) - - method private externalEditor () = - let cmd = Helm_registry.get "matita.external_editor" in -(* ZACK uncomment to enable interactive ask of external editor command *) -(* let cmd = - let msg = - "External editor command: -%f will be substitute for the script name, -%p for the cursor position in bytes, -%l for the execution point in bytes." - in - ask_text ~gui:self ~title:"External editor" ~msg ~multiline:false - ~default:(Helm_registry.get "matita.external_editor") () - in *) - let fname = (MatitaScript.current ())#filename in - let slice mark = - source_buffer#start_iter#get_slice - ~stop:(source_buffer#get_iter_at_mark mark) - in - let script = MatitaScript.current () in - let locked = `MARK script#locked_mark in - let string_pos mark = string_of_int (String.length (slice mark)) in - let cursor_pos = string_pos `INSERT in - let locked_pos = string_pos locked in - let cmd = - Pcre.replace ~pat:"%f" ~templ:fname - (Pcre.replace ~pat:"%p" ~templ:cursor_pos - (Pcre.replace ~pat:"%l" ~templ:locked_pos - cmd)) - in - let locked_before = slice locked in - let locked_offset = (source_buffer#get_iter_at_mark locked)#offset in - ignore (Unix.system cmd); - source_buffer#set_text (HExtlib.input_file fname); - let locked_iter = source_buffer#get_iter (`OFFSET locked_offset) in - source_buffer#move_mark locked locked_iter; - source_buffer#apply_tag script#locked_tag - ~start:source_buffer#start_iter ~stop:locked_iter; - let locked_after = slice locked in - let line = ref 0 in - let col = ref 0 in - try - for i = 0 to String.length locked_before - 1 do - if locked_before.[i] <> locked_after.[i] then begin - source_buffer#place_cursor - ~where:(source_buffer#get_iter (`LINEBYTE (!line, !col))); - script#goto `Cursor (); - raise Exit - end else if locked_before.[i] = '\n' then begin - incr line; - col := 0 - end - done - with - | Exit -> () - | Invalid_argument _ -> script#goto `Bottom () - - method loadScript file = - let script = MatitaScript.current () in - script#reset (); - script#assignFileName file; - let content = - if Sys.file_exists file then file - else BuildTimeConf.script_template - in - source_view#source_buffer#begin_not_undoable_action (); - script#loadFromFile content; - source_view#source_buffer#end_not_undoable_action (); - console#message ("'"^file^"' loaded."); - self#_enableSaveTo file - - method setStar name b = - let l = main#scriptLabel in - if b then - l#set_text (name ^ " *") - else - l#set_text (name) - - method private _enableSaveTo file = - script_fname <- Some file; - self#main#saveMenuItem#misc#set_sensitive true - - method console = console - method sourceView: GSourceView.source_view = - (source_view: GSourceView.source_view) - method fileSel = fileSel - method findRepl = findRepl - method main = main - method develList = develList - method newDevel = newDevel - - method newBrowserWin () = - object (self) - inherit browserWin () - val combo = GEdit.combo_box_entry () - initializer - self#check_widgets (); - let combo_widget = combo#coerce in - uriHBox#pack ~from:`END ~fill:true ~expand:true combo_widget; - combo#entry#misc#grab_focus () - method browserUri = combo - end - - method newUriDialog () = - let dialog = new uriChoiceDialog () in - dialog#check_widgets (); - dialog - - method newRecordDialog () = - let dialog = new recordChoiceDialog () in - dialog#check_widgets (); - dialog - - method newConfirmationDialog () = - let dialog = new confirmationDialog () in - dialog#check_widgets (); - dialog - - method newEmptyDialog () = - let dialog = new emptyDialog () in - dialog#check_widgets (); - dialog - - method private addKeyBinding key callback = - List.iter (fun evbox -> add_key_binding key callback evbox) - keyBindingBoxes - - method setQuitCallback callback = - connect_menu_item main#quitMenuItem callback; - ignore (main#toplevel#event#connect#delete - (fun _ -> callback ();true)); - self#addKeyBinding GdkKeysyms._q callback - - method chooseFile ?(ok_not_exists = false) () = - _ok_not_exists <- ok_not_exists; - _only_directory <- false; - fileSel#fileSelectionWin#show (); - GtkThread.main (); - chosen_file - - method private chooseDir ?(ok_not_exists = false) () = - _ok_not_exists <- ok_not_exists; - _only_directory <- true; - fileSel#fileSelectionWin#show (); - GtkThread.main (); - (* we should check that this is a directory *) - chosen_file - - method createDevelopment ~containing = - next_devel_must_contain <- containing; - newDevel#toplevel#misc#show() - - method askText ?(title = "") ?(msg = "") () = - let dialog = new textDialog () in - dialog#textDialog#set_title title; - dialog#textDialogLabel#set_label msg; - let text = ref None in - let return v = - text := v; - dialog#textDialog#destroy (); - GMain.Main.quit () - in - ignore (dialog#textDialog#event#connect#delete (fun _ -> true)); - connect_button dialog#textDialogCancelButton (fun _ -> return None); - connect_button dialog#textDialogOkButton (fun _ -> - let text = dialog#textDialogTextView#buffer#get_text () in - return (Some text)); - dialog#textDialog#show (); - GtkThread.main (); - !text - - method private updateFontSize () = - self#sourceView#misc#modify_font_by_name - (sprintf "%s %d" BuildTimeConf.script_font font_size) - - method increaseFontSize () = - font_size <- font_size + 1; - self#updateFontSize () - - method decreaseFontSize () = - font_size <- font_size - 1; - self#updateFontSize () - - method resetFontSize () = - font_size <- default_font_size; - self#updateFontSize () - - end - -let gui () = - let g = new gui () in - gui_instance := Some g; - MatitaMathView.set_gui g; - g - -let instance = singleton gui - -let non p x = not (p x) - -(* this is a shit and should be changed :-{ *) -let interactive_uri_choice - ?(selection_mode:[`SINGLE|`MULTIPLE] = `MULTIPLE) ?(title = "") - ?(msg = "") ?(nonvars_button = false) ?(hide_uri_entry=false) - ?(hide_try=false) ?(ok_label="_Auto") ?(ok_action:[`SELECT|`AUTO] = `AUTO) - ?copy_cb () - ~id uris -= - let gui = instance () in - let nonvars_uris = lazy (List.filter (non UriManager.uri_is_var) uris) in - if (selection_mode <> `SINGLE) && - (Helm_registry.get_bool "matita.auto_disambiguation") - then - Lazy.force nonvars_uris - else begin - let dialog = gui#newUriDialog () in - if hide_uri_entry then - dialog#uriEntryHBox#misc#hide (); - if hide_try then - begin - dialog#uriChoiceSelectedButton#misc#hide (); - dialog#uriChoiceConstantsButton#misc#hide (); - end; - dialog#okLabel#set_label ok_label; - dialog#uriChoiceTreeView#selection#set_mode - (selection_mode :> Gtk.Tags.selection_mode); - let model = new stringListModel dialog#uriChoiceTreeView in - let choices = ref None in - (match copy_cb with - | None -> () - | Some cb -> - dialog#copyButton#misc#show (); - connect_button dialog#copyButton - (fun _ -> - match model#easy_selection () with - | [u] -> (cb u) - | _ -> ())); - dialog#uriChoiceDialog#set_title title; - dialog#uriChoiceLabel#set_text msg; - List.iter model#easy_append (List.map UriManager.string_of_uri uris); - dialog#uriChoiceConstantsButton#misc#set_sensitive nonvars_button; - let return v = - choices := v; - dialog#uriChoiceDialog#destroy (); - GMain.Main.quit () - in - ignore (dialog#uriChoiceDialog#event#connect#delete (fun _ -> true)); - connect_button dialog#uriChoiceConstantsButton (fun _ -> - return (Some (Lazy.force nonvars_uris))); - if ok_action = `AUTO then - connect_button dialog#uriChoiceAutoButton (fun _ -> - Helm_registry.set_bool "matita.auto_disambiguation" true; - return (Some (Lazy.force nonvars_uris))) - else - connect_button dialog#uriChoiceAutoButton (fun _ -> - match model#easy_selection () with - | [] -> () - | uris -> return (Some (List.map UriManager.uri_of_string uris))); - connect_button dialog#uriChoiceSelectedButton (fun _ -> - match model#easy_selection () with - | [] -> () - | uris -> return (Some (List.map UriManager.uri_of_string uris))); - connect_button dialog#uriChoiceAbortButton (fun _ -> return None); - dialog#uriChoiceDialog#show (); - GtkThread.main (); - (match !choices with - | None -> raise MatitaTypes.Cancel - | Some uris -> uris) - end - -class interpModel = - let cols = new GTree.column_list in - let id_col = cols#add Gobject.Data.string in - let dsc_col = cols#add Gobject.Data.string in - let interp_no_col = cols#add Gobject.Data.int in - let tree_store = GTree.tree_store cols in - let id_renderer = GTree.cell_renderer_text [], ["text", id_col] in - let dsc_renderer = GTree.cell_renderer_text [], ["text", dsc_col] in - let id_view_col = GTree.view_column ~renderer:id_renderer () in - let dsc_view_col = GTree.view_column ~renderer:dsc_renderer () in - fun tree_view choices -> - object - initializer - tree_view#set_model (Some (tree_store :> GTree.model)); - ignore (tree_view#append_column id_view_col); - ignore (tree_view#append_column dsc_view_col); - let name_of_interp = - (* try to find a reasonable name for an interpretation *) - let idx = ref 0 in - fun interp -> - try - List.assoc "0" interp - with Not_found -> - incr idx; string_of_int !idx - in - tree_store#clear (); - let idx = ref ~-1 in - List.iter - (fun interp -> - incr idx; - let interp_row = tree_store#append () in - tree_store#set ~row:interp_row ~column:id_col - (name_of_interp interp); - tree_store#set ~row:interp_row ~column:interp_no_col !idx; - List.iter - (fun (id, dsc) -> - let row = tree_store#append ~parent:interp_row () in - tree_store#set ~row ~column:id_col id; - tree_store#set ~row ~column:dsc_col dsc; - tree_store#set ~row ~column:interp_no_col !idx) - interp) - choices - - method get_interp_no tree_path = - let iter = tree_store#get_iter tree_path in - tree_store#get ~row:iter ~column:interp_no_col - end - -let interactive_interp_choice () choices = - let gui = instance () in - assert (choices <> []); - let dialog = gui#newRecordDialog () in - let model = new interpModel dialog#recordChoiceTreeView choices in - dialog#recordChoiceDialog#set_title "Interpretation choice"; - dialog#recordChoiceDialogLabel#set_label "Choose an interpretation:"; - let interp_no = ref None in - let return _ = - dialog#recordChoiceDialog#destroy (); - GMain.Main.quit () - in - let fail _ = interp_no := None; return () in - ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true)); - connect_button dialog#recordChoiceOkButton (fun _ -> - match !interp_no with None -> () | Some _ -> return ()); - connect_button dialog#recordChoiceCancelButton fail; - ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ -> - interp_no := Some (model#get_interp_no path); - return ())); - let selection = dialog#recordChoiceTreeView#selection in - ignore (selection#connect#changed (fun _ -> - match selection#get_selected_rows with - | [path] -> interp_no := Some (model#get_interp_no path) - | _ -> assert false)); - dialog#recordChoiceDialog#show (); - GtkThread.main (); - (match !interp_no with Some row -> [row] | _ -> raise MatitaTypes.Cancel) - -let _ = - (* disambiguator callbacks *) - GrafiteDisambiguator.set_choose_uris_callback (interactive_uri_choice ()); - GrafiteDisambiguator.set_choose_interp_callback (interactive_interp_choice ()); - (* gtk initialization *) - GtkMain.Rc.add_default_file BuildTimeConf.gtkrc_file; (* loads gtk rc *) - GMathView.add_configuration_path BuildTimeConf.gtkmathview_conf; - ignore (GMain.Main.init ()) - diff --git a/helm/matita/matitaGui.mli b/helm/matita/matitaGui.mli deleted file mode 100644 index 8c9064e1d..000000000 --- a/helm/matita/matitaGui.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - - (** singleton instance of the gui *) -val instance: unit -> MatitaGuiTypes.gui - - (** {2 Disambiguation callbacks} - * Use singleton gui instance. *) - - (** @param selection_mode selection mode in uri list, default to `MULTIPLE - * @param title window title, defaults to "" - * @param msg message for the user, defaults to "" - * @param nonvars_button enable button to exclude vars?, defaults to false - * @raise MatitaTypes.Cancel *) -val interactive_uri_choice: - ?selection_mode:([`SINGLE|`MULTIPLE]) -> ?title:string -> - ?msg:string -> ?nonvars_button:bool -> - ?hide_uri_entry:bool -> ?hide_try:bool -> ?ok_label:string -> - ?ok_action:[`AUTO|`SELECT] -> - ?copy_cb:(string -> unit) -> unit -> - GrafiteDisambiguator.choose_uris_callback - - (** @raise MatitaTypes.Cancel *) -val interactive_interp_choice: - unit -> - GrafiteDisambiguator.choose_interp_callback - diff --git a/helm/matita/matitaGuiTypes.mli b/helm/matita/matitaGuiTypes.mli deleted file mode 100644 index 1b9d17cad..000000000 --- a/helm/matita/matitaGuiTypes.mli +++ /dev/null @@ -1,151 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -class type console = -object - method message: string -> unit - method error: string -> unit - method warning: string -> unit - method debug: string -> unit - method clear: unit -> unit - - method log_callback: HLog.log_callback -end - -class type browserWin = -object - inherit MatitaGeneratedGui.browserWin - method browserUri: GEdit.combo_box_entry -end - -class type gui = -object - method setQuitCallback : (unit -> unit) -> unit - - (** {2 Access to singleton instances of lower-level GTK widgets} *) - - method fileSel : MatitaGeneratedGui.fileSelectionWin - method main : MatitaGeneratedGui.mainWin - method findRepl : MatitaGeneratedGui.findReplWin - method develList: MatitaGeneratedGui.develListWin - method newDevel: MatitaGeneratedGui.newDevelWin -(* method toolbar : MatitaGeneratedGui.toolBarWin *) - - method console: console - method sourceView: GSourceView.source_view - - (** {2 Dialogs instantiation} - * methods below create a new window on each invocation. You should - * remember to destroy windows after use *) - - method newBrowserWin: unit -> browserWin - method newUriDialog: unit -> MatitaGeneratedGui.uriChoiceDialog - method newRecordDialog: unit -> MatitaGeneratedGui.recordChoiceDialog - method newConfirmationDialog: unit -> MatitaGeneratedGui.confirmationDialog - method newEmptyDialog: unit -> MatitaGeneratedGui.emptyDialog - - (** {2 Selections / clipboards handling} *) - - method canCopy: bool - method canCut: bool - method canDelete: bool - method canPaste: bool - method canPastePattern: bool - - method markupSelected: bool - - method copy: unit -> unit - method cut: unit -> unit - method delete: unit -> unit - method paste: unit -> unit - method pastePattern: unit -> unit - - (** {2 Utility methods} *) - - (** ask the used to choose a file with the file chooser - * @param ok_not_exists if set to true returns also non existent files - * (useful for save). Defaults to false *) - method chooseFile: ?ok_not_exists:bool -> unit -> string option - method createDevelopment: containing:string option -> unit - - (** prompt the user for a (multiline) text entry *) - method askText: ?title:string -> ?msg:string -> unit -> string option - - method loadScript: string -> unit - method setStar: string -> bool -> unit - - (** {3 Fonts} *) - method increaseFontSize: unit -> unit - method decreaseFontSize: unit -> unit - method resetFontSize: unit -> unit -end - -type paste_kind = [ `Term | `Pattern ] - - (** multi selection gtkMathView which handle mactions and hyperlinks. Mactions - * are handled internally. Hyperlinks are handled by calling an user provided - * callback *) -class type clickableMathView = -object - inherit GMathViewAux.multi_selection_math_view - - (** set hyperlink callback. None disable hyperlink handling *) - method set_href_callback: (string -> unit) option -> unit - - method has_selection: bool - - (** @raise Failure "no selection" *) - method strings_of_selection: (paste_kind * string) list - - method update_font_size: unit -end - -class type cicMathView = -object - inherit clickableMathView - - (** load a sequent and render it into parent widget *) - method load_sequent: Cic.metasenv -> int -> unit - - method load_object: Cic.obj -> unit -end - -class type sequentsViewer = -object - method reset: unit - method load_logo: unit - method load_logo_with_qed: unit - method load_sequents: GrafiteTypes.incomplete_proof -> unit - method goto_sequent: int -> unit (* to be called _after_ load_sequents *) -end - -class type cicBrowser = -object - method load: MatitaTypes.mathViewer_entry -> unit - (* method loadList: string list -> MatitaTypes.mathViewer_entry -> unit *) - method loadInput: string -> unit - method mathView: clickableMathView -end - diff --git a/helm/matita/matitaInit.ml b/helm/matita/matitaInit.ml deleted file mode 100644 index 53ff6b9d6..000000000 --- a/helm/matita/matitaInit.ml +++ /dev/null @@ -1,242 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -type thingsToInitilaize = - ConfigurationFile | Db | Environment | Getter | Makelib | CmdLine | Registry - -exception FailedToInitialize of thingsToInitilaize - -let wants s l = - List.iter ( - fun item -> - if not (List.exists (fun x -> x = item) l) then - raise (FailedToInitialize item)) - s - -let already_configured s l = - List.for_all (fun item -> List.exists (fun x -> x = item) l) s - -let conffile = ref BuildTimeConf.matita_conf - -let registry_defaults = - [ - "db.nodb", "false"; - "matita.system", "false"; - "matita.debug", "false"; - "matita.external_editor", "gvim -f -c 'go %p' %f"; - "matita.preserve", "false"; - "matita.quiet", "false"; - "matita.profile", "true"; - ] - -let set_registry_values = - List.iter (fun key, value -> Helm_registry.set ~key ~value) - -let fill_registry init_status = - if not (already_configured [ Registry ] init_status) then begin - set_registry_values registry_defaults; - Registry :: init_status - end else - init_status - -let load_configuration init_status = - wants [ Registry ] init_status; - if not (already_configured [ConfigurationFile] init_status) then - begin - Helm_registry.load_from !conffile; - if not (Helm_registry.has "user.name") then begin - let login = (Unix.getpwuid (Unix.getuid ())).Unix.pw_name in - Helm_registry.set "user.name" login - end; - if Helm_registry.get_bool "matita.system" then - Helm_registry.set "user.home" BuildTimeConf.runtime_base_dir; - ConfigurationFile::init_status - end - else - init_status - -let initialize_db init_status = - wants [ ConfigurationFile; CmdLine ] init_status; - if not (already_configured [ Db ] init_status) then - begin - if not (Helm_registry.get_bool "matita.system") then - MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner"); - LibraryDb.create_owner_environment (); - Db::init_status - end - else - init_status - -let initialize_makelib init_status = - wants [ConfigurationFile] init_status; - if not (already_configured [Makelib] init_status) then - begin - MatitamakeLib.initialize (); - Makelib::init_status - end - else - init_status - -let initialize_environment init_status = - wants [ConfigurationFile] init_status; - if not (already_configured [Getter;Environment] init_status) then - begin - Http_getter.init (); - CicEnvironment.set_trust (* environment trust *) - (let trust = - Helm_registry.get_opt_default Helm_registry.get_bool - ~default:true "matita.environment_trust" in - fun _ -> trust); - Getter::Environment::init_status - end - else - init_status - -let status = ref [] - -let usages = Hashtbl.create 11 -let _ = - List.iter - (fun (name, s) -> Hashtbl.replace usages name s) - [ "matitac", - sprintf "MatitaC v%s -Usage: matitac [ OPTION ... ] FILE -Options:" - BuildTimeConf.version; - "matita", - sprintf "Matita v%s -Usage: matita [ OPTION ... ] [ FILE ... ] -Options:" - BuildTimeConf.version; - "cicbrowser", - sprintf - "CIC Browser v%s -Usage: cicbrowser [ URL | WHELP QUERY ] -Options:" - BuildTimeConf.version; - "matitadep", - sprintf "MatitaDep v%s -Usage: matitadep [ OPTION ... ] FILE ... -Options:" - BuildTimeConf.version; - "matitaclean", - sprintf "MatitaClean v%s -Usage: matitaclean all - matitaclean [ (FILE | URI) ... ] -Options:" - BuildTimeConf.version; - ] -let default_usage = - sprintf "Matita v%s\nUsage: matita [ ARG ]\nOptions:" BuildTimeConf.version - -let usage () = - let basename = Filename.basename Sys.argv.(0) in - let usage_key = - try Filename.chop_extension basename with Invalid_argument _ -> basename - in - try Hashtbl.find usages usage_key with Not_found -> default_usage - -let parse_cmdline init_status = - if not (already_configured [CmdLine] init_status) then begin - let includes = ref [ BuildTimeConf.stdlib_dir ] in - let args = ref [] in - let add_l l = fun s -> l := s :: !l in - let arg_spec = - let std_arg_spec = [ - "-I", Arg.String (add_l includes), - (" Adds path to the list of searched paths for the " - ^ "include command"); - "-conffile", Arg.Set_string conffile, - (Printf.sprintf " Read configuration from filename (default: %s)" - BuildTimeConf.matita_conf); - "-q", Arg.Unit (fun () -> Helm_registry.set_bool "matita.quiet" true), - "Turn off verbose compilation"; - "-preserve", - Arg.Unit (fun () -> Helm_registry.set_bool "matita.preserve" true), - "Turns off automatic baseuri cleaning"; - "-nodb", Arg.Unit (fun () -> Helm_registry.set_bool "db.nodb" true), - ("Avoid using external database connection " - ^ "(WARNING: disable many features)"); - "-system", Arg.Unit (fun () -> - Helm_registry.set_bool "matita.system" true), - ("Act on the system library instead of the user one" - ^ "(WARNING: not for the casual user)"); - "-noprofile", - Arg.Unit (fun () -> Helm_registry.set_bool "matita.profile" false), - "Turns off profiling printings"; - ] in - let debug_arg_spec = - if BuildTimeConf.debug then - [ "-debug", - Arg.Unit (fun () -> Helm_registry.set_bool "matita.debug" true), - ("Do not catch top-level exception " - ^ "(useful for backtrace inspection)"); - ] - else [] - in - std_arg_spec @ debug_arg_spec - in - let set_list ~key l = - Helm_registry.set_list Helm_registry.of_string ~key ~value:(List.rev !l) - in - Arg.parse arg_spec (add_l args) (usage ()); - set_list ~key:"matita.includes" includes; - set_list ~key:"matita.args" args; - HExtlib.set_profiling_printings - (fun () -> Helm_registry.get_bool "matita.profile"); - CmdLine :: init_status - end else - init_status - -let die_usage () = - print_endline (usage ()); - exit 1 - -let initialize_all () = - status := - List.fold_left (fun s f -> f s) !status - [ fill_registry; - parse_cmdline; load_configuration; initialize_makelib; - initialize_db; initialize_environment ] -(* initialize_notation - (initialize_environment - (initialize_db - (initialize_makelib - (load_configuration - (parse_cmdline !status))))) *) - -let load_configuration_file () = - status := load_configuration !status - -let parse_cmdline () = - status := parse_cmdline !status - -let fill_registry () = - status := fill_registry !status - diff --git a/helm/matita/matitaInit.mli b/helm/matita/matitaInit.mli deleted file mode 100644 index 63b84b448..000000000 --- a/helm/matita/matitaInit.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - - (** {2 global initialization} *) -val initialize_all: unit -> unit - - (** {2 per-components initialization} *) -val fill_registry: unit -> unit (** fill registry with default values *) -val parse_cmdline: unit -> unit (** parse cmdline setting registry keys *) -val load_configuration_file: unit -> unit - - (** {2 Utilities} *) - - (** die nicely: exit with return code 1 printing usage error message *) -val die_usage: unit -> 'a - diff --git a/helm/matita/matitaMathView.ml b/helm/matita/matitaMathView.ml deleted file mode 100644 index e2eb22d5b..000000000 --- a/helm/matita/matitaMathView.ml +++ /dev/null @@ -1,1107 +0,0 @@ -(* Copyright (C) 2004-2005, 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/. - *) - -(* $Id$ *) - -open Printf - -open GrafiteTypes -open MatitaGtkMisc -open MatitaGuiTypes - -module Stack = Continuationals.Stack - -(** inherit from this class if you want to access current script *) -class scriptAccessor = -object (self) - method private script = MatitaScript.current () -end - -let cicBrowsers = ref [] -let gui_instance = ref None -let set_gui gui = gui_instance := Some gui -let get_gui () = - match !gui_instance with - | None -> assert false - | Some gui -> gui - -let default_font_size () = - Helm_registry.get_opt_default Helm_registry.int - ~default:BuildTimeConf.default_font_size "matita.font_size" -let current_font_size = ref ~-1 -let increase_font_size () = incr current_font_size -let decrease_font_size () = decr current_font_size -let reset_font_size () = current_font_size := default_font_size () - - (* is there any lablgtk2 constant corresponding to the various mouse - * buttons??? *) -let left_button = 1 -let middle_button = 2 -let right_button = 3 - -let near (x1, y1) (x2, y2) = - let distance = sqrt (((x2 -. x1) ** 2.) +. ((y2 -. y1) ** 2.)) in - (distance < 4.) - -let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink" -let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm" -let href_ds = Gdome.domString "href" -let xref_ds = Gdome.domString "xref" - -let domImpl = Gdome.domImplementation () - - (** Gdome.element of a MathML document whose rendering should be blank. Used - * by cicBrowser to render "about:blank" document *) -let empty_mathml = lazy ( - domImpl#createDocument ~namespaceURI:(Some DomMisc.mathml_ns) - ~qualifiedName:(Gdome.domString "math") ~doctype:None) - -let empty_boxml = lazy ( - domImpl#createDocument ~namespaceURI:(Some DomMisc.boxml_ns) - ~qualifiedName:(Gdome.domString "box") ~doctype:None) - - (** shown for goals closed by side effects *) -let closed_goal_mathml = lazy ( - domImpl#createDocumentFromURI ~uri:BuildTimeConf.closed_xml ()) - -(* ids_to_terms should not be passed here, is just for debugging *) -let find_root_id annobj id ids_to_father_ids ids_to_terms ids_to_inner_types = - let find_parent id ids = - let rec aux id = -(* (prerr_endline (sprintf "id %s = %s" id - (try - CicPp.ppterm (Hashtbl.find ids_to_terms id) - with Not_found -> "NONE"))); *) - if List.mem id ids then Some id - else - (match - (try Hashtbl.find ids_to_father_ids id with Not_found -> None) - with - | None -> None - | Some id' -> aux id') - in - aux id - in - let return_father id ids = - match find_parent id ids with - | None -> assert false - | Some parent_id -> parent_id - in - let mk_ids terms = List.map CicUtil.id_of_annterm terms in - let inner_types = - Hashtbl.fold - (fun _ types acc -> - match types.Cic2acic.annexpected with - None -> types.Cic2acic.annsynthesized :: acc - | Some ty -> ty :: types.Cic2acic.annsynthesized :: acc - ) ids_to_inner_types [] in - match annobj with - | Cic.AConstant (_, _, _, Some bo, ty, _, _) - | Cic.AVariable (_, _, Some bo, ty, _, _) - | Cic.ACurrentProof (_, _, _, _, bo, ty, _, _) -> - return_father id (mk_ids (ty :: bo :: inner_types)) - | Cic.AConstant (_, _, _, None, ty, _, _) - | Cic.AVariable (_, _, None, ty, _, _) -> - return_father id (mk_ids (ty::inner_types)) - | Cic.AInductiveDefinition _ -> - assert false (* TODO *) - - (** @return string content of a dom node having a single text child node, e.g. - * bool *) -let string_of_dom_node node = - match node#get_firstChild with - | None -> "" - | Some node -> - (try - let text = new Gdome.text_of_node node in - text#get_data#to_string - with GdomeInit.DOMCastException _ -> "") - -let name_of_hypothesis = function - | Some (Cic.Name s, _) -> s - | _ -> assert false - -let id_of_node (node: Gdome.element) = - let xref_attr = - node#getAttributeNS ~namespaceURI:helm_ns ~localName:xref_ds in - try - List.hd (HExtlib.split ~sep:' ' xref_attr#to_string) - with Failure _ -> assert false - -type selected_term = - | SelTerm of Cic.term * string option (* term, parent hypothesis (if any) *) - | SelHyp of string * Cic.context (* hypothesis, context *) - -class clickableMathView obj = -let text_width = 80 in -object (self) - inherit GMathViewAux.multi_selection_math_view obj - - val mutable href_callback: (string -> unit) option = None - method set_href_callback f = href_callback <- f - - val mutable _cic_info = None - method private set_cic_info info = _cic_info <- info - method private cic_info = _cic_info - - initializer - self#set_font_size !current_font_size; - ignore (self#connect#selection_changed self#choose_selection_cb); - ignore (self#event#connect#button_press self#button_press_cb); - ignore (self#event#connect#button_release self#button_release_cb); - ignore (self#event#connect#selection_clear self#selection_clear_cb); - ignore (self#coerce#misc#connect#selection_get self#selection_get_cb) - - val mutable button_press_x = -1. - val mutable button_press_y = -1. - val mutable selection_changed = false - - method private selection_get_cb ctxt ~info ~time = - let text = - match ctxt#target with - | "PATTERN" -> self#text_of_selection `Pattern - | "TERM" | _ -> self#text_of_selection `Term - in - match text with - | None -> () - | Some s -> ctxt#return s - - method private text_of_selection fmt = - match self#get_selections with - | [] -> None - | node :: _ -> Some (self#string_of_node ~paste_kind:fmt node) - - method private selection_clear_cb sel_event = - self#remove_selections; - (GData.clipboard Gdk.Atom.clipboard)#clear (); - false - - method private button_press_cb gdk_button = - let button = GdkEvent.Button.button gdk_button in - if button = left_button then begin - button_press_x <- GdkEvent.Button.x gdk_button; - button_press_y <- GdkEvent.Button.y gdk_button; - selection_changed <- false - end else if button = right_button then - self#popup_contextual_menu (GdkEvent.Button.time gdk_button); - false - - (** @return a pattern structure which contains pretty printed terms *) - method private tactic_text_pattern_of_selection = - match self#get_selections with - | [] -> assert false (* this method is invoked only if there's a sel. *) - | node :: _ -> - let id = id_of_node node in - let cic_info, unsh_sequent = self#get_cic_info id in - match self#get_term_by_id cic_info id with - | SelTerm (t, father_hyp) -> - let sequent = self#sequent_of_id ~paste_kind:`Pattern id in - let text = self#string_of_cic_sequent sequent in - (match father_hyp with - | None -> None, [], Some text - | Some hyp_name -> None, [ hyp_name, text ], None) - | SelHyp (hyp_name, _ctxt) -> None, [ hyp_name, "%" ], None - - method private popup_contextual_menu time = - let menu = GMenu.menu () in - let add_menu_item ?(menu = menu) ?stock ?label () = - GMenu.image_menu_item ?stock ?label ~packing:menu#append () in - let check = add_menu_item ~label:"Check" () in - let reductions_menu_item = GMenu.menu_item ~label:"βδιζ-reduce" () in - menu#append reductions_menu_item; - let reductions = GMenu.menu () in - reductions_menu_item#set_submenu reductions; - let normalize = add_menu_item ~menu:reductions ~label:"Normalize" () in - let reduce = add_menu_item ~menu:reductions ~label:"Reduce" () in - let simplify = add_menu_item ~menu:reductions ~label:"Simplify" () in - let whd = add_menu_item ~menu:reductions ~label:"Weak head" () in - menu#append (GMenu.separator_item ()); - let copy = add_menu_item ~stock:`COPY () in - let gui = get_gui () in - List.iter (fun item -> item#misc#set_sensitive gui#canCopy) - [ copy; check; normalize; reduce; simplify; whd ]; - let reduction_action kind () = - let pat = self#tactic_text_pattern_of_selection in - let statement = - let loc = HExtlib.dummy_floc in - "\n" ^ - GrafiteAstPp.pp_executable ~term_pp:(fun s -> s) - ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false) - (GrafiteAst.Tactical (loc, - GrafiteAst.Tactic (loc, GrafiteAst.Reduce (loc, kind, pat)), - Some (GrafiteAst.Semicolon loc))) in - (MatitaScript.current ())#advance ~statement () in - connect_menu_item copy gui#copy; - connect_menu_item normalize (reduction_action `Normalize); - connect_menu_item reduce (reduction_action `Reduce); - connect_menu_item simplify (reduction_action `Simpl); - connect_menu_item whd (reduction_action `Whd); - menu#popup ~button:right_button ~time - - method private button_release_cb gdk_button = - if GdkEvent.Button.button gdk_button = left_button then begin - let button_release_x = GdkEvent.Button.x gdk_button in - let button_release_y = GdkEvent.Button.y gdk_button in - if selection_changed then - () - else (* selection _not_ changed *) - if near (button_press_x, button_press_y) - (button_release_x, button_release_y) - then - let x = int_of_float button_press_x in - let y = int_of_float button_press_y in - (match self#get_element_at x y with - | None -> () - | Some elt -> - let localName = href_ds in - if elt#hasAttributeNS ~namespaceURI:xlink_ns ~localName then - self#invoke_href_callback - (elt#getAttributeNS ~namespaceURI:xlink_ns - ~localName)#to_string - gdk_button - else - ignore (self#action_toggle elt)); - end; - false - - method private invoke_href_callback href_value gdk_button = - let button = GdkEvent.Button.button gdk_button in - if button = left_button then - let time = GdkEvent.Button.time gdk_button in - match href_callback with - | None -> () - | Some f -> - (match HExtlib.split href_value with - | [ uri ] -> f uri - | uris -> - let menu = GMenu.menu () in - List.iter - (fun uri -> - let menu_item = - GMenu.menu_item ~label:uri ~packing:menu#append () in - connect_menu_item menu_item (fun () -> f uri)) - uris; - menu#popup ~button ~time) - - method private choose_selection_cb gdome_elt = - let set_selection elt = - let misc = self#coerce#misc in - self#set_selection (Some elt); - misc#add_selection_target ~target:"STRING" Gdk.Atom.primary; - ignore (misc#grab_selection Gdk.Atom.primary); - in - let rec aux elt = - if (elt#getAttributeNS ~namespaceURI:helm_ns - ~localName:xref_ds)#to_string <> "" - then - set_selection elt - else - try - (match elt#get_parentNode with - | None -> assert false - | Some p -> aux (new Gdome.element_of_node p)) - with GdomeInit.DOMCastException _ -> () - in - (match gdome_elt with - | Some elt when (elt#getAttributeNS ~namespaceURI:xlink_ns - ~localName:href_ds)#to_string <> "" -> - set_selection elt - | Some elt -> aux elt - | None -> self#set_selection None); - selection_changed <- true - - method update_font_size = self#set_font_size !current_font_size - - (** find a term by id from stored CIC infos @return either `Hyp if the id - * correspond to an hypothesis or `Term (cic, hyp) if the id correspond to a - * term. In the latter case hyp is either None (if the term is a subterm of - * the sequent conclusion) or Some hyp_name if the term belongs to an - * hypothesis *) - method private get_term_by_id cic_info id = - let unsh_item, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, _, _ = - cic_info in - let rec find_father_hyp id = - if Hashtbl.mem ids_to_hypotheses id - then Some (name_of_hypothesis (Hashtbl.find ids_to_hypotheses id)) - else - let father_id = - try Hashtbl.find ids_to_father_ids id - with Not_found -> assert false in - match father_id with - | Some id -> find_father_hyp id - | None -> None - in - try - let term = Hashtbl.find ids_to_terms id in - let father_hyp = find_father_hyp id in - SelTerm (term, father_hyp) - with Not_found -> - try - let hyp = Hashtbl.find ids_to_hypotheses id in - let _, context, _ = - match unsh_item with Some seq -> seq | None -> assert false in - let context' = MatitaMisc.list_tl_at hyp context in - SelHyp (name_of_hypothesis hyp, context') - with Not_found -> assert false - - method private find_obj_conclusion id = - match self#cic_info with - | None - | Some (_, _, _, _, _, None) -> assert false - | Some (_, ids_to_terms, _, ids_to_father_ids, ids_to_inner_types, Some annobj) -> - let id = - find_root_id annobj id ids_to_father_ids ids_to_terms ids_to_inner_types - in - (try Hashtbl.find ids_to_terms id with Not_found -> assert false) - - method private string_of_node ~(paste_kind:paste_kind) node = - if node#hasAttributeNS ~namespaceURI:helm_ns ~localName:xref_ds - then - let id = id_of_node node in - self#string_of_cic_sequent (self#sequent_of_id ~paste_kind id) - else string_of_dom_node node - - method private string_of_cic_sequent cic_sequent = - let script = MatitaScript.current () in - let metasenv = - if script#onGoingProof () then script#proofMetasenv else [] in - let _, (acic_sequent, _, _, ids_to_inner_sorts, _) = - Cic2acic.asequent_of_sequent metasenv cic_sequent in - let _, _, _, annterm = acic_sequent in - let ast, ids_to_uris = - TermAcicContent.ast_of_acic ids_to_inner_sorts annterm in - let pped_ast = TermContentPres.pp_ast ast in - let markup = CicNotationPres.render ids_to_uris pped_ast in - BoxPp.render_to_string text_width markup - - method private pattern_of term context unsh_sequent = - let context_len = List.length context in - let _, unsh_context, conclusion = unsh_sequent in - try - (match - List.nth unsh_context (List.length unsh_context - context_len - 1) - with - | None -> assert false (* can't select a restricted hypothesis *) - | Some (name, Cic.Decl ty) -> - ProofEngineHelpers.pattern_of ~term:ty [term] - | Some (name, Cic.Def (bo, _)) -> - ProofEngineHelpers.pattern_of ~term:bo [term]) - with Failure _ | Invalid_argument _ -> - ProofEngineHelpers.pattern_of ~term:conclusion [term] - - method private get_cic_info id = - match self#cic_info with - | Some ((Some unsh_sequent, _, _, _, _, _) as info) -> info, unsh_sequent - | Some ((None, _, _, _, _, _) as info) -> - let t = self#find_obj_conclusion id in - info, (~-1, [], t) (* dummy sequent for obj *) - | None -> assert false - - method private sequent_of_id ~(paste_kind:paste_kind) id = - let cic_info, unsh_sequent = self#get_cic_info id in - let cic_sequent = - match self#get_term_by_id cic_info id with - | SelTerm (t, _father_hyp) -> - let occurrences = - ProofEngineHelpers.locate_in_conjecture t unsh_sequent in - (match occurrences with - | [ context, _t ] -> - (match paste_kind with - | `Term -> ~-1, context, t - | `Pattern -> ~-1, [], self#pattern_of t context unsh_sequent) - | _ -> - HLog.error (sprintf "found %d occurrences while 1 was expected" - (List.length occurrences)); - assert false) (* since it uses physical equality *) - | SelHyp (_name, context) -> ~-1, context, Cic.Rel 1 in - cic_sequent - - method private string_of_selection ~(paste_kind:paste_kind) = - match self#get_selections with - | [] -> None - | node :: _ -> Some (self#string_of_node ~paste_kind node) - - method has_selection = self#get_selections <> [] - - (** @return an associative list format -> string with all possible selection - * formats. Rationale: in order to convert the selection to TERM or PATTERN - * format we need the sequent, the metasenv, ... keeping all of them in a - * closure would be more expensive than keeping their already converted - * forms *) - method strings_of_selection = - try - let misc = self#coerce#misc in - List.iter - (fun target -> misc#add_selection_target ~target Gdk.Atom.clipboard) - [ "TERM"; "PATTERN"; "STRING" ]; - ignore (misc#grab_selection Gdk.Atom.clipboard); - List.map - (fun paste_kind -> - paste_kind, HExtlib.unopt (self#string_of_selection ~paste_kind)) - [ `Term; `Pattern ] - with Failure _ -> failwith "no selection" - -end - -let clickableMathView ?hadjustment ?vadjustment ?font_size ?log_verbosity = - GtkBase.Widget.size_params - ~cont:(OgtkMathViewProps.pack_return (fun p -> - OgtkMathViewProps.set_params - (new clickableMathView (GtkMathViewProps.MathView_GMetaDOM.create p)) - ~font_size:None ~log_verbosity:None)) - [] - -class cicMathView obj = -object (self) - inherit clickableMathView obj - - val mutable current_mathml = None - - method load_sequent metasenv metano = - let sequent = CicUtil.lookup_meta metano metasenv in - let (mathml, unsh_sequent, - (_, (ids_to_terms, ids_to_father_ids, ids_to_hypotheses,_ ))) - = - ApplyTransformation.mml_of_cic_sequent metasenv sequent - in - self#set_cic_info - (Some (Some unsh_sequent, - ids_to_terms, ids_to_hypotheses, ids_to_father_ids, - Hashtbl.create 1, None)); - if BuildTimeConf.debug then begin - let name = "sequent_viewer.xml" in - HLog.debug ("load_sequent: dumping MathML to ./" ^ name); - ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()) - end; - self#load_root ~root:mathml#get_documentElement - - method load_object obj = - let use_diff = false in (* ZACK TODO use XmlDiff when re-rendering? *) - let (mathml, - (annobj, (ids_to_terms, ids_to_father_ids, _, ids_to_hypotheses, _, ids_to_inner_types))) - = - ApplyTransformation.mml_of_cic_object obj - in - self#set_cic_info - (Some (None, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, ids_to_inner_types, Some annobj)); - (match current_mathml with - | Some current_mathml when use_diff -> - self#freeze; - XmlDiff.update_dom ~from:current_mathml mathml; - self#thaw - | _ -> - if BuildTimeConf.debug then begin - let name = "cic_browser.xml" in - HLog.debug ("cic_browser: dumping MathML to ./" ^ name); - ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()) - end; - self#load_root ~root:mathml#get_documentElement; - current_mathml <- Some mathml); -end - -let tab_label meta_markup = - let rec aux = - function - | `Current m -> sprintf "%s" (aux m) - | `Closed m -> sprintf "%s" (aux m) - | `Shift (pos, m) -> sprintf "|%d: %s" pos (aux m) - | `Meta n -> sprintf "?%d" n - in - let markup = aux meta_markup in - (GMisc.label ~markup ~show:true ())#coerce - -let goal_of_switch = function Stack.Open g | Stack.Closed g -> g - -class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () = - object (self) - inherit scriptAccessor - - val mutable pages = 0 - val mutable switch_page_callback = None - val mutable page2goal = [] (* associative list: page no -> goal no *) - val mutable goal2page = [] (* the other way round *) - val mutable goal2win = [] (* associative list: goal no -> scrolled win *) - val mutable _metasenv = [] - val mutable scrolledWin: GBin.scrolled_window option = None - (* scrolled window to which the sequentViewer is currently attached *) - val logo = (GMisc.image - ~file:(MatitaMisc.image_path "matita_medium.png") () - :> GObj.widget) - - val logo_with_qed = (GMisc.image - ~file:(MatitaMisc.image_path "matita_small.png") () - :> GObj.widget) - - method load_logo = - notebook#set_show_tabs false; - notebook#append_page logo - - method load_logo_with_qed = - notebook#set_show_tabs false; - notebook#append_page logo_with_qed - - method reset = - cicMathView#remove_selections; - (match scrolledWin with - | Some w -> - (* removing page from the notebook will destroy all contained widget, - * we do not want the cicMathView to be destroyed as well *) - w#remove cicMathView#coerce; - scrolledWin <- None - | None -> ()); - (match switch_page_callback with - | Some id -> - GtkSignal.disconnect notebook#as_widget id; - switch_page_callback <- None - | None -> ()); - for i = 0 to pages do notebook#remove_page 0 done; - notebook#set_show_tabs true; - pages <- 0; - page2goal <- []; - goal2page <- []; - goal2win <- []; - _metasenv <- []; - self#script#setGoal None - - method load_sequents { proof = (_,metasenv,_,_) as proof; stack = stack } = - _metasenv <- metasenv; - pages <- 0; - let win goal_switch = - let w = - GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS - ~shadow_type:`IN ~show:true () - in - let reparent () = - scrolledWin <- Some w; - match cicMathView#misc#parent with - | None -> w#add cicMathView#coerce - | Some parent -> - let parent = - match cicMathView#misc#parent with - None -> assert false - | Some p -> GContainer.cast_container p - in - parent#remove cicMathView#coerce; - w#add cicMathView#coerce - in - goal2win <- (goal_switch, reparent) :: goal2win; - w#coerce - in - assert ( - let stack_goals = Stack.open_goals stack in - let proof_goals = ProofEngineTypes.goals_of_proof proof in - if - HExtlib.list_uniq (List.sort Pervasives.compare stack_goals) - <> List.sort Pervasives.compare proof_goals - then begin - prerr_endline ("STACK GOALS = " ^ String.concat " " (List.map string_of_int stack_goals)); - prerr_endline ("PROOF GOALS = " ^ String.concat " " (List.map string_of_int proof_goals)); - false - end - else true - ); - let render_switch = - function Stack.Open i ->`Meta i | Stack.Closed i ->`Closed (`Meta i) - in - let page = ref 0 in - let added_goals = ref [] in - (* goals can be duplicated on the tack due to focus, but we should avoid - * multiple labels in the user interface *) - let add_tab markup goal_switch = - let goal = Stack.goal_of_switch goal_switch in - if not (List.mem goal !added_goals) then begin - notebook#append_page ~tab_label:(tab_label markup) (win goal_switch); - page2goal <- (!page, goal_switch) :: page2goal; - goal2page <- (goal_switch, !page) :: goal2page; - incr page; - pages <- pages + 1; - added_goals := goal :: !added_goals - end - in - let add_switch _ _ (_, sw) = add_tab (render_switch sw) sw in - Stack.iter (** populate notebook with tabs *) - ~env:(fun depth tag (pos, sw) -> - let markup = - match depth, pos with - | 0, _ -> `Current (render_switch sw) - | 1, pos when Stack.head_tag stack = `BranchTag -> - `Shift (pos, render_switch sw) - | _ -> render_switch sw - in - add_tab markup sw) - ~cont:add_switch ~todo:add_switch - stack; - switch_page_callback <- - Some (notebook#connect#switch_page ~callback:(fun page -> - let goal_switch = - try List.assoc page page2goal with Not_found -> assert false - in - self#script#setGoal (Some (goal_of_switch goal_switch)); - self#render_page ~page ~goal_switch)) - - method private render_page ~page ~goal_switch = - (match goal_switch with - | Stack.Open goal -> cicMathView#load_sequent _metasenv goal - | Stack.Closed goal -> - let doc = Lazy.force closed_goal_mathml in - cicMathView#load_root ~root:doc#get_documentElement); - (try - cicMathView#set_selection None; - List.assoc goal_switch goal2win () - with Not_found -> assert false) - - method goto_sequent goal = - let goal_switch, page = - try - List.find - (function Stack.Open g, _ | Stack.Closed g, _ -> g = goal) - goal2page - with Not_found -> assert false - in - notebook#goto_page page; - self#render_page page goal_switch - - end - - (** constructors *) - -type 'widget constructor = - ?hadjustment:GData.adjustment -> - ?vadjustment:GData.adjustment -> - ?font_size:int -> - ?log_verbosity:int -> - ?width:int -> - ?height:int -> - ?packing:(GObj.widget -> unit) -> - ?show:bool -> - unit -> - 'widget - -let cicMathView ?hadjustment ?vadjustment ?font_size ?log_verbosity = - GtkBase.Widget.size_params - ~cont:(OgtkMathViewProps.pack_return (fun p -> - OgtkMathViewProps.set_params - (new cicMathView (GtkMathViewProps.MathView_GMetaDOM.create p)) - ~font_size ~log_verbosity)) - [] - -let blank_uri = BuildTimeConf.blank_uri -let current_proof_uri = BuildTimeConf.current_proof_uri - -type term_source = - [ `Ast of CicNotationPt.term - | `Cic of Cic.term * Cic.metasenv - | `String of string - ] - -class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) - () -= - let whelp_RE = Pcre.regexp "^\\s*whelp" in - let uri_RE = - Pcre.regexp - "^cic:/([^/]+/)*[^/]+\\.(con|ind|var)(#xpointer\\(\\d+(/\\d+)+\\))?$" - in - let dir_RE = Pcre.regexp "^cic:((/([^/]+/)*[^/]+(/)?)|/|)$" in - let whelp_query_RE = Pcre.regexp "^\\s*whelp\\s+([^\\s]+)\\s+(.*)$" in - let is_whelp txt = Pcre.pmatch ~rex:whelp_RE txt in - let is_uri txt = Pcre.pmatch ~rex:uri_RE txt in - let is_dir txt = Pcre.pmatch ~rex:dir_RE txt in - let gui = get_gui () in - let (win: MatitaGuiTypes.browserWin) = gui#newBrowserWin () in - let queries = ["Locate";"Hint";"Match";"Elim";"Instance"] in - let combo,_ = GEdit.combo_box_text ~strings:queries () in - let activate_combo_query input q = - let q' = String.lowercase q in - let rec aux i = function - | [] -> failwith ("Whelp query '" ^ q ^ "' not found") - | h::_ when String.lowercase h = q' -> i - | _::tl -> aux (i+1) tl - in - combo#set_active (aux 0 queries); - win#queryInputText#set_text input - in - let set_whelp_query txt = - let query, arg = - try - let q = Pcre.extract ~rex:whelp_query_RE txt in - q.(1), q.(2) - with Invalid_argument _ -> failwith "Malformed Whelp query" - in - activate_combo_query arg query - in - let toplevel = win#toplevel in - let mathView = cicMathView ~packing:win#scrolledBrowser#add () in - let fail message = - MatitaGtkMisc.report_error ~title:"Cic browser" ~message - ~parent:toplevel () - in - let tags = - [ "dir", GdkPixbuf.from_file (MatitaMisc.image_path "matita-folder.png"); - "obj", GdkPixbuf.from_file (MatitaMisc.image_path "matita-object.png") ] - in - let handle_error f = - try - f () - with exn -> - if not (Helm_registry.get_bool "matita.debug") then - fail (snd (MatitaExcPp.to_string exn)) - else raise exn - in - let handle_error' f = (fun () -> handle_error (fun () -> f ())) in - let load_easter_egg = lazy ( - win#easterEggImage#set_file (MatitaMisc.image_path "meegg.png")) - in - object (self) - inherit scriptAccessor - - (* Whelp bar queries *) - - initializer - activate_combo_query "" "locate"; - win#whelpBarComboVbox#add combo#coerce; - let start_query () = - let query = String.lowercase (List.nth queries combo#active) in - let input = win#queryInputText#text in - let statement = "whelp " ^ query ^ " " ^ input ^ "." in - (MatitaScript.current ())#advance ~statement () - in - ignore(win#queryInputText#connect#activate ~callback:start_query); - ignore(combo#connect#changed ~callback:start_query); - win#whelpBarImage#set_file (MatitaMisc.image_path "whelp.png"); - win#mathOrListNotebook#set_show_tabs false; - win#browserForwardButton#misc#set_sensitive false; - win#browserBackButton#misc#set_sensitive false; - ignore (win#browserUri#entry#connect#activate (handle_error' (fun () -> - self#loadInput win#browserUri#entry#text))); - ignore (win#browserHomeButton#connect#clicked (handle_error' (fun () -> - self#load (`About `Current_proof)))); - ignore (win#browserRefreshButton#connect#clicked - (handle_error' (self#refresh ~force:true))); - ignore (win#browserBackButton#connect#clicked (handle_error' self#back)); - ignore (win#browserForwardButton#connect#clicked - (handle_error' self#forward)); - ignore (win#toplevel#event#connect#delete (fun _ -> - let my_id = Oo.id self in - cicBrowsers := List.filter (fun b -> Oo.id b <> my_id) !cicBrowsers; - if !cicBrowsers = [] && - Helm_registry.get "matita.mode" = "cicbrowser" - then - GMain.quit (); - false)); - ignore(win#whelpResultTreeview#connect#row_activated - ~callback:(fun _ _ -> - handle_error (fun () -> self#loadInput (self#_getSelectedUri ())))); - mathView#set_href_callback (Some (fun uri -> - handle_error (fun () -> - self#load (`Uri (UriManager.uri_of_string uri))))); - self#_load (`About `Blank); - toplevel#show () - - val mutable current_entry = `About `Blank - - val model = - new MatitaGtkMisc.taggedStringListModel tags win#whelpResultTreeview - - val mutable lastDir = "" (* last loaded "directory" *) - - method mathView = (mathView :> MatitaGuiTypes.clickableMathView) - - method private _getSelectedUri () = - match model#easy_selection () with - | [sel] when is_uri sel -> sel (* absolute URI selected *) -(* | [sel] -> win#browserUri#entry#text ^ sel |+ relative URI selected +| *) - | [sel] -> lastDir ^ sel - | _ -> assert false - - (** history RATIONALE - * - * All operations about history are done using _historyFoo. - * Only toplevel functions (ATM load and loadInput) call _historyAdd. - *) - - method private _historyAdd item = - history#add item; - win#browserBackButton#misc#set_sensitive true; - win#browserForwardButton#misc#set_sensitive false - - method private _historyPrev () = - let item = history#previous in - if history#is_begin then win#browserBackButton#misc#set_sensitive false; - win#browserForwardButton#misc#set_sensitive true; - item - - method private _historyNext () = - let item = history#next in - if history#is_end then win#browserForwardButton#misc#set_sensitive false; - win#browserBackButton#misc#set_sensitive true; - item - - (** notebook RATIONALE - * - * Use only these functions to switch between the tabs - *) - method private _showMath = win#mathOrListNotebook#goto_page 0 - method private _showList = win#mathOrListNotebook#goto_page 1 - - method private back () = - try - self#_load (self#_historyPrev ()) - with MatitaMisc.History_failure -> () - - method private forward () = - try - self#_load (self#_historyNext ()) - with MatitaMisc.History_failure -> () - - (* loads a uri which can be a cic uri or an about:* uri - * @param uri string *) - method private _load ?(force=false) entry = - handle_error (fun () -> - if entry <> current_entry || entry = `About `Current_proof || force then - begin - (match entry with - | `About `Current_proof -> self#home () - | `About `Blank -> self#blank () - | `About `Us -> self#egg () - | `Check term -> self#_loadCheck term - | `Cic (term, metasenv) -> self#_loadTermCic term metasenv - | `Dir dir -> self#_loadDir dir - | `Uri uri -> self#_loadUriManagerUri uri - | `Whelp (query, results) -> - set_whelp_query query; - self#_loadList (List.map (fun r -> "obj", - UriManager.string_of_uri r) results)); - self#setEntry entry - end) - - method private blank () = - self#_showMath; - mathView#load_root (Lazy.force empty_mathml)#get_documentElement - - method private _loadCheck term = - failwith "not implemented _loadCheck"; -(* self#_showMath *) - - method private egg () = - win#mathOrListNotebook#goto_page 2; - Lazy.force load_easter_egg - - method private home () = - self#_showMath; - match self#script#grafite_status.proof_status with - | Proof (uri, metasenv, bo, ty) -> - let name = UriManager.name_of_uri (HExtlib.unopt uri) in - let obj = Cic.CurrentProof (name, metasenv, bo, ty, [], []) in - self#_loadObj obj - | Incomplete_proof { proof = (uri, metasenv, bo, ty) } -> - let name = UriManager.name_of_uri (HExtlib.unopt uri) in - let obj = Cic.CurrentProof (name, metasenv, bo, ty, [], []) in - self#_loadObj obj - | _ -> self#blank () - - (** loads a cic uri from the environment - * @param uri UriManager.uri *) - method private _loadUriManagerUri uri = - let uri = UriManager.strip_xpointer uri in - let (obj, _) = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - self#_loadObj obj - - method private _loadDir dir = - let content = Http_getter.ls dir in - let l = - List.fast_sort - Pervasives.compare - (List.map - (function - | Http_getter_types.Ls_section s -> "dir", s - | Http_getter_types.Ls_object o -> "obj", o.Http_getter_types.uri) - content) - in - lastDir <- dir; - self#_loadList l - - method private setEntry entry = - win#browserUri#entry#set_text (MatitaTypes.string_of_entry entry); - current_entry <- entry - - method private _loadObj obj = - (* showMath must be done _before_ loading the document, since if the - * widget is not mapped (hidden by the notebook) the document is not - * rendered *) - self#_showMath; - mathView#load_object obj - - method private _loadTermCic term metasenv = - let context = self#script#proofContext in - let dummyno = CicMkImplicit.new_meta metasenv [] in - let sequent = (dummyno, context, term) in - mathView#load_sequent (sequent :: metasenv) dummyno; - self#_showMath - - method private _loadList l = - model#list_store#clear (); - List.iter (fun (tag, s) -> model#easy_append ~tag s) l; - self#_showList - - (** { public methods, all must call _load!! } *) - - method load entry = - handle_error (fun () -> self#_load entry; self#_historyAdd entry) - - (** this is what the browser does when you enter a string an hit enter *) - method loadInput txt = - let txt = HExtlib.trim_blanks txt in - let fix_uri txt = - UriManager.string_of_uri - (UriManager.strip_xpointer (UriManager.uri_of_string txt)) - in - if is_whelp txt then begin - set_whelp_query txt; - (MatitaScript.current ())#advance ~statement:(txt ^ ".") () - end else begin - let entry = - match txt with - | txt when is_uri txt -> `Uri (UriManager.uri_of_string (fix_uri txt)) - | txt when is_dir txt -> `Dir (MatitaMisc.normalize_dir txt) - | txt -> - (try - MatitaTypes.entry_of_string txt - with Invalid_argument _ -> - raise - (GrafiteTypes.Command_error(sprintf "unsupported uri: %s" txt))) - in - self#_load entry; - self#_historyAdd entry - end - - (** {2 methods accessing underlying GtkMathView} *) - - method updateFontSize = mathView#set_font_size !current_font_size - - (** {2 methods used by constructor only} *) - - method win = win - method history = history - method currentEntry = current_entry - method refresh ~force () = self#_load ~force current_entry - - end - -let sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) (): - MatitaGuiTypes.sequentsViewer -= - new sequentsViewer ~notebook ~cicMathView () - -let cicBrowser () = - let size = BuildTimeConf.browser_history_size in - let rec aux history = - let browser = new cicBrowser_impl ~history () in - let win = browser#win in - ignore (win#browserNewButton#connect#clicked (fun () -> - let history = - new MatitaMisc.browser_history ~memento:history#save size - (`About `Blank) - in - let newBrowser = aux history in - newBrowser#load browser#currentEntry)); -(* - (* attempt (failed) to close windows on CTRL-W ... *) - MatitaGtkMisc.connect_key win#browserWinEventBox#event ~modifiers:[`CONTROL] - GdkKeysyms._W (fun () -> win#toplevel#destroy ()); -*) - cicBrowsers := browser :: !cicBrowsers; - (browser :> MatitaGuiTypes.cicBrowser) - in - let history = new MatitaMisc.browser_history size (`About `Blank) in - aux history - -let default_cicMathView () = cicMathView ~show:true () -let cicMathView_instance = MatitaMisc.singleton default_cicMathView - -let default_sequentsViewer () = - let gui = get_gui () in - let cicMathView = cicMathView_instance () in - sequentsViewer ~notebook:gui#main#sequentsNotebook ~cicMathView () -let sequentsViewer_instance = MatitaMisc.singleton default_sequentsViewer - -let mathViewer () = - object(self) - method private get_browser reuse = - if reuse then - (match !cicBrowsers with - | [] -> cicBrowser () - | b :: _ -> (b :> MatitaGuiTypes.cicBrowser)) - else - (cicBrowser ()) - - method show_entry ?(reuse=false) t = (self#get_browser reuse)#load t - - method show_uri_list ?(reuse=false) ~entry l = - (self#get_browser reuse)#load entry - end - -let refresh_all_browsers () = - List.iter (fun b -> b#refresh ~force:false ()) !cicBrowsers - -let update_font_sizes () = - List.iter (fun b -> b#updateFontSize) !cicBrowsers; - (cicMathView_instance ())#update_font_size - -let get_math_views () = - ((cicMathView_instance ()) :> MatitaGuiTypes.clickableMathView) - :: (List.map (fun b -> b#mathView) !cicBrowsers) - -let find_selection_owner () = - let rec aux = - function - | [] -> raise Not_found - | mv :: tl -> - (match mv#get_selections with - | [] -> aux tl - | sel :: _ -> mv) - in - aux (get_math_views ()) - -let has_selection () = - try ignore (find_selection_owner ()); true - with Not_found -> false - -let math_view_clipboard = ref None (* associative list target -> string *) -let has_clipboard () = !math_view_clipboard <> None -let empty_clipboard () = math_view_clipboard := None - -let copy_selection () = - try - math_view_clipboard := - Some ((find_selection_owner ())#strings_of_selection) - with Not_found -> failwith "no selection" - -let paste_clipboard paste_kind = - match !math_view_clipboard with - | None -> failwith "empty clipboard" - | Some cb -> - (try List.assoc paste_kind cb with Not_found -> assert false) - diff --git a/helm/matita/matitaMathView.mli b/helm/matita/matitaMathView.mli deleted file mode 100644 index ea0c077d8..000000000 --- a/helm/matita/matitaMathView.mli +++ /dev/null @@ -1,87 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** {2 Constructors} *) - - (** meta constructor *) -type 'widget constructor = - ?hadjustment:GData.adjustment -> - ?vadjustment:GData.adjustment -> - ?font_size:int -> - ?log_verbosity:int -> - ?width:int -> - ?height:int -> - ?packing:(GObj.widget -> unit) -> - ?show:bool -> - unit -> - 'widget - -val clickableMathView: MatitaGuiTypes.clickableMathView constructor - -val cicMathView: MatitaGuiTypes.cicMathView constructor - -val sequentsViewer: - notebook:GPack.notebook -> - cicMathView:MatitaGuiTypes.cicMathView -> - unit -> - MatitaGuiTypes.sequentsViewer - -val cicBrowser: unit -> MatitaGuiTypes.cicBrowser - -(** {2 MathView wide functions} *) -(* TODO ZACK consider exporting here a single function which return a list of - * MatitaGuiTypes.clickableMathView and act on them externally ... *) - -val increase_font_size: unit -> unit -val decrease_font_size: unit -> unit -val reset_font_size: unit -> unit - -val refresh_all_browsers: unit -> unit (** act on all cicBrowsers *) -val update_font_sizes: unit -> unit - - (** {3 Clipboard & Selection handling} *) - -val has_selection: unit -> bool - - (** fills the clipboard with the current selection - * @raise Failure "no selection" *) -val copy_selection: unit -> unit -val has_clipboard: unit -> bool (** clipboard is not empty *) -val empty_clipboard: unit -> unit (** empty the clipboard *) - - (** @raise Failure "empty clipboard" *) -val paste_clipboard: MatitaGuiTypes.paste_kind -> string - -(** {2 Singleton instances} *) - -val cicMathView_instance: unit -> MatitaGuiTypes.cicMathView -val sequentsViewer_instance: unit -> MatitaGuiTypes.sequentsViewer - -val mathViewer: unit -> MatitaTypes.mathViewer - -(** {2 Initialization} *) - -val set_gui: MatitaGuiTypes.gui -> unit - diff --git a/helm/matita/matitaMisc.ml b/helm/matita/matitaMisc.ml deleted file mode 100644 index 0c4329e55..000000000 --- a/helm/matita/matitaMisc.ml +++ /dev/null @@ -1,152 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -(** Functions "imported" from Http_getter_misc *) - -let normalize_dir = Http_getter_misc.normalize_dir -let strip_suffix = Http_getter_misc.strip_suffix - -let absolute_path file = - if file.[0] = '/' then file else Unix.getcwd () ^ "/" ^ file - -let is_proof_script fname = true (** TODO Zack *) -let is_proof_object fname = true (** TODO Zack *) - -let append_phrase_sep s = - if not (Pcre.pmatch ~pat:(sprintf "%s$" BuildTimeConf.phrase_sep) s) then - s ^ BuildTimeConf.phrase_sep - else - s - -exception History_failure - -type 'a memento = 'a array * int * int * int (* data, hd, tl, cur *) - -class type ['a] history = - object - method add : 'a -> unit - method next : 'a - method previous : 'a - method load: 'a memento -> unit - method save: 'a memento - method is_begin: bool - method is_end: bool - end - -class basic_history (head, tail, cur) = - object - val mutable hd = head (* insertion point *) - val mutable tl = tail (* oldest inserted item *) - val mutable cur = cur (* current item for the history *) - - method is_begin = cur <= tl - method is_end = cur >= hd - end - - -class shell_history size = - let size = size + 1 in - let decr x = let x' = x - 1 in if x' < 0 then size + x' else x' in - let incr x = (x + 1) mod size in - object (self) - val data = Array.create size "" - - inherit basic_history (0, -1 , -1) - - method add s = - data.(hd) <- s; - if tl = -1 then tl <- hd; - hd <- incr hd; - if hd = tl then tl <- incr tl; - cur <- hd - method previous = - if cur = tl then raise History_failure; - cur <- decr cur; - data.(cur) - method next = - if cur = hd then raise History_failure; - cur <- incr cur; - if cur = hd then "" else data.(cur) - method load (data', hd', tl', cur') = - assert (Array.length data = Array.length data'); - hd <- hd'; tl <- tl'; cur <- cur'; - Array.blit data' 0 data 0 (Array.length data') - method save = (Array.copy data, hd, tl, cur) - end - -class ['a] browser_history ?memento size init = - object (self) - initializer match memento with Some m -> self#load m | _ -> () - val data = Array.create size init - - inherit basic_history (0, 0, 0) - - method previous = - if cur = tl then raise History_failure; - cur <- cur - 1; - if cur = ~-1 then cur <- size - 1; - data.(cur) - method next = - if cur = hd then raise History_failure; - cur <- cur + 1; - if cur = size then cur <- 0; - data.(cur) - method add (e:'a) = - if e <> data.(cur) then - begin - cur <- cur + 1; - if cur = size then cur <- 0; - if cur = tl then tl <- tl + 1; - if tl = size then tl <- 0; - hd <- cur; - data.(cur) <- e - end - method load (data', hd', tl', cur') = - assert (Array.length data = Array.length data'); - hd <- hd'; tl <- tl'; cur <- cur'; - Array.blit data' 0 data 0 (Array.length data') - method save = (Array.copy data, hd, tl, cur) - end - -let singleton f = - let instance = lazy (f ()) in - fun () -> Lazy.force instance - -let image_path n = sprintf "%s/%s" BuildTimeConf.images_dir n - -let end_ma_RE = Pcre.regexp "\\.ma$" - -let list_tl_at ?(equality=(==)) e l = - let rec aux = - function - | [] -> raise Not_found - | hd :: tl as l when equality hd e -> l - | hd :: tl -> aux tl - in - aux l diff --git a/helm/matita/matitaMisc.mli b/helm/matita/matitaMisc.mli deleted file mode 100644 index 170a87c9b..000000000 --- a/helm/matita/matitaMisc.mli +++ /dev/null @@ -1,75 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val absolute_path: string -> string - - (** @return true if file is a (textual) proof script *) -val is_proof_script: string -> bool - - (** @return true if file is a (binary) proof object *) -val is_proof_object: string -> bool - - (** given a phrase, if it doesn't end with BuildTimeConf.phrase_sep, append - * it *) -val append_phrase_sep: string -> string - -val normalize_dir: string -> string (** add trailing "/" if missing *) -val strip_suffix: suffix:string -> string -> string - - (** @return tl tail of a list starting at a given element - * @param eq equality to be used, defaults to physical equality (==) - * @raise Not_found *) -val list_tl_at: ?equality:('a -> 'a -> bool) -> 'a -> 'a list -> 'a list - -exception History_failure - -type 'a memento - -class type ['a] history = - object ('b) - method add : 'a -> unit - method next : 'a (** @raise History_failure *) - method previous : 'a (** @raise History_failure *) - method load: 'a memento -> unit - method save: 'a memento - method is_begin: bool - method is_end: bool - end - - (** shell like history: new items added at the end of the history - * @param size maximum history size *) -class shell_history : int -> [string] history - - (** browser like history: new items added at the current point of the history - * @param size maximum history size - * @param first element in history (this history is never empty) *) -class ['a] browser_history: ?memento:'a memento -> int -> 'a -> ['a] history - - (** create a singleton from a given function. Given function is invoked the - * first time it gets called. Next invocation will return first value *) -val singleton: (unit -> 'a) -> (unit -> 'a) - - (** given the base name of an image, returns its full path *) -val image_path: string -> string diff --git a/helm/matita/matitaScript.ml b/helm/matita/matitaScript.ml deleted file mode 100644 index 188726d95..000000000 --- a/helm/matita/matitaScript.ml +++ /dev/null @@ -1,830 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf -open GrafiteTypes - -module TA = GrafiteAst - -let debug = false -let debug_print = if debug then prerr_endline else ignore - - (** raised when one of the script margins (top or bottom) is reached *) -exception Margin -exception NoUnfinishedProof -exception ActionCancelled - -let safe_substring s i j = - try String.sub s i j with Invalid_argument _ -> assert false - -let heading_nl_RE = Pcre.regexp "^\\s*\n\\s*" -let heading_nl_RE' = Pcre.regexp "^(\\s*\n\\s*)((.|\n)*)" -let only_dust_RE = Pcre.regexp "^(\\s|\n|%%[^\n]*\n)*$" -let multiline_RE = Pcre.regexp "^\n[^\n]+$" -let newline_RE = Pcre.regexp "\n" - -let comment str = - if Pcre.pmatch ~rex:multiline_RE str then - "\n(** " ^ (Pcre.replace ~rex:newline_RE str) ^ " *)" - else - "\n(**\n" ^ str ^ "\n*)" - -let first_line s = - let s = Pcre.replace ~rex:heading_nl_RE s in - try - let nl_pos = String.index s '\n' in - String.sub s 0 nl_pos - with Not_found -> s - - (** creates a statement AST for the Goal tactic, e.g. "goal 7" *) -let goal_ast n = - let module A = GrafiteAst in - let loc = HExtlib.dummy_floc in - A.Executable (loc, A.Tactical (loc, - A.Tactic (loc, A.Goal (loc, n)), - Some (A.Dot loc))) - -type guistuff = { - mathviewer:MatitaTypes.mathViewer; - urichooser: UriManager.uri list -> UriManager.uri list; - ask_confirmation: title:string -> message:string -> [`YES | `NO | `CANCEL]; - develcreator: containing:string option -> unit; - mutable filenamedata: string option * MatitamakeLib.development option -} - -let eval_with_engine guistuff lexicon_status grafite_status user_goal - parsed_text st -= - let module TAPp = GrafiteAstPp in - let parsed_text_length = String.length parsed_text in - let initial_space,parsed_text = - try - let pieces = Pcre.extract ~rex:heading_nl_RE' parsed_text in - pieces.(1), pieces.(2) - with - Not_found -> "", parsed_text in - let inital_space,new_grafite_status,new_lexicon_status,new_status_and_text_list' = - (* the code commented out adds the "select" command if needed *) - initial_space,grafite_status,lexicon_status,[] in -(* let loc, ex = - match st with TA.Executable (loc,ex) -> loc, ex | _ -> assert false in - match grafite_status.proof_status with - | Incomplete_proof { stack = stack } - when not (List.mem user_goal (Continuationals.head_goals stack)) -> - let grafite_status = - MatitaEngine.eval_ast - ~do_heavy_checks:true grafite_status (goal_ast user_goal) - in - let initial_space = if initial_space = "" then "\n" else initial_space - in - "\n", grafite_status, - [ grafite_status, - initial_space ^ TAPp.pp_tactical (TA.Select (loc, [user_goal])) ] - | _ -> initial_space,grafite_status,[] in *) - let enriched_history_fragment = - MatitaEngine.eval_ast ~do_heavy_checks:true - new_lexicon_status new_grafite_status st - in - let _,new_text_list_rev = - let module DTE = DisambiguateTypes.Environment in - let module UM = UriManager in - List.fold_right ( - fun (_,alias) (initial_space,acc) -> - match alias with - None -> initial_space,initial_space::acc - | Some (k,((v,_) as value)) -> - let new_text = - let initial_space = - if initial_space = "" then "\n" else initial_space - in - initial_space ^ - DisambiguatePp.pp_environment - (DisambiguateTypes.Environment.add k value - DisambiguateTypes.Environment.empty) - in - "\n",new_text::acc - ) enriched_history_fragment (initial_space,[]) in - let new_text_list_rev = - match enriched_history_fragment,new_text_list_rev with - (_,None)::_, initial_space::tl -> (initial_space ^ parsed_text)::tl - | _,_ -> assert false - in - let res = - try - List.combine (fst (List.split enriched_history_fragment)) new_text_list_rev - with - Invalid_argument _ -> assert false - in - res,parsed_text_length - -let wrap_with_developments guistuff f arg = - try - f arg - with - | DependenciesParser.UnableToInclude what - | LexiconEngine.IncludedFileNotCompiled what - | GrafiteEngine.IncludedFileNotCompiled what as exc -> - let compile_needed_and_go_on d = - let target = Pcre.replace ~pat:"lexicon$" ~templ:"moo" what in - let refresh_cb () = - while Glib.Main.pending () do ignore(Glib.Main.iteration false); done - in - if not(MatitamakeLib.build_development_in_bg ~target refresh_cb d) then - raise exc - else - f arg - in - let do_nothing () = raise ActionCancelled in - let handle_with_devel d = - let name = MatitamakeLib.name_for_development d in - let title = "Unable to include " ^ what in - let message = - what ^ " is handled by development " ^ name ^ ".\n\n" ^ - "Should I compile it and Its dependencies?" - in - (match guistuff.ask_confirmation ~title ~message with - | `YES -> compile_needed_and_go_on d - | `NO -> raise exc - | `CANCEL -> do_nothing ()) - in - let handle_without_devel filename = - let title = "Unable to include " ^ what in - let message = - what ^ " is not handled by a development.\n" ^ - "All dependencies are automatically solved for a development.\n\n" ^ - "Do you want to set up a development?" - in - (match guistuff.ask_confirmation ~title ~message with - | `YES -> - (match filename with - | Some f -> - guistuff.develcreator ~containing:(Some (Filename.dirname f)) - | None -> guistuff.develcreator ~containing:None); - do_nothing () - | `NO -> raise exc - | `CANCEL -> do_nothing()) - in - match guistuff.filenamedata with - | None,None -> handle_without_devel None - | None,Some d -> handle_with_devel d - | Some f,_ -> - match MatitamakeLib.development_for_dir (Filename.dirname f) with - | None -> handle_without_devel (Some f) - | Some d -> handle_with_devel d -;; - -let eval_with_engine - guistuff lexicon_status grafite_status user_goal parsed_text st -= - wrap_with_developments guistuff - (eval_with_engine - guistuff lexicon_status grafite_status user_goal parsed_text) st -;; - -let pp_eager_statement_ast = - GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term - ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false) - -let rec eval_macro include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script mac = - let module TAPp = GrafiteAstPp in - let module MQ = MetadataQuery in - let module MDB = LibraryDb in - let module CTC = CicTypeChecker in - let module CU = CicUniv in - (* no idea why ocaml wants this *) - let parsed_text_length = String.length parsed_text in - let dbd = LibraryDb.instance () in - (* XXX use a real CIC -> string pretty printer *) - let pp_macro = TAPp.pp_macro ~term_pp:CicPp.ppterm in - match mac with - (* WHELP's stuff *) - | TA.WMatch (loc, term) -> - let l = Whelp.match_term ~dbd term in - let query_url = - MatitaMisc.strip_suffix ~suffix:"." - (HExtlib.trim_blanks unparsed_text) - in - let entry = `Whelp (query_url, l) in - guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; - [], parsed_text_length - | TA.WInstance (loc, term) -> - let l = Whelp.instance ~dbd term in - let entry = `Whelp (pp_macro (TA.WInstance (loc, term)), l) in - guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; - [], parsed_text_length - | TA.WLocate (loc, s) -> - let l = Whelp.locate ~dbd s in - let entry = `Whelp (pp_macro (TA.WLocate (loc, s)), l) in - guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; - [], parsed_text_length - | TA.WElim (loc, term) -> - let uri = - match term with - | Cic.MutInd (uri,n,_) -> UriManager.uri_of_uriref uri n None - | _ -> failwith "Not a MutInd" - in - let l = Whelp.elim ~dbd uri in - let entry = `Whelp (pp_macro (TA.WElim (loc, term)), l) in - guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; - [], parsed_text_length - | TA.WHint (loc, term) -> - let s = ((None,[0,[],term], Cic.Meta (0,[]) ,term),0) in - let l = List.map fst (MQ.experimental_hint ~dbd s) in - let entry = `Whelp (pp_macro (TA.WHint (loc, term)), l) in - guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; - [], parsed_text_length - (* REAL macro *) - | TA.Hint loc -> - let user_goal' = - match user_goal with - Some n -> n - | None -> raise NoUnfinishedProof - in - let proof = GrafiteTypes.get_current_proof grafite_status in - let proof_status = proof,user_goal' in - let l = List.map fst (MQ.experimental_hint ~dbd proof_status) in - let selected = guistuff.urichooser l in - (match selected with - | [] -> [], parsed_text_length - | [uri] -> - let suri = UriManager.string_of_uri uri in - let ast loc = - TA.Executable (loc, (TA.Tactical (loc, - TA.Tactic (loc, - TA.Apply (loc, CicNotationPt.Uri (suri, None))), - Some (TA.Dot loc)))) in - let text = - comment parsed_text ^ "\n" ^ - pp_eager_statement_ast (ast HExtlib.dummy_floc) in - let text_len = String.length text in - let loc = HExtlib.floc_of_loc (0,text_len) in - let statement = `Ast (GrafiteParser.LSome (ast loc),text) in - let res,_parsed_text_len = - eval_statement include_paths buffer guistuff lexicon_status - grafite_status user_goal script statement - in - (* we need to replace all the parsed_text *) - res,String.length parsed_text - | _ -> - HLog.error - "The result of the urichooser should be only 1 uri, not:\n"; - List.iter ( - fun u -> HLog.error (UriManager.string_of_uri u ^ "\n") - ) selected; - assert false) - | TA.Check (_,term) -> - let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in - let context = - match user_goal with - None -> [] - | Some n -> GrafiteTypes.get_proof_context grafite_status n in - let ty,_ = CTC.type_of_aux' metasenv context term CicUniv.empty_ugraph in - let t_and_ty = Cic.Cast (term,ty) in - guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv)); - [], parsed_text_length - (* TODO *) - | TA.Quit _ -> failwith "not implemented" - | TA.Print (_,kind) -> failwith "not implemented" - | TA.Search_pat (_, search_kind, str) -> failwith "not implemented" - | TA.Search_term (_, search_kind, term) -> failwith "not implemented" - -and eval_executable include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script loc ex -= - let module TAPp = GrafiteAstPp in - let module MD = GrafiteDisambiguator in - let module ML = MatitaMisc in - try - begin - match ex with - | TA.Command (_,TA.Set (_,"baseuri",u)) -> - if not (GrafiteMisc.is_empty u) then - (match - guistuff.ask_confirmation - ~title:"Baseuri redefinition" - ~message:( - "Baseuri " ^ u ^ " already exists.\n" ^ - "Do you want to redefine the corresponding "^ - "part of the library?") - with - | `YES -> - let basedir = Helm_registry.get "matita.basedir" in - LibraryClean.clean_baseuris ~basedir [u] - | `NO -> () - | `CANCEL -> raise MatitaTypes.Cancel) - | _ -> () - end; - eval_with_engine - guistuff lexicon_status grafite_status user_goal parsed_text - (TA.Executable (loc, ex)) - with - MatitaTypes.Cancel -> [], 0 - | GrafiteEngine.Macro (_loc,lazy_macro) -> - let context = - match user_goal with - None -> [] - | Some n -> GrafiteTypes.get_proof_context grafite_status n in - let grafite_status,macro = lazy_macro context in - eval_macro include_paths buffer guistuff lexicon_status grafite_status - user_goal unparsed_text parsed_text script macro - -and eval_statement include_paths (buffer : GText.buffer) guistuff lexicon_status - grafite_status user_goal script statement -= - let (lexicon_status,st), unparsed_text = - match statement with - | `Raw text -> - if Pcre.pmatch ~rex:only_dust_RE text then raise Margin; - let ast = - wrap_with_developments guistuff - (GrafiteParser.parse_statement - (Ulexing.from_utf8_string text) ~include_paths) lexicon_status - in - ast, text - | `Ast (st, text) -> (lexicon_status, st), text - in - let text_of_loc loc = - let parsed_text_length = snd (HExtlib.loc_of_floc loc) in - let parsed_text = safe_substring unparsed_text 0 parsed_text_length in - parsed_text, parsed_text_length - in - match st with - | GrafiteParser.LNone loc -> - let parsed_text, parsed_text_length = text_of_loc loc in - [(grafite_status,lexicon_status),parsed_text], - parsed_text_length - | GrafiteParser.LSome (GrafiteAst.Comment (loc, _)) -> - let parsed_text, parsed_text_length = text_of_loc loc in - let remain_len = String.length unparsed_text - parsed_text_length in - let s = String.sub unparsed_text parsed_text_length remain_len in - let s,len = - try - eval_statement include_paths buffer guistuff lexicon_status - grafite_status user_goal script (`Raw s) - with - HExtlib.Localized (floc, exn) -> - HExtlib.raise_localized_exception ~offset:parsed_text_length floc exn - | GrafiteDisambiguator.DisambiguationError (offset,errorll) -> - raise - (GrafiteDisambiguator.DisambiguationError - (offset+parsed_text_length, errorll)) - in - (match s with - | (statuses,text)::tl -> - (statuses,parsed_text ^ text)::tl,parsed_text_length + len - | [] -> [], 0) - | GrafiteParser.LSome (GrafiteAst.Executable (loc, ex)) -> - let parsed_text, parsed_text_length = text_of_loc loc in - eval_executable include_paths buffer guistuff lexicon_status - grafite_status user_goal unparsed_text parsed_text script loc ex - -let fresh_script_id = - let i = ref 0 in - fun () -> incr i; !i - -class script ~(source_view: GSourceView.source_view) - ~(mathviewer: MatitaTypes.mathViewer) - ~set_star - ~ask_confirmation - ~urichooser - ~develcreator - () = -let buffer = source_view#buffer in -let source_buffer = source_view#source_buffer in -let initial_statuses = - (* these include_paths are used only to load the initial notation *) - let include_paths = - Helm_registry.get_list Helm_registry.string "matita.includes" in - let lexicon_status = - CicNotation2.load_notation ~include_paths - BuildTimeConf.core_notation_script in - let grafite_status = GrafiteSync.init () in - grafite_status,lexicon_status -in -object (self) - val mutable include_paths = - Helm_registry.get_list Helm_registry.string "matita.includes" - - val scriptId = fresh_script_id () - - val guistuff = { - mathviewer = mathviewer; - urichooser = urichooser; - ask_confirmation = ask_confirmation; - develcreator = develcreator; - filenamedata = (None, None)} - - method private getFilename = - match guistuff.filenamedata with Some f,_ -> f | _ -> assert false - - method filename = self#getFilename - - method private ppFilename = - match guistuff.filenamedata with - | Some f,_ -> f - | None,_ -> sprintf ".unnamed%d.ma" scriptId - - initializer - ignore (GMain.Timeout.add ~ms:300000 - ~callback:(fun _ -> self#_saveToBackupFile ();true)); - ignore (buffer#connect#modified_changed - (fun _ -> set_star (Filename.basename self#ppFilename) buffer#modified)) - - val mutable statements = [] (** executed statements *) - - val mutable history = [ initial_statuses ] - (** list of states before having executed statements. Head element of this - * list is the current state, last element is the state at the beginning of - * the script. - * Invariant: this list length is 1 + length of statements *) - - (** goal as seen by the user (i.e. metano corresponding to current tab) *) - val mutable userGoal = None - - (** text mark and tag representing locked part of a script *) - val locked_mark = - buffer#create_mark ~name:"locked" ~left_gravity:true buffer#start_iter - val locked_tag = buffer#create_tag [`BACKGROUND "lightblue"; `EDITABLE false] - val error_tag = buffer#create_tag [`UNDERLINE `SINGLE; `FOREGROUND "red"] - - method locked_mark = locked_mark - method locked_tag = locked_tag - method error_tag = error_tag - - (* history can't be empty, the invariant above grant that it contains at - * least the init grafite_status *) - method grafite_status = match history with (s,_)::_ -> s | _ -> assert false - method lexicon_status = match history with (_,ss)::_ -> ss | _ -> assert false - - method private _advance ?statement () = - let s = match statement with Some s -> s | None -> self#getFuture in - HLog.debug ("evaluating: " ^ first_line s ^ " ..."); - let (entries, parsed_len) = - try - eval_statement include_paths buffer guistuff self#lexicon_status - self#grafite_status userGoal self (`Raw s) - with End_of_file -> raise Margin - in - let new_statuses, new_statements = - let statuses, texts = List.split entries in - statuses, texts - in - history <- new_statuses @ history; - statements <- new_statements @ statements; - let start = buffer#get_iter_at_mark (`MARK locked_mark) in - let new_text = String.concat "" (List.rev new_statements) in - if statement <> None then - buffer#insert ~iter:start new_text - else begin - if new_text <> String.sub s 0 parsed_len then begin - buffer#delete ~start ~stop:(start#copy#forward_chars parsed_len); - buffer#insert ~iter:start new_text; - end; - end; - self#moveMark (String.length new_text); - (* here we need to set the Goal in case we are going to cursor (or to - bottom) and we will face a macro *) - match self#grafite_status.proof_status with - Incomplete_proof p -> - userGoal <- - (try Some (Continuationals.Stack.find_goal p.stack) - with Failure _ -> None) - | _ -> userGoal <- None - - method private _retract offset lexicon_status grafite_status new_statements - new_history - = - let cur_grafite_status,cur_lexicon_status = - match history with s::_ -> s | [] -> assert false - in - LexiconSync.time_travel ~present:cur_lexicon_status ~past:lexicon_status; - GrafiteSync.time_travel ~present:cur_grafite_status ~past:grafite_status; - statements <- new_statements; - history <- new_history; - self#moveMark (- offset) - - method advance ?statement () = - try - self#_advance ?statement (); - self#notify - with - | Margin -> self#notify - | exc -> self#notify; raise exc - - method retract () = - try - let cmp,new_statements,new_history,(grafite_status,lexicon_status) = - match statements,history with - stat::statements, _::(status::_ as history) -> - String.length stat, statements, history, status - | [],[_] -> raise Margin - | _,_ -> assert false - in - self#_retract cmp lexicon_status grafite_status new_statements - new_history; - self#notify - with - | Margin -> self#notify - | exc -> self#notify; raise exc - - method private getFuture = - buffer#get_text ~start:(buffer#get_iter_at_mark (`MARK locked_mark)) - ~stop:buffer#end_iter () - - - (** @param rel_offset relative offset from current position of locked_mark *) - method private moveMark rel_offset = - let mark = `MARK locked_mark in - let old_insert = buffer#get_iter_at_mark `INSERT in - buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; - let current_mark_pos = buffer#get_iter_at_mark mark in - let new_mark_pos = - match rel_offset with - | 0 -> current_mark_pos - | n when n > 0 -> current_mark_pos#forward_chars n - | n (* when n < 0 *) -> current_mark_pos#backward_chars (abs n) - in - buffer#move_mark mark ~where:new_mark_pos; - buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:new_mark_pos; - buffer#move_mark `INSERT old_insert; - let mark_position = buffer#get_iter_at_mark mark in - if source_view#move_mark_onscreen mark then - begin - buffer#move_mark mark mark_position; - source_view#scroll_to_mark ~use_align:true ~xalign:1.0 ~yalign:0.1 mark; - end; - while Glib.Main.pending () do ignore(Glib.Main.iteration false); done - - method clean_dirty_lock = - let lock_mark_iter = buffer#get_iter_at_mark (`MARK locked_mark) in - buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; - buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:lock_mark_iter - - val mutable observers = [] - - method addObserver (o: LexiconEngine.status -> GrafiteTypes.status -> unit) = - observers <- o :: observers - - method private notify = - let lexicon_status = self#lexicon_status in - let grafite_status = self#grafite_status in - List.iter (fun o -> o lexicon_status grafite_status) observers - - method loadFromFile f = - buffer#set_text (HExtlib.input_file f); - self#reset_buffer; - buffer#set_modified false - - method assignFileName file = - let abspath = MatitaMisc.absolute_path file in - let dirname = Filename.dirname abspath in - let devel = MatitamakeLib.development_for_dir dirname in - guistuff.filenamedata <- Some abspath, devel; - let include_ = - match MatitamakeLib.development_for_dir dirname with - None -> [] - | Some devel -> [MatitamakeLib.root_for_development devel] in - let include_ = - include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes") - in - include_paths <- include_ - - method saveToFile () = - let oc = open_out self#getFilename in - output_string oc (buffer#get_text ~start:buffer#start_iter - ~stop:buffer#end_iter ()); - close_out oc; - buffer#set_modified false - - method private _saveToBackupFile () = - if buffer#modified then - begin - let f = self#ppFilename ^ "~" in - let oc = open_out f in - output_string oc (buffer#get_text ~start:buffer#start_iter - ~stop:buffer#end_iter ()); - close_out oc; - HLog.debug ("backup " ^ f ^ " saved") - end - - method private goto_top = - let grafite_status,lexicon_status = - let rec last x = function - | [] -> x - | hd::tl -> last hd tl - in - last (self#grafite_status,self#lexicon_status) history - in - (* FIXME: this is not correct since there is no undo for - * library_objects.set_default... *) - GrafiteSync.time_travel ~present:self#grafite_status ~past:grafite_status; - LexiconSync.time_travel ~present:self#lexicon_status ~past:lexicon_status - - method private reset_buffer = - statements <- []; - history <- [ initial_statuses ]; - userGoal <- None; - self#notify; - buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; - buffer#move_mark (`MARK locked_mark) ~where:buffer#start_iter - - method reset () = - self#reset_buffer; - source_buffer#begin_not_undoable_action (); - buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter; - source_buffer#end_not_undoable_action (); - buffer#set_modified false; - - method template () = - let template = HExtlib.input_file BuildTimeConf.script_template in - buffer#insert ~iter:(buffer#get_iter `START) template; - let development = MatitamakeLib.development_for_dir (Unix.getcwd ()) in - guistuff.filenamedata <- (None,development); - let include_ = - match development with - None -> [] - | Some devel -> [MatitamakeLib.root_for_development devel ] - in - let include_ = - include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes") - in - include_paths <- include_ ; - buffer#set_modified false; - set_star (Filename.basename self#ppFilename) false - - method goto (pos: [`Top | `Bottom | `Cursor]) () = - let old_locked_mark = - `MARK - (buffer#create_mark ~name:"old_locked_mark" - ~left_gravity:true (buffer#get_iter_at_mark (`MARK locked_mark))) in - let getpos _ = buffer#get_iter_at_mark (`MARK locked_mark) in - let getoldpos _ = buffer#get_iter_at_mark old_locked_mark in - let dispose_old_locked_mark () = buffer#delete_mark old_locked_mark in - match pos with - | `Top -> - dispose_old_locked_mark (); - self#goto_top; - self#reset_buffer; - self#notify - | `Bottom -> - (try - let rec dowhile () = - self#_advance (); - let newpos = getpos () in - if (getoldpos ())#compare newpos < 0 then - begin - buffer#move_mark old_locked_mark newpos; - dowhile () - end - in - dowhile (); - dispose_old_locked_mark (); - self#notify - with - | Margin -> dispose_old_locked_mark (); self#notify - | exc -> dispose_old_locked_mark (); self#notify; raise exc) - | `Cursor -> - let locked_iter () = buffer#get_iter_at_mark (`NAME "locked") in - let cursor_iter () = buffer#get_iter_at_mark `INSERT in - let remember = - `MARK - (buffer#create_mark ~name:"initial_insert" - ~left_gravity:true (cursor_iter ())) in - let dispose_remember () = buffer#delete_mark remember in - let remember_iter () = - buffer#get_iter_at_mark (`NAME "initial_insert") in - let cmp () = (locked_iter ())#offset - (remember_iter ())#offset in - let icmp = cmp () in - let forward_until_cursor () = (* go forward until locked > cursor *) - let rec aux () = - self#_advance (); - if cmp () < 0 && (getoldpos ())#compare (getpos ()) < 0 - then - begin - buffer#move_mark old_locked_mark (getpos ()); - aux () - end - in - aux () - in - let rec back_until_cursor len = (* go backward until locked < cursor *) - function - statements, ((grafite_status,lexicon_status)::_ as history) - when len <= 0 -> - self#_retract (icmp - len) lexicon_status grafite_status statements - history - | statement::tl1, _::tl2 -> - back_until_cursor (len - String.length statement) (tl1,tl2) - | _,_ -> assert false - in - (try - begin - if icmp < 0 then (* locked < cursor *) - (forward_until_cursor (); self#notify) - else if icmp > 0 then (* locked > cursor *) - (back_until_cursor icmp (statements,history); self#notify) - else (* cursor = locked *) - () - end ; - dispose_remember (); - dispose_old_locked_mark (); - with - | Margin -> dispose_remember (); dispose_old_locked_mark (); self#notify - | exc -> dispose_remember (); dispose_old_locked_mark (); - self#notify; raise exc) - - method onGoingProof () = - match self#grafite_status.proof_status with - | No_proof | Proof _ -> false - | Incomplete_proof _ -> true - | Intermediate _ -> assert false - -(* method proofStatus = MatitaTypes.get_proof_status self#status *) - method proofMetasenv = GrafiteTypes.get_proof_metasenv self#grafite_status - - method proofContext = - match userGoal with - None -> [] - | Some n -> GrafiteTypes.get_proof_context self#grafite_status n - - method proofConclusion = - match userGoal with - None -> assert false - | Some n -> - GrafiteTypes.get_proof_conclusion self#grafite_status n - - method stack = GrafiteTypes.get_stack self#grafite_status - method setGoal n = userGoal <- n - method goal = userGoal - - method eos = - let s = self#getFuture in - let rec is_there_only_comments lexicon_status s = - if Pcre.pmatch ~rex:only_dust_RE s then raise Margin; - let lexicon_status,st = - GrafiteParser.parse_statement (Ulexing.from_utf8_string s) - ~include_paths lexicon_status - in - match st with - | GrafiteParser.LSome (GrafiteAst.Comment (loc,_)) -> - let parsed_text_length = snd (HExtlib.loc_of_floc loc) in - let remain_len = String.length s - parsed_text_length in - let next = String.sub s parsed_text_length remain_len in - is_there_only_comments lexicon_status next - | GrafiteParser.LNone _ - | GrafiteParser.LSome (GrafiteAst.Executable _) -> false - in - try - is_there_only_comments self#lexicon_status s - with - | CicNotationParser.Parse_error _ -> false - | Margin | End_of_file -> true - - (* debug *) - method dump () = - HLog.debug "script status:"; - HLog.debug ("history size: " ^ string_of_int (List.length history)); - HLog.debug (sprintf "%d statements:" (List.length statements)); - List.iter HLog.debug statements; - HLog.debug ("Current file name: " ^ - (match guistuff.filenamedata with - |None,_ -> "[ no name ]" - | Some f,_ -> f)); - -end - -let _script = ref None - -let script ~source_view ~mathviewer ~urichooser ~develcreator ~ask_confirmation ~set_star () -= - let s = new script - ~source_view ~mathviewer ~ask_confirmation ~urichooser ~develcreator ~set_star () - in - _script := Some s; - s - -let current () = match !_script with None -> assert false | Some s -> s - diff --git a/helm/matita/matitaScript.mli b/helm/matita/matitaScript.mli deleted file mode 100644 index cfc465541..000000000 --- a/helm/matita/matitaScript.mli +++ /dev/null @@ -1,103 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -exception NoUnfinishedProof -exception ActionCancelled - -class type script = -object - - method locked_mark : Gtk.text_mark - method locked_tag : GText.tag - method error_tag : GText.tag - - (** @return current status *) - method lexicon_status: LexiconEngine.status - method grafite_status: GrafiteTypes.status - - (** {2 Observers} *) - - method addObserver : - (LexiconEngine.status -> GrafiteTypes.status -> unit) -> unit - - (** {2 History} *) - - method advance : ?statement:string -> unit -> unit - method retract : unit -> unit - method goto: [`Top | `Bottom | `Cursor] -> unit -> unit - method reset: unit -> unit - method template: unit -> unit - - (** {2 Load/save} *) - - method assignFileName : string -> unit (* to the current active file *) - method loadFromFile : string -> unit - method saveToFile : unit -> unit - method filename : string - - (** {2 Current proof} (if any) *) - - (** @return true if there is an ongoing proof, false otherise *) - method onGoingProof: unit -> bool - -(* method proofStatus: ProofEngineTypes.status |+* @raise Statement_error +| *) - method proofMetasenv: Cic.metasenv (** @raise Statement_error *) - method proofContext: Cic.context (** @raise Statement_error *) - method proofConclusion: Cic.term (** @raise Statement_error *) - method stack: Continuationals.Stack.t (** @raise Statement_error *) - - method setGoal: int option -> unit - method goal: int option - - (** end of script, true if the whole script has been executed *) - method eos: bool - - (** misc *) - method clean_dirty_lock: unit - - (* debug *) - method dump : unit -> unit - -end - - (** @param set_star callback used to set the modified symbol (usually a star - * "*") on the side of a script name *) -val script: - source_view:GSourceView.source_view -> - mathviewer: MatitaTypes.mathViewer-> - urichooser: (UriManager.uri list -> UriManager.uri list) -> - develcreator: (containing:string option -> unit) -> - ask_confirmation: - (title:string -> message:string -> [`YES | `NO | `CANCEL]) -> - set_star: (string -> bool -> unit) -> - unit -> - script - -(* each time script above is called an internal ref is set, instance will return - * the value of this ref *) -(* TODO Zack: orrible solution until we found a better one for having a single - * access point for the script *) -val current: unit -> script - diff --git a/helm/matita/matitaTypes.ml b/helm/matita/matitaTypes.ml deleted file mode 100644 index 13543dbb6..000000000 --- a/helm/matita/matitaTypes.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf -open GrafiteTypes - - (** user hit the cancel button *) -exception Cancel - -type abouts = - [ `Blank - | `Current_proof - | `Us - ] - -type mathViewer_entry = - [ `About of abouts (* current proof *) - | `Check of string (* term *) - | `Cic of Cic.term * Cic.metasenv - | `Dir of string (* "directory" in cic uris namespace *) - | `Uri of UriManager.uri (* cic object uri *) - | `Whelp of string * UriManager.uri list (* query and results *) - ] - -let string_of_entry = function - | `About `Blank -> "about:blank" - | `About `Current_proof -> "about:proof" - | `About `Us -> "about:us" - | `Check _ -> "check:" - | `Cic (_, _) -> "term:" - | `Dir uri -> uri - | `Uri uri -> UriManager.string_of_uri uri - | `Whelp (query, _) -> query - -let entry_of_string = function - | "about:blank" -> `About `Blank - | "about:proof" -> `About `Current_proof - | "about:us" -> `About `Us - | _ -> (* only about entries supported ATM *) - raise (Invalid_argument "entry_of_string") - -class type mathViewer = - object - (** @param reuse if set reused last opened cic browser otherwise - * opens a new one. default is false - *) - method show_entry: ?reuse:bool -> mathViewer_entry -> unit - method show_uri_list: - ?reuse:bool -> entry:mathViewer_entry -> UriManager.uri list -> unit - end diff --git a/helm/matita/matitaTypes.mli b/helm/matita/matitaTypes.mli deleted file mode 100644 index be77c4435..000000000 --- a/helm/matita/matitaTypes.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -exception Cancel - -type abouts = [ `Blank | `Current_proof | `Us ] - -type mathViewer_entry = - [ `About of abouts - | `Check of string - | `Cic of Cic.term * Cic.metasenv - | `Dir of string - | `Uri of UriManager.uri - | `Whelp of string * UriManager.uri list ] - -val string_of_entry : mathViewer_entry -> string -val entry_of_string : string -> mathViewer_entry - -class type mathViewer = - object - method show_entry : ?reuse:bool -> mathViewer_entry -> unit - method show_uri_list : - ?reuse:bool -> entry:mathViewer_entry -> UriManager.uri list -> unit - end diff --git a/helm/matita/matitac.ml b/helm/matita/matitac.ml deleted file mode 100644 index 95b500b87..000000000 --- a/helm/matita/matitac.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let main () = - match Filename.basename Sys.argv.(0) with - | "matitadep" | "matitadep.opt" -> Matitadep.main () - | "matitaclean" | "matitaclean.opt" -> Matitaclean.main () - | "matitamake" | "matitamake.opt" -> Matitamake.main () - | _ -> -(* - let _ = Paramodulation.Saturation.init () in *) -(* ALB to link paramodulation *) - let _ = MatitacLib.main `COMPILER in - () - -let _ = main () - diff --git a/helm/matita/matitacLib.ml b/helm/matita/matitacLib.ml deleted file mode 100644 index ee09258e0..000000000 --- a/helm/matita/matitacLib.ml +++ /dev/null @@ -1,267 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open GrafiteTypes - -exception AttemptToInsertAnAlias - -let pp_ast_statement = - GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term - ~lazy_term_pp:CicNotationPp.pp_term ~obj_pp:CicNotationPp.pp_obj - -(** {2 Initialization} *) - -let grafite_status = (ref None : GrafiteTypes.status option ref) -let lexicon_status = (ref None : LexiconEngine.status option ref) - -let run_script is eval_function = - let lexicon_status',grafite_status' = - match !lexicon_status,!grafite_status with - | Some ss, Some s -> ss,s - | _,_ -> assert false - in - let slash_n_RE = Pcre.regexp "\\n" in - let cb = - if Helm_registry.get_bool "matita.quiet" then - (fun _ _ -> ()) - else - (fun grafite_status stm -> - (* dump_status grafite_status; *) - let stm = pp_ast_statement stm in - let stm = Pcre.replace ~rex:slash_n_RE stm in - let stm = - if String.length stm > 50 then - String.sub stm 0 50 ^ " ..." - else - stm - in - HLog.debug ("Executing: ``" ^ stm ^ "''")) - in - try - let grafite_status'', lexicon_status'' = - match eval_function lexicon_status' grafite_status' is cb with - [] -> assert false - | (s,None)::_ -> s - | (s,Some _)::_ -> raise AttemptToInsertAnAlias - in - lexicon_status := Some lexicon_status''; - grafite_status := Some grafite_status'' - with - | GrafiteEngine.Drop - | End_of_file - | CicNotationParser.Parse_error _ as exn -> raise exn - | exn -> - HLog.error (snd (MatitaExcPp.to_string exn)); - raise exn - -let fname () = - match Helm_registry.get_list Helm_registry.string "matita.args" with - | [x] -> x - | _ -> MatitaInit.die_usage () - -let pp_ocaml_mode () = - HLog.message ""; - HLog.message " ** Entering Ocaml mode ** "; - HLog.message ""; - HLog.message "Type 'go ();;' to enter an interactive matitac"; - HLog.message "" - -let clean_exit n = - let opt_exit = - function - None -> () - | Some n -> exit n - in - match !grafite_status with - None -> opt_exit n - | Some grafite_status -> - try - let baseuri = GrafiteTypes.get_string_option grafite_status "baseuri" in - let basedir = Helm_registry.get "matita.basedir" in - LibraryClean.clean_baseuris ~basedir ~verbose:false [baseuri]; - opt_exit n - with GrafiteTypes.Option_error("baseuri", "not found") -> - (* no baseuri ==> nothing to clean yet *) - opt_exit n - -let rec interactive_loop () = - let str = Ulexing.from_utf8_channel stdin in - try - run_script str - (MatitaEngine.eval_from_stream ~first_statement_only:false ~prompt:true - ~include_paths:(Helm_registry.get_list Helm_registry.string - "matita.includes")) - with - | GrafiteEngine.Drop -> pp_ocaml_mode () - | GrafiteEngine.Macro (floc,_) -> - let x, y = HExtlib.loc_of_floc floc in - HLog.error - (sprintf "A macro has been found in a script at %d-%d" x y); - interactive_loop () - | Sys.Break -> HLog.error "user break!"; interactive_loop () - | GrafiteTypes.Command_error _ -> interactive_loop () - | End_of_file -> - print_newline (); - clean_exit (Some 0) - | HExtlib.Localized (floc,CicNotationParser.Parse_error err) -> - let x, y = HExtlib.loc_of_floc floc in - HLog.error (sprintf "Parse error at %d-%d: %s" x y err); - interactive_loop () - | exn -> HLog.error (Printexc.to_string exn); interactive_loop () - -let go () = - Helm_registry.load_from BuildTimeConf.matita_conf; - Http_getter.init (); - MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner"); - LibraryDb.create_owner_environment (); - CicEnvironment.set_trust (* environment trust *) - (let trust = - Helm_registry.get_opt_default Helm_registry.get_bool - ~default:true "matita.environment_trust" in - fun _ -> trust); - let include_paths = - Helm_registry.get_list Helm_registry.string "matita.includes" in - grafite_status := Some (GrafiteSync.init ()); - lexicon_status := - Some (CicNotation2.load_notation ~include_paths - BuildTimeConf.core_notation_script); - Sys.catch_break true; - interactive_loop () - -let main ~mode = - MatitaInit.initialize_all (); - (* must be called after init since args are set by cmdline parsing *) - let fname = fname () in - let include_paths = - Helm_registry.get_list Helm_registry.string "matita.includes" in - grafite_status := Some (GrafiteSync.init ()); - lexicon_status := - Some (CicNotation2.load_notation ~include_paths - BuildTimeConf.core_notation_script); - Sys.catch_break true; - let origcb = HLog.get_log_callback () in - let newcb tag s = - match tag with - | `Debug | `Message -> () - | `Warning | `Error -> origcb tag s - in - if Helm_registry.get_bool "matita.quiet" then - HLog.set_log_callback newcb; - let matita_debug = Helm_registry.get_bool "matita.debug" in - try - let time = Unix.time () in - if Helm_registry.get_bool "matita.quiet" then - origcb `Message ("compiling " ^ Filename.basename fname ^ "...") - else - HLog.message (sprintf "execution of %s started:" fname); - let is = - Ulexing.from_utf8_channel - (match fname with - | "stdin" -> stdin - | fname -> open_in fname) in - let include_paths = - Helm_registry.get_list Helm_registry.string "matita.includes" in - (try - run_script is - (MatitaEngine.eval_from_stream ~first_statement_only:false ~include_paths - ~clean_baseuri:(not (Helm_registry.get_bool "matita.preserve"))) - with End_of_file -> ()); - let elapsed = Unix.time () -. time in - let tm = Unix.gmtime elapsed in - let sec = string_of_int tm.Unix.tm_sec ^ "''" in - let min = - if tm.Unix.tm_min > 0 then (string_of_int tm.Unix.tm_min ^ "' ") else "" - in - let hou = - if tm.Unix.tm_hour > 0 then (string_of_int tm.Unix.tm_hour ^ "h ") else "" - in - let proof_status,moo_content_rev,metadata,lexicon_content_rev = - match !lexicon_status,!grafite_status with - | Some ss, Some s -> - s.proof_status, s.moo_content_rev, ss.LexiconEngine.metadata, - ss.LexiconEngine.lexicon_content_rev - | _,_ -> assert false - in - if proof_status <> GrafiteTypes.No_proof then - begin - HLog.error - "there are still incomplete proofs at the end of the script"; - clean_exit (Some 2) - end - else - begin - let basedir = Helm_registry.get "matita.basedir" in - let baseuri = - DependenciesParser.baseuri_of_script ~include_paths fname in - let moo_fname = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in - let lexicon_fname= LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri in - let metadata_fname = - LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri - in - GrafiteMarshal.save_moo moo_fname moo_content_rev; - LibraryNoDb.save_metadata metadata_fname metadata; - LexiconMarshal.save_lexicon lexicon_fname lexicon_content_rev; - HLog.message - (sprintf "execution of %s completed in %s." fname (hou^min^sec)); - exit 0 - end - with - | Sys.Break -> - HLog.error "user break!"; - if mode = `COMPILER then - clean_exit (Some ~-1) - else - pp_ocaml_mode () - | GrafiteEngine.Drop -> - if mode = `COMPILER then - clean_exit (Some 1) - else - pp_ocaml_mode () - | GrafiteEngine.Macro (floc,_) -> - let x, y = HExtlib.loc_of_floc floc in - HLog.error - (sprintf "A macro has been found in a script at %d-%d" x y); - if mode = `COMPILER then - clean_exit (Some 1) - else - pp_ocaml_mode () - | HExtlib.Localized (floc,CicNotationParser.Parse_error err) -> - let (x, y) = HExtlib.loc_of_floc floc in - HLog.error (sprintf "Parse error at %d-%d: %s" x y err); - if mode = `COMPILER then - clean_exit (Some 1) - else - pp_ocaml_mode () - | exn -> - if matita_debug then raise exn; - if mode = `COMPILER then - clean_exit (Some 3) - else - pp_ocaml_mode () - diff --git a/helm/matita/matitacLib.mli b/helm/matita/matitacLib.mli deleted file mode 100644 index 636c51d57..000000000 --- a/helm/matita/matitacLib.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val interactive_loop : unit -> unit - -(** go initializes the status and calls interactive_loop *) -val go : unit -> unit -val main : mode:[ `COMPILER | `TOPLEVEL ] -> unit - -(** clean_exit n - if n = Some n it performs an exit [n] after a complete clean-up of what was - partially compiled - otherwise it performs the clean-up without exiting -*) -val clean_exit : int option -> unit diff --git a/helm/matita/matitaclean.ml b/helm/matita/matitaclean.ml deleted file mode 100644 index 826a4a282..000000000 --- a/helm/matita/matitaclean.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module UM = UriManager -module TA = GrafiteAst - -let clean_suffixes = [ ".moo"; ".lexicon"; ".metadata"; ".xml.gz" ] - -let main () = - let _ = MatitaInit.initialize_all () in - let basedir = Helm_registry.get "matita.basedir" in - match Helm_registry.get_list Helm_registry.string "matita.args" with - | [ "all" ] -> - LibraryDb.clean_owner_environment (); - let xmldir = basedir ^ "/xml" in - let clean_pat = - String.concat " -o " - (List.map (fun suf -> "-name \\*" ^ suf) clean_suffixes) in - let clean_cmd = - sprintf "find %s \\( %s \\) -exec rm \\{\\} \\; 2> /dev/null" - xmldir clean_pat in - ignore (Sys.command clean_cmd); - ignore - (Sys.command ("find " ^ xmldir ^ - " -type d -exec rmdir -p {} \\; 2> /dev/null")); - exit 0 - | [] -> MatitaInit.die_usage () - | files -> - let uris_to_remove = - List.fold_left - (fun uris_to_remove suri -> - let uri = - try - UM.buri_of_uri (UM.uri_of_string suri) - with UM.IllFormedUri _ -> - let u = - DependenciesParser.baseuri_of_script ~include_paths:[] suri in - if String.length u < 5 || String.sub u 0 5 <> "cic:/" then begin - HLog.error (sprintf "File %s defines a bad baseuri: %s" - suri u); - exit 1 - end else - u - in - uri::uris_to_remove) [] files - in - LibraryClean.clean_baseuris ~basedir uris_to_remove diff --git a/helm/matita/matitaclean.mli b/helm/matita/matitaclean.mli deleted file mode 100644 index 45d57a886..000000000 --- a/helm/matita/matitaclean.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val main: unit -> unit - diff --git a/helm/matita/matitadep.ml b/helm/matita/matitadep.ml deleted file mode 100644 index c1ada6aea..000000000 --- a/helm/matita/matitadep.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module GA = GrafiteAst -module U = UriManager - -let main () = - (* all are maps from "file" to "something" *) - let include_deps = Hashtbl.create (Array.length Sys.argv) in - let baseuri_of = Hashtbl.create (Array.length Sys.argv) in - let uri_deps = Hashtbl.create (Array.length Sys.argv) in - let buri alias = U.buri_of_uri (U.uri_of_string alias) in - let resolve alias current_buri = - let buri = buri alias in - if buri <> current_buri then Some buri else None in - MatitaInit.fill_registry (); - MatitaInit.parse_cmdline (); - MatitaInit.load_configuration_file (); - let include_paths = - Helm_registry.get_list Helm_registry.string "matita.includes" in - let basedir = Helm_registry.get "matita.basedir" in - List.iter - (fun ma_file -> - let ic = open_in ma_file in - let istream = Ulexing.from_utf8_channel ic in - let dependencies = DependenciesParser.parse_dependencies istream in - close_in ic; - List.iter - (function - | DependenciesParser.UriDep uri -> - let uri = UriManager.string_of_uri uri in - if not (Http_getter_storage.is_legacy uri) then - Hashtbl.add uri_deps ma_file uri - | DependenciesParser.BaseuriDep uri -> - let uri = Http_getter_misc.strip_trailing_slash uri in - Hashtbl.add baseuri_of ma_file uri - | DependenciesParser.IncludeDep path -> - try - let baseuri = - DependenciesParser.baseuri_of_script ~include_paths path in - if not (Http_getter_storage.is_legacy baseuri) then - let moo_file = - LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in - Hashtbl.add include_deps ma_file moo_file - with Sys_error _ -> - HLog.warn - ("Unable to find " ^ path ^ " that is included in " ^ ma_file) - ) dependencies - ) (Helm_registry.get_list Helm_registry.string "matita.args"); - Hashtbl.iter - (fun file alias -> - let dep = resolve alias (Hashtbl.find baseuri_of file) in - match dep with - | None -> () - | Some u -> - Hashtbl.add include_deps file - (LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri:u)) - uri_deps; - List.iter - (fun ma_file -> - let deps = Hashtbl.find_all include_deps ma_file in - let deps = List.fast_sort Pervasives.compare deps in - let deps = HExtlib.list_uniq deps in - let deps = ma_file :: deps in - let baseuri = Hashtbl.find baseuri_of ma_file in - let moo = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in - Printf.printf "%s: %s\n" moo (String.concat " " deps); - Printf.printf "%s: %s\n" (Pcre.replace ~pat:"ma$" ~templ:"mo" ma_file) moo) - (Helm_registry.get_list Helm_registry.string "matita.args") - diff --git a/helm/matita/matitadep.mli b/helm/matita/matitadep.mli deleted file mode 100644 index 45d57a886..000000000 --- a/helm/matita/matitadep.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val main: unit -> unit - diff --git a/helm/matita/matitamake.ml b/helm/matita/matitamake.ml deleted file mode 100644 index f0e17eb8b..000000000 --- a/helm/matita/matitamake.ml +++ /dev/null @@ -1,163 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module MK = MatitamakeLib ;; - -let main () = - MatitaInit.fill_registry (); - MatitaInit.load_configuration_file (); - MK.initialize (); - let usage = ref (fun () -> ()) in - let dev_of_name name = - match MK.development_for_name name with - | None -> - prerr_endline ("Unable to find a development called " ^ name); - exit 1 - | Some d -> d - in - let dev_for_dir dir = - match MK.development_for_dir dir with - | None -> - prerr_endline ("Unable to find a development holding directory: "^ dir); - exit 1 - | Some d -> d - in - let init_dev_doc = " -\tParameters: name (the name of the development, required) -\tDescription: tells matitamake that a new development radicated -\t\tin the current working directory should be handled." - in - let init_dev args = - if List.length args <> 1 then !usage (); - match MK.initialize_development (List.hd args) (Unix.getcwd ()) with - | None -> exit 2 - | Some _ -> exit 0 - in - let list_dev_doc = " -\tParameters: -\tDescription: lists the known developments and their roots." - in - let list_dev args = - if List.length args <> 0 then !usage (); - match MK.list_known_developments () with - | [] -> print_string "No developments found.\n"; exit 0 - | l -> - List.iter - (fun (name, root) -> - print_string (Printf.sprintf "%-10s\trooted in %s\n" name root)) - l; - exit 0 - in - let destroy_dev_doc = " -\tParameters: name (the name of the development to destroy, required) -\tDescription: deletes a development (only from matitamake metadat, no -\t\t.ma files will be deleted)." - in - let destroy_dev args = - if List.length args <> 1 then !usage (); - let name = (List.hd args) in - let dev = dev_of_name name in - MK.destroy_development dev; - exit 0 - in - let clean_dev_doc = " -\tParameters: name (the name of the development to destroy, optional) -\t\tIf omitted the development that holds the current working -\t\tdirectory is used (if any). -\tDescription: clean the develpoment." - in - let clean_dev args = - let dev = - match args with - | [] -> dev_for_dir (Unix.getcwd ()) - | [name] -> dev_of_name name - | _ -> !usage (); exit 1 - in - match MK.clean_development dev with - | true -> exit 0 - | false -> exit 1 - in - let build_dev_doc = " -\tParameters: name (the name of the development to build, required) -\tDescription: completely builds the develpoment." - in - let build_dev args = - if List.length args <> 1 then !usage (); - let name = (List.hd args) in - let dev = dev_of_name name in - match MK.build_development dev with - | true -> exit 0 - | false -> exit 1 - in - let nodb_doc = " -\tParameters: -\tDescription: avoid using external database connection." - in - let nodb _ = Helm_registry.set_bool "db.nodb" true in - let target args = - if List.length args < 1 then !usage (); - let dev = dev_for_dir (Unix.getcwd ()) in - List.iter - (fun t -> - ignore(MK.build_development ~target:t dev)) - args - in - let params = [ - "-init", init_dev, init_dev_doc; - "-clean", clean_dev, clean_dev_doc; - "-list", list_dev, list_dev_doc; - "-destroy", destroy_dev, destroy_dev_doc; - "-build", build_dev, build_dev_doc; - "-nodb", nodb, nodb_doc; - "-h", (fun _ -> !usage()), "print this help screen"; - "-help", (fun _ -> !usage()), "print this help screen"; - ] - in - usage := (fun () -> - let p = prerr_endline in - p "\nusage:"; - p "\tmatitamake(.opt) [command [options]]\n"; - p "\tmatitamake(.opt) [target]\n"; - p "commands:"; - List.iter (fun (n,_,d) -> p (Printf.sprintf " %-10s%s" n d)) params; - p "\nIf target is omitted a 'all' will be used as the default."; - p "With -build you can build a development wherever it is."; - p "If you specify a target it implicitly refers to the development that"; - p "holds the current working directory (if any).\n"; - exit 1); - let rec parse args = - match args with - | [] -> target ["all"] - | s::tl -> - try - let _,f,_ = List.find (fun (n,_,_) -> n = s) params in - f tl; - parse tl - with Not_found -> if s.[0] = '-' then !usage () else target args - in - parse (List.tl (Array.to_list Sys.argv)) - diff --git a/helm/matita/matitamakeLib.ml b/helm/matita/matitamakeLib.ml deleted file mode 100644 index fba66e0d6..000000000 --- a/helm/matita/matitamakeLib.ml +++ /dev/null @@ -1,306 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let logger = fun mark -> - match mark with - | `Error -> HLog.error - | `Warning -> HLog.warn - | `Debug -> HLog.debug - | `Message -> HLog.message -;; - -type development = - { root: string ; name: string } - -let developments = ref [] - -let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;; -let rootfile = "/root" ;; - -let ls_dir dir = - try - let d = Unix.opendir dir in - let content = ref [] in - try - while true do - let name = Unix.readdir d in - if name <> "." && name <> ".." then - content := name :: !content - done; - Some [] - with End_of_file -> Unix.closedir d; Some !content - with Unix.Unix_error _ -> None - -let initialize () = - (* create a base env if none *) - HExtlib.mkdir (pool ()); - (* load developments *) - match ls_dir (pool ()) with - | None -> logger `Error ("Unable to list directory " ^ pool ()) - | Some l -> - List.iter - (fun name -> - let root = - try - Some (HExtlib.input_file (pool () ^ name ^ rootfile)) - with Unix.Unix_error _ -> - logger `Warning ("Malformed development " ^ name); - None - in - match root with - | None -> () - | Some root -> - developments := {root = root ; name = name} :: !developments) - l - -(* finds the makefile path for development devel *) -let makefile_for_development devel = - let develdir = pool () ^ devel.name in - develdir ^ "/makefile" -;; - -(* given a dir finds a development that is radicated in it or below *) -let development_for_dir dir = - let is_prefix_of d1 d2 = - let len1 = String.length d1 in - let len2 = String.length d2 in - if len2 < len1 then - false - else - let pref = String.sub d2 0 len1 in - pref = d1 - in - (* it must be unique *) - try - Some (List.find (fun d -> is_prefix_of d.root dir) !developments) - with Not_found -> None -;; - -let development_for_name name = - try - Some (List.find (fun d -> d.name = name) !developments) - with Not_found -> None - -(* dumps the deveopment to disk *) -let dump_development devel = - let devel_dir = pool () ^ devel.name in - HExtlib.mkdir devel_dir; - HExtlib.output_file ~filename:(devel_dir ^ rootfile) ~text:devel.root -;; - -let list_known_developments () = - List.map (fun r -> r.name,r.root) !developments - -let am_i_opt () = - if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else "" - -let rebuild_makefile development = - let makefilepath = makefile_for_development development in - let template = - HExtlib.input_file BuildTimeConf.matitamake_makefile_template - in - let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in - let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in - let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in - let df = pool () ^ development.name ^ "/depend" in - let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in - let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in - let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in - let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in - let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in - HExtlib.output_file ~filename:makefilepath ~text:template - -(* creates a new development if possible *) -let initialize_development name dir = - let name = Pcre.replace ~pat:" " ~templ:"_" name in - let dev = {name = name ; root = dir} in - match development_for_dir dir with - | Some d -> - logger `Error - ("Directory " ^ dir ^ " is already handled by development " ^ d.name); - logger `Error - ("Development " ^ d.name ^ " is rooted in " ^ d.root); - logger `Error - (dir ^ " is a subdir of " ^ d.root); - None - | None -> - dump_development dev; - rebuild_makefile dev; - developments := dev :: !developments; - Some dev - -let make chdir args = - let old = Unix.getcwd () in - try - Unix.chdir chdir; - let rc = - Unix.system - (String.concat " " ("make"::(List.map Filename.quote args))) - in - Unix.chdir old; - match rc with - | Unix.WEXITED 0 -> true - | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false - | _ -> logger `Error "make STOPPED or SIGNALED!";false - with Unix.Unix_error (_,cmd,err) -> - logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err); - false - -let call_make development target make = - rebuild_makefile development; - let makefile = makefile_for_development development in - let nodb = - Helm_registry.get_opt_default Helm_registry.bool ~default:false "db.nodb" - in - let flags = [] in - let flags = flags @ if nodb then ["NODB=true"] else [] in - let flags = - try - flags @ [ sprintf "MATITA_FLAGS=\"%s\"" (Sys.getenv "MATITA_FLAGS") ] - with Not_found -> flags in - make development.root - (["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target] - @ flags) - -let build_development ?(target="all") development = - call_make development target make - -(* not really good vt100 *) -let vt100 s = - let rex = Pcre.regexp "\\[[0-9;]+m" in - let rex_i = Pcre.regexp "^Info" in - let rex_w = Pcre.regexp "^Warning" in - let rex_e = Pcre.regexp "^Error" in - let rex_d = Pcre.regexp "^Debug" in - let rex_noendline = Pcre.regexp "\\n" in - let s = Pcre.replace ~rex:rex_noendline s in - let tokens = Pcre.split ~rex s in - let logger = ref HLog.message in - let rec aux = - function - | [] -> () - | s::tl -> - (if Pcre.pmatch ~rex:rex_i s then - logger := HLog.message - else if Pcre.pmatch ~rex:rex_w s then - logger := HLog.warn - else if Pcre.pmatch ~rex:rex_e s then - logger := HLog.error - else if Pcre.pmatch ~rex:rex_d s then - logger := HLog.debug - else - !logger s); - aux tl - in - aux tokens - - -let mk_maker refresh_cb = - (fun chdir args -> - let out_r,out_w = Unix.pipe () in - let err_r,err_w = Unix.pipe () in - let pid = ref ~-1 in - ignore(Sys.signal Sys.sigchld (Sys.Signal_ignore)); - try - let argv = Array.of_list ("make"::args) in - pid := Unix.create_process "make" argv Unix.stdin out_w err_w; - Unix.close out_w; - Unix.close err_w; - let buf = String.create 1024 in - let rec aux = function - | f::tl -> - let len = Unix.read f buf 0 1024 in - if len = 0 then - raise - (Unix.Unix_error - (Unix.EPIPE,"read","len = 0 (matita internal)")); - vt100 (String.sub buf 0 len); - aux tl - | _ -> () - in - while true do - let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in - aux r; - refresh_cb () - done; - true - with - | Unix.Unix_error (_,"read",_) - | Unix.Unix_error (_,"select",_) -> true) - -let build_development_in_bg ?(target="all") refresh_cb development = - call_make development target (mk_maker refresh_cb) -;; - -let clean_development development = - call_make development "clean" make - -let clean_development_in_bg refresh_cb development = - call_make development "clean" (mk_maker refresh_cb) - -let destroy_development_aux development clean_development = - let delete_development development = - let unlink file = - try - Unix.unlink file - with Unix.Unix_error _ -> logger `Debug ("Unable to delete " ^ file) - in - let rmdir dir = - try - Unix.rmdir dir - with Unix.Unix_error _ -> - logger `Warning ("Unable to remove dir " ^ dir); - match ls_dir dir with - | None -> logger `Error ("Unable to list directory " ^ dir) - | Some [] -> () - | Some l -> logger `Error ("The directory is not empty") - in - unlink (makefile_for_development development); - unlink (pool () ^ development.name ^ rootfile); - unlink (pool () ^ development.name ^ "/depend"); - rmdir (pool () ^ development.name); - developments := - List.filter (fun d -> d.name <> development.name) !developments - in - if not(clean_development development) then - begin - logger `Warning "Unable to clean the development problerly."; - logger `Warning "This may cause garbage." - end; - delete_development development - -let destroy_development development = - destroy_development_aux development clean_development - -let destroy_development_in_bg refresh development = - destroy_development_aux development (clean_development_in_bg refresh) - -let root_for_development development = development.root -let name_for_development development = development.name - diff --git a/helm/matita/matitamakeLib.mli b/helm/matita/matitamakeLib.mli deleted file mode 100644 index 4aaab47b1..000000000 --- a/helm/matita/matitamakeLib.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -type development - -(* initialize_development [name] [dir] - * ask matitamake to recorder [dir] as the root for thedevelopment [name] *) -val initialize_development: string -> string -> development option -(* make target [default all] *) -val build_development: ?target:string -> development -> bool -(* make target [default all], the refresh cb is called after every output *) -val build_development_in_bg: - ?target:string -> (unit -> unit) -> development -> bool -(* make clean *) -val clean_development: development -> bool -val clean_development_in_bg: (unit -> unit) -> development -> bool -(* return the development that handles dir *) -val development_for_dir: string -> development option -(* return the development *) -val development_for_name: string -> development option -(* return the known list of name, development_root *) -val list_known_developments: unit -> (string * string ) list -(* cleans the development, forgetting about it *) -val destroy_development: development -> unit -val destroy_development_in_bg: (unit -> unit) -> development -> unit -(* initiale internal data structures *) -val initialize : unit -> unit -(* gives back the root *) -val root_for_development : development -> string -(* gives back the name *) -val name_for_development : development -> string - diff --git a/helm/matita/matitatop.ml b/helm/matita/matitatop.ml deleted file mode 100644 index 0aba1e9b5..000000000 --- a/helm/matita/matitatop.ml +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let _ = - let _ = Topdirs.dir_quit in - Toploop.loop Format.std_formatter; - assert false diff --git a/helm/matita/scripts/README b/helm/matita/scripts/README deleted file mode 100644 index d48449056..000000000 --- a/helm/matita/scripts/README +++ /dev/null @@ -1,20 +0,0 @@ -bench.sql - the SQL code to generate the bench table - -crontab - install this crontab (may need tweaking) to have cron run the whole - stuff for you - -crontab.sh - the script crontab should run (includes a "pretty" report) - -do_tests.sh - script used by ../Makefile to run matitac[.opt] on some tests. supports some - options and prints out some informations neded my insert - -insert.awk - creates the SQL INSERT statements for the output of profile_cvs.sh - -profile_svn.sh - SVN co, compilation, run - diff --git a/helm/matita/scripts/bench.sql b/helm/matita/scripts/bench.sql deleted file mode 100644 index a45508548..000000000 --- a/helm/matita/scripts/bench.sql +++ /dev/null @@ -1,13 +0,0 @@ -DROP TABLE bench; - -CREATE TABLE bench ( - mark VARCHAR(100) NOT NULL, - time VARCHAR(8) NOT NULL, - timeuser VARCHAR(8) NOT NULL, - compilation ENUM('byte','opt') NOT NULL, - test VARCHAR(100) NOT NULL, - result ENUM('ok','fail') NOT NULL, - options SET('gc-off','gc-on') -); - -DESCRIBE bench; diff --git a/helm/matita/scripts/crontab b/helm/matita/scripts/crontab deleted file mode 100644 index 4b4c1e80a..000000000 --- a/helm/matita/scripts/crontab +++ /dev/null @@ -1,4 +0,0 @@ -MAILTO=helm@cs.unibo.it -HOME=/home/tassi/ -#SVNOPTIONS='-r {2006-01-09}' -10 5 * * * sh /home/tassi/helm/matita/scripts/crontab.sh diff --git a/helm/matita/scripts/crontab.sh b/helm/matita/scripts/crontab.sh deleted file mode 100644 index 5ad50de5e..000000000 --- a/helm/matita/scripts/crontab.sh +++ /dev/null @@ -1,78 +0,0 @@ -#!/bin/bash -TODAY=`date +%Y%m%d` -YESTERDAY=`date -d yesterday +%Y%m%d` -TMPDIRNAME=$HOME/__${TODAY}_crontab -TMPDIRNAMEOLD=$HOME/__${YESTERDAY}_crontab -SVNROOT="svn+ssh://mowgli.cs.unibo.it/local/svn/helm/trunk/" -SHELLTIME2CENTSPHP=scripts/shell_time2cents.php -SHELLADDERPHP=scripts/shell_adder.php -COMMONPHP=scripts/public_html/common.php - - -OLD=$PWD -mkdir -p $TMPDIRNAME -rm -rf $TMPDIRNAMEOLD -cd $TMPDIRNAME -rm -rf helm -svn co ${SVNROOT}helm/matita/scripts/ > LOG.svn 2>&1 -scripts/profile_svn.sh 2> LOG - -MARK=`echo "select distinct mark from bench where mark like '$TODAY%' order by mark" | mysql -u helm matita | tail -n 1` -LASTMARK=`echo "select distinct mark from bench where mark like '$YESTERDAY%' order by mark" | mysql -u helm matita | tail -n 1` - -if [ -z "$MARK" ]; then - echo "No benchmark records for $TODAY" - exit 1 -fi - -if [ -z "$LASTMARK" ]; then - echo "No benchmark records for $YESTERDAY" - exit 1 -fi - -CUR_TIME=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLADDERPHP -- $COMMONPHP "select SEC_TO_TIME(SUM(TIME_TO_SEC(time))) from bench where mark = \"$MARK\" group by mark;"` -OLD_TIME=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLADDERPHP -- $COMMONPHP "select SEC_TO_TIME(SUM(TIME_TO_SEC(time))) from bench where mark = \"$LASTMARK\" group by mark;"` - -CUR_CENTS=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLTIME2CENTSPHP -- $COMMONPHP $CUR_TIME` -OLD_CENTS=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLTIME2CENTSPHP -- $COMMONPHP $OLD_TIME` - -((DELTA=$CUR_CENTS-$OLD_CENTS)) -if [ $DELTA -lt 0 ]; then - PERC=0 -else - ((PERC=100 * $DELTA)) - ((PERC=$PERC / $OLD_CENTS)) -fi -if [ $PERC -ge 5 ]; then - cat </dev/null 2>/dev/null - $COMPILER $T 1>/dev/null 2>/dev/null - fi - $CLEANER $T 1>/dev/null 2>/dev/null - TIMES=`(time $COMPILER $T > $LOG 2>&1) 2>&1` - RC=$?; - cat $LOG >> $LOGFILE - touch $DIFF - if [ $EXPECTED = "FAIL" ]; then - if [ $RC = 0 ]; then - echo "The test was successful but it should have failed!" > $DIFF - RC=1; - else - diff $LOG `basename $T .ma`.log > $DIFF - RC=$? - fi - fi - if [ $RC = 0 ]; then - printf "$OK\t$TIMES\t$DO_TESTS_EXTRA\n" - else - printf "$FAIL\t$TIMES\t$DO_TESTS_EXTRA\n"; - cat $DIFF - fi - if [ "$KEEP" != "1" ]; then - rm -f $LOG - rm -f $DIFF - fi - exit $RC -done diff --git a/helm/matita/scripts/insert.awk b/helm/matita/scripts/insert.awk deleted file mode 100644 index d62a6a3ec..000000000 --- a/helm/matita/scripts/insert.awk +++ /dev/null @@ -1,17 +0,0 @@ - { - result=tolower($3); - if( $1 ~ ".opt$" ) - compilation="opt" - else - compilation="byte" - test=$2 - time=$4 - timeuser=$5 - mark=$7 - if ( $8 ~ "^gc-off$") - options="'gc-off'"; - if ( $8 ~ "^gc-on$") - options="'gc-on'" - - printf "INSERT bench (result, compilation, test, time, timeuser, mark, options) VALUES ('%s', '%s', '%s', '%s', '%s', '%s', %s);\n", result, compilation, test, time, timeuser, mark, options; - } diff --git a/helm/matita/scripts/profile_svn.sh b/helm/matita/scripts/profile_svn.sh deleted file mode 100755 index eca457ecc..000000000 --- a/helm/matita/scripts/profile_svn.sh +++ /dev/null @@ -1,70 +0,0 @@ -#!/bin/bash -MARK=`date +%Y%m%d%H%M` -TMPDIRNAME=__${MARK}_compilation -SVNROOT="svn+ssh://mowgli.cs.unibo.it/local/svn/helm/trunk/" - -function testit { - LOGTOOPT=/dev/null - LOGTOBYTE=/dev/null - export DO_TESTS_EXTRA="$MARK\t$@" - make tests DO_TESTS_OPTS="-no-color -twice -keep-logs" - make tests.opt DO_TESTS_OPTS="-no-color -twice -keep-logs" -} - -function compile { - LOCALOLD=$PWD - cd $1 - autoconf 1>/dev/null - ./configure 1>/dev/null - make all opt 1>/dev/null - cd $2 - autoconf 1>/dev/null - ./configure 1>/dev/null - cp matita.conf.xml.sample matita.conf.xml - make all opt 1>/dev/null - cd $LOCALOLD -} - -function run_tests { - LOCALOLD=$PWD - cd $1 - ./matitaclean all - mkdir .matita - export OCAMLRUNPARAM='o=1000000' - testit "gc-off" - export OCAMLRUNPARAM='' - testit "gc-on" - cd $LOCALOLD -} - -OLD=$PWD -rm -rf $TMPDIRNAME -mkdir $TMPDIRNAME -mkdir $TMPDIRNAME.HOME -cd $TMPDIRNAME -SVNLOG=`pwd`/LOG.svn - -#svn -svn co -N $SVNROOT > $SVNLOG 2>&1 -cd trunk -svn update -N helm >> $SVNLOG 2>&1 -cd helm -svn update $SVNOPTIONS ocaml >> $SVNLOG 2>&1 -svn update $SVNOPTIONS matita >> $SVNLOG 2>&1 -cd .. -cd .. -ln -s trunk/helm . - -#compile -export HOME="`pwd`/../$TMPDIRNAME.HOME" -compile $PWD/helm/ocaml $PWD/helm/matita - -#run -run_tests $PWD/helm/matita > LOG 2>/dev/null - -cat LOG | grep "\(OK\|FAIL\)" | grep "\(gc-on\|gc-off\)" | awk -f $PWD/helm/matita/scripts/insert.awk > INSERT.sql -cat INSERT.sql | mysql -u helm -h mowgli.cs.unibo.it matita -SVNREVISION=`cat $SVNLOG | grep revision | tail -n 1 | sed "s/.*revision \(\w\+\)./\1/"` -echo "INSERT INTO bench_svn VALUES ('$MARK','$SVNREVISION')" | mysql -u helm -h mowgli.cs.unibo.it matita -cd $OLD -#rm -rf $TMPDIRNAME diff --git a/helm/matita/scripts/public_html/bench.php b/helm/matita/scripts/public_html/bench.php deleted file mode 100644 index 2ee540825..000000000 --- a/helm/matita/scripts/public_html/bench.php +++ /dev/null @@ -1,147 +0,0 @@ -$name :   "; - if (strpos($q, urlencode("***")) === false) { - echo "all"; - } else { - foreach($limits as $l) { - $q1 = str_replace(urlencode("***"), " LIMIT 0,$l", $q); - echo "" . - minus1_to_all($l) . "  "; - } - $q1 = str_replace(urlencode("***"), " ", $q); - echo "" . - minus1_to_all("-1") . "  "; - } - echo ""; -} - -?> - - - - - - -

QUERY the benchmark system

-

Common Queries

-

-

    - - - - - - - -
-

-

Custom Query

-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Marks: - -
Compilations: - -
Options: - -
Tests: - -
Test results: - -
Group By: - -
Limit: - -
-
- - diff --git a/helm/matita/scripts/public_html/common.php b/helm/matita/scripts/public_html/common.php deleted file mode 100644 index f2a9be030..000000000 --- a/helm/matita/scripts/public_html/common.php +++ /dev/null @@ -1,89 +0,0 @@ - $v) { - $rc[$x['mark']][$k] = sum_time($v, $x[$k]); - } - } - } - return array_values($rc); -} - -function array_to_combo($l,$a) { - echo ""; -} - -?> diff --git a/helm/matita/scripts/public_html/composequery.php b/helm/matita/scripts/public_html/composequery.php deleted file mode 100644 index 49a943e47..000000000 --- a/helm/matita/scripts/public_html/composequery.php +++ /dev/null @@ -1,46 +0,0 @@ - $x) { - $v = $_GET[$x]; - if($v != "--") { - if($fst == false) { - $rc = $rc . " and "; - } else { - $rc = $rc . " "; - } - $fst = false; - $rc = $rc . $x . " = '" . $v . "'"; - } - } - return $rc; - } - - $gb = $_GET['groupby']; - $limit = $_GET['limit']; - if($gb != "--") - $what = "mark, SEC_TO_TIME(SUM(TIME_TO_SEC(time))) as sum_time, SEC_TO_TIME(SUM(TIME_TO_SEC(timeuser))) as sum_timeuser"; - else - $what = "mark, time, timeuser, compilation, test, result, options"; - $clause = clause_for($c); - if($clause != "") - $query = "select $what from bench where " . clause_for($c); - else - $query = "select $what from bench "; - if( $gb != "--"){ - $query = $query. "group by $gb"; - } - - if($limit != "--") { - $query = $query. " LIMIT 0,$limit"; - } - - $query = $query. ";"; - - header("Location: showquery.php?query=".urlencode("Custom:@@@" . $query)); - exit; -?> diff --git a/helm/matita/scripts/public_html/index.html b/helm/matita/scripts/public_html/index.html deleted file mode 100644 index 12fd7be9f..000000000 --- a/helm/matita/scripts/public_html/index.html +++ /dev/null @@ -1,15 +0,0 @@ - - - - - - - -

MATITA BENCHMARKING SYSTEM

-

-

- Go to the benchmark query page -
-

- - diff --git a/helm/matita/scripts/public_html/showquery.php b/helm/matita/scripts/public_html/showquery.php deleted file mode 100644 index e7db764d8..000000000 --- a/helm/matita/scripts/public_html/showquery.php +++ /dev/null @@ -1,62 +0,0 @@ - - - - - - -

QUERY results

- $q) { ?> -

-

- -

- - "; - foreach( $q[0] as $name => $txt) { - echo ""; - } - echo "\n"; - $i=0; - foreach ($q as $k => $v) { - $i = $i + 1; - if ( $i%2 == 0) - echo ""; - else - echo ""; - foreach( $v as $name => $txt) { - echo ""; - } - echo "\n"; - } - ?> -
$name
" . prettify($txt) . "
- -

BACK to the query page

- - diff --git a/helm/matita/scripts/public_html/style.css b/helm/matita/scripts/public_html/style.css deleted file mode 100644 index dc2df470d..000000000 --- a/helm/matita/scripts/public_html/style.css +++ /dev/null @@ -1,55 +0,0 @@ -body { - font-family: sans-serif; - font-size: 12pt; -} - -h1 { - text-align: center; - background-color: #87CEFA; -} - -h2 { - margin-right: auto; - border-bottom-color: #87CEFA; - border-bottom-style: solid; - border-bottom-width: 2px; -} - -a, .button { - border: 1px outset; - text-decoration: none; - background-color: #e9e9e9; - color: black; - cursor:pointer; - font-size: small; - padding-left:4px; - padding-right:4px; -} - -li { - margin-bottom: 10pt; -} - -ul { - list-style-type: upper-roman; -} - -table, td { - border-style:none; - padding: 2px 6px 2px 6px; -} - -tr.odd { - background-color:#EEEEEE; -} -tr.even { - background-color:#CECECE; -} - -th { - border-style:solid; - border-width:0px 0px 1px 0px; - border-color: gray; -} - - diff --git a/helm/matita/scripts/shell_adder.php b/helm/matita/scripts/shell_adder.php deleted file mode 100755 index a13005e55..000000000 --- a/helm/matita/scripts/shell_adder.php +++ /dev/null @@ -1,6 +0,0 @@ - diff --git a/helm/matita/scripts/shell_time2cents.php b/helm/matita/scripts/shell_time2cents.php deleted file mode 100755 index 4914fc24f..000000000 --- a/helm/matita/scripts/shell_time2cents.php +++ /dev/null @@ -1,4 +0,0 @@ - diff --git a/helm/matita/template_makefile.in b/helm/matita/template_makefile.in deleted file mode 100644 index 57f1301d5..000000000 --- a/helm/matita/template_makefile.in +++ /dev/null @@ -1,29 +0,0 @@ -SRC=$(shell find @ROOT@ -name "*.ma" -a -type f) -TODO=$(SRC:%.ma=%.mo) - -MATITA_FLAGS= -MATITA_FLAGS+=-noprofile -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -MATITAC=@CC@ -MATITACLEAN=@CLEAN@ -MATITADEP=@DEP@ - -all: $(TODO) - -clean: - $(MATITACLEAN) $(MATITA_FLAGS) $(SRC) - rm -f $(TODO) - -%.moo: - ($(MATITAC) $(MATITA_FLAGS) -q -I @ROOT@ $< | (grep -v "^make" || true)) - -@DEPFILE@ : $(SRC) - $(MATITADEP) $(MATITA_FLAGS) -I '@ROOT@' $^ 1> @DEPFILE@ - -# this is the depend for full targets like: -# dir/dir/name.moo: dir/dir/name.ma dir/dep.moo --include @DEPFILE@ diff --git a/helm/matita/tests/Makefile b/helm/matita/tests/Makefile deleted file mode 100644 index 34d4d120c..000000000 --- a/helm/matita/tests/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -SRC=$(wildcard *.ma) - -MATITA_FLAGS = -I .. -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -MATITAC=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac $(MATITA_FLAGS)" "../matitaclean $(MATITA_FLAGS)" /dev/null OK -MATITACOPT=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac.opt $(MATITA_FLAGS)" "../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK -VERBOSEMATITAC=../matitac $(MATITA_FLAGS) -VERBOSEMATITACOPT=../matitac.opt $(MATITA_FLAGS) - -MATITACLEAN=../matitaclean $(MATITA_FLAGS) -MATITACLEANOPT=../matitaclean.opt $(MATITA_FLAGS) - -MATITADEP=../matitadep $(MATITA_FLAGS) -MATITADEPOPT=../matitadep.opt $(MATITA_FLAGS) - -DEPEND_NAME=.depend - -H=@ - -all: $(SRC:%.ma=%.mo) - -opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all - -verbose: - $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all - -%.opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) - -clean_: - $(H)rm -f __*not_for_matita - -clean: clean_ - $(H)$(MATITACLEAN) $(SRC) - -cleanall: clean_ - $(H)rm -f $(SRC:%.ma=%.moo) - $(H)$(MATITACLEAN) all - -depend: - $(H)rm -f $(DEPEND_NAME) - $(H)$(MAKE) $(DEPEND_NAME) -.PHONY: depend - -%.moo: - $(H)$(MATITAC) $< - -$(DEPEND_NAME): $(SRC) - $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ - -#include $(DEPEND_NAME) -include .depend diff --git a/helm/matita/tests/SK.ma b/helm/matita/tests/SK.ma deleted file mode 100644 index 708f92f30..000000000 --- a/helm/matita/tests/SK.ma +++ /dev/null @@ -1,116 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/SK/". - -include "legacy/coq.ma". -alias symbol "eq" = "Coq's leibnitz's equality". - -theorem SKK: - \forall A:Set. - \forall app: A \to A \to A. - \forall K:A. - \forall S:A. - \forall H1: (\forall x,y:A.(app (app K x) y) = x). - \forall H2: (\forall x,y,z:A. - (app (app (app S x) y) z) = (app (app x z) (app y z))). - \forall x:A. - (app (app (app S K) K) x) = x. -intros.auto paramodulation. -qed. - -theorem bool1: - \forall A:Set. - \forall one:A. - \forall zero:A. - \forall add: A \to A \to A. - \forall mult: A \to A \to A. - \forall inv: A \to A. - \forall c1:(\forall x,y:A.(add x y) = (add y x)). - \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). - \forall d1: (\forall x,y,z:A. - (add x (mult y z)) = (mult (add x y) (add x z))). - \forall d2: (\forall x,y,z:A. - (mult x (add y z)) = (add (mult x y) (mult x z))). - \forall i1: (\forall x:A. (add x zero) = x). - \forall i2: (\forall x:A. (mult x one) = x). - \forall inv1: (\forall x:A. (add x (inv x)) = one). - \forall inv2: (\forall x:A. (mult x (inv x)) = zero). - (inv zero) = one. -intros.auto paramodulation. -qed. - -theorem bool2: - \forall A:Set. - \forall one:A. - \forall zero:A. - \forall add: A \to A \to A. - \forall mult: A \to A \to A. - \forall inv: A \to A. - \forall c1:(\forall x,y:A.(add x y) = (add y x)). - \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). - \forall d1: (\forall x,y,z:A. - (add x (mult y z)) = (mult (add x y) (add x z))). - \forall d2: (\forall x,y,z:A. - (mult x (add y z)) = (add (mult x y) (mult x z))). - \forall i1: (\forall x:A. (add x zero) = x). - \forall i2: (\forall x:A. (mult x one) = x). - \forall inv1: (\forall x:A. (add x (inv x)) = one). - \forall inv2: (\forall x:A. (mult x (inv x)) = zero). - \forall x:A. (mult x zero) = zero. -intros.auto paramodulation. -qed. - -theorem bool3: - \forall A:Set. - \forall one:A. - \forall zero:A. - \forall add: A \to A \to A. - \forall mult: A \to A \to A. - \forall inv: A \to A. - \forall c1:(\forall x,y:A.(add x y) = (add y x)). - \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). - \forall d1: (\forall x,y,z:A. - (add x (mult y z)) = (mult (add x y) (add x z))). - \forall d2: (\forall x,y,z:A. - (mult x (add y z)) = (add (mult x y) (mult x z))). - \forall i1: (\forall x:A. (add x zero) = x). - \forall i2: (\forall x:A. (mult x one) = x). - \forall inv1: (\forall x:A. (add x (inv x)) = one). - \forall inv2: (\forall x:A. (mult x (inv x)) = zero). - \forall x:A. (inv (inv x)) = x. -intros.auto paramodulation. -qed. - -theorem bool2: - \forall A:Set. - \forall one:A. - \forall zero:A. - \forall add: A \to A \to A. - \forall mult: A \to A \to A. - \forall inv: A \to A. - \forall c1:(\forall x,y:A.(add x y) = (add y x)). - \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). - \forall d1: (\forall x,y,z:A. - (add x (mult y z)) = (mult (add x y) (add x z))). - \forall d2: (\forall x,y,z:A. - (mult x (add y z)) = (add (mult x y) (mult x z))). - \forall i1: (\forall x:A. (add x zero) = x). - \forall i2: (\forall x:A. (mult x one) = x). - \forall inv1: (\forall x:A. (add x (inv x)) = one). - \forall inv2: (\forall x:A. (mult x (inv x)) = zero). - \forall x,y:A. - (inv (mult x y)) = (add (inv x) (inv y)). -intros.auto paramodulation. -qed. diff --git a/helm/matita/tests/absurd.ma b/helm/matita/tests/absurd.ma deleted file mode 100644 index fe789a00f..000000000 --- a/helm/matita/tests/absurd.ma +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/absurd/". -include "legacy/coq.ma". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias id "not" = "cic:/Coq/Init/Logic/not.con". - -theorem stupid : \forall a:Prop. a \to not a \to 0 = 1. -intros. -absurd a. -assumption. -assumption. -qed. diff --git a/helm/matita/tests/apply.ma b/helm/matita/tests/apply.ma deleted file mode 100644 index abd4a9407..000000000 --- a/helm/matita/tests/apply.ma +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -(* test _with_ the WHD on the apply argument *) -set "baseuri" "cic:/matita/tests/apply/". -include "legacy/coq.ma". - -alias id "not" = "cic:/Coq/Init/Logic/not.con". -alias id "False" = "cic:/Coq/Init/Logic/False.ind#xpointer(1/1)". - -theorem b: - \forall x:Prop. - (not x) \to x \to False. -intros. -apply H. -assumption. -qed. - -(* test _without_ the WHD on the apply argument *) - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". - -theorem a: - \forall A:Set. - \forall x: A. - not (x=x) \to not (x=x). -intros. -apply H. -qed. - - -(* this test shows what happens when a term of type A -> ? is applied to - a goal of type A' -> B: if A unifies with A' the unifier becomes ? := B - and no goal is opened; otherwise the unifier becomes ? := A' -> B and a - new goal of type A is created. *) -theorem c: - \forall A,B:Prop. - A \to (\forall P: Prop. A \to P) \to (A \to B) \land (B \to B). - intros 4; split; [ apply H1 | apply H1; exact H ]. -qed. - -(* this test requires the delta-expansion of not in the type of the applied - term (to reveal a product) *) -theorem d: \forall A: Prop. \lnot A \to A \to False. - intros. apply H. assumption. -qed. diff --git a/helm/matita/tests/assumption.ma b/helm/matita/tests/assumption.ma deleted file mode 100644 index ef84002ac..000000000 --- a/helm/matita/tests/assumption.ma +++ /dev/null @@ -1,39 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/assumption". -include "legacy/coq.ma". - -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias num (instance 0) = "natural number". -alias symbol "and" (instance 0) = "Coq's logical and". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". - - -theorem stupid: - \forall a: 0 = 0. - \forall b: 3 + 2 = 5. - \forall c: (\lambda x:nat.x) 3 = 3. - 0=0 \land 3 + 2 = 5 \land 3 = 3. -intros. -split. -split. -clear H2. clear H1. -assumption. -clear H. -assumption. -assumption. -qed. - diff --git a/helm/matita/tests/bad_tests/Makefile b/helm/matita/tests/bad_tests/Makefile deleted file mode 100644 index 7620894f2..000000000 --- a/helm/matita/tests/bad_tests/Makefile +++ /dev/null @@ -1,57 +0,0 @@ -SRC=$(wildcard *.ma) - -MATITA_FLAGS = -I ../.. -NODB=false -ifeq ($(NODB),true) - MATITA_FLAGS += -nodb -endif - -MATITAC=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac $(MATITA_FLAGS) -noprofile" "../../matitaclean $(MATITA_FLAGS)" /dev/null FAIL -MATITACOPT=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac.opt $(MATITA_FLAGS) -noprofile" "../../matitaclean.opt $(MATITA_FLAGS)" /dev/null FAIL -VERBOSEMATITAC=../../matitac $(MATITA_FLAGS) -VERBOSEMATITACOPT=../../matitac.opt $(MATITA_FLAGS) - -MATITACLEAN=../../matitaclean $(MATITA_FLAGS) -MATITACLEANOPT=../../matitaclean.opt $(MATITA_FLAGS) - -MATITADEP=../../matitadep $(MATITA_FLAGS) -MATITADEPOPT=../../matitadep.opt $(MATITA_FLAGS) - -DEPEND_NAME=.depend - -H=@ - -all: $(SRC:%.ma=%.mo) - -opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all - -verbose: - $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all - -%.opt: - $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) - -clean_: - $(H)rm -f __*not_for_matita - -clean: clean_ - $(H)$(MATITACLEAN) $(SRC) - -cleanall: clean_ - $(H)rm -f $(SRC:%.ma=%.moo) - $(H)$(MATITACLEAN) all - -depend: - $(H)rm -f $(DEPEND_NAME) - $(H)$(MAKE) $(DEPEND_NAME) -.PHONY: depend - -%.moo: - $(H)$(MATITAC) $< - -$(DEPEND_NAME): $(SRC) - $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ - -#include $(DEPEND_NAME) -include .depend diff --git a/helm/matita/tests/bad_tests/auto.log b/helm/matita/tests/bad_tests/auto.log deleted file mode 100644 index 0cac60da3..000000000 --- a/helm/matita/tests/bad_tests/auto.log +++ /dev/null @@ -1,100 +0,0 @@ -Info: execution of auto.ma started: -Debug: Executing: ``set "baseuri" "cic:/matita/tests/auto/"'' -Debug: Executing: ``include cic:/matita/legacy/coq'' -Debug: Executing: ``Theorem a: @[\forall ((x): (@[nat])).(\forall ((y) ...'' -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Datatypes/nat.ind -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/eq.ind -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/minus.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/mult.con -Error: Bad name: a -Debug: Executing: ``intro.'' -Debug: Executing: ``auto.'' -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/trans_eq.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/z.var -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/f_equal3.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/f_equal2.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/f_equal.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/B.var -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/f.var -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/add_sub_square_identity.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/mult_n_Sm.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/TreeAutomata/semantics/conservation_0_0.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/technical_lemma.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/ARITH/Chinese/Nat_complements/technical_lemma.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/plus_minus.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_plus_simpl_l_reverse.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_plus.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/minus_minus.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_plus_distr_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_plus_distr_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_plus_distr_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/mult_plus_distr2.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_n_n.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_n_O.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/minus_minus_lem1.con -WE HAVE NO UNIVERSE FILE FOR cic:/Cachan/SMC/mu/Splus_nm.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus_n_Sm.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus_Sn_m.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_Snm_nSm.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/TreeAutomata/bases/S_plus_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/Qpositive/mult_reg_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_reg_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_permute_2_in_4.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_permute.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_comm.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_assoc_reverse.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_assoc.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_plus_reg_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_plus_reg_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/plus_eq.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/plus_permute2.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/minus_eq_decompose.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/Qpositive/minus_decompose.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/minus_eq.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/eq_add_S.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/expand_mult2.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_n_2.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/ring/ArithRing/S_to_plus_one.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/ZArith/BinInt/ZL0.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/S_plus.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/plus_n_SO.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus_n_O.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_0_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_0_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Marseille/GC/lib_arith/lib_plus/plus_O_O.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/plus_eqO.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/plus_O_O.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Bertrand/Misc/plus_eqO.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/g0.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/McCarthy/g.var -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/mult_SO.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Bertrand/Misc/mult_SO.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack1.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/Ackermann/Ack.var -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_1_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_1_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/mult2_recompose.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_n_1.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/mult_n_O.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_0_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_0_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_comm.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_assoc_reverse.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_assoc.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/square_recompose.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_sym.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_permut.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_assoc_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_mult_reg_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_mult_reg_l.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/mult_eq.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/mult_sym.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/mult_permute.con -WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Float/Faux/minus_inv_lt_aux.con -WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_minus_distr_r.con -WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/mult_minus_distr_l.con -Error: Tactic error: No Applicable theorem diff --git a/helm/matita/tests/bad_tests/auto.ma b/helm/matita/tests/bad_tests/auto.ma deleted file mode 100755 index c7bd62492..000000000 --- a/helm/matita/tests/bad_tests/auto.ma +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/auto/". -include "legacy/coq.ma". - -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "minus" (instance 0) = "Coq's natural minus". -alias symbol "plus" (instance 0) = "Coq's natural plus". -alias symbol "times" (instance 0) = "Coq's natural times". -theorem a : \forall x,y:nat. x*x+(S y) = O - x. -intros. -auto depth = 3. diff --git a/helm/matita/tests/bad_tests/baseuri.log b/helm/matita/tests/bad_tests/baseuri.log deleted file mode 100644 index 9185479df..000000000 --- a/helm/matita/tests/bad_tests/baseuri.log +++ /dev/null @@ -1,4 +0,0 @@ -Info: execution of baseuri.ma started: -Debug: Executing: ``set "baseuri" "cic:/matita/tests/baseuri/"'' -Debug: Executing: ``set "baseuri" "cic:/matita/tests/baseuri/"'' -Error: Error: Redefinition of 'baseuri' is forbidden. diff --git a/helm/matita/tests/bad_tests/baseuri.ma b/helm/matita/tests/bad_tests/baseuri.ma deleted file mode 100644 index 0e06223fa..000000000 --- a/helm/matita/tests/bad_tests/baseuri.ma +++ /dev/null @@ -1,16 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/baseuri/". -set "baseuri" "cic:/matita/tests/baseuri/". diff --git a/helm/matita/tests/change.ma b/helm/matita/tests/change.ma deleted file mode 100644 index b2ae3b7a0..000000000 --- a/helm/matita/tests/change.ma +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/change/". -include "legacy/coq.ma". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". - -theorem stupid: - \forall a:nat. - a = 5 \to - (3 + 2) = a. -intros. -change in \vdash (? ? % ?) with 5. -rewrite < H in \vdash (? ? % ?). -reflexivity. -qed. - -(* tests changing a term under a binder *) -alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". -theorem t: (\forall x:nat. x=x) \to True. - intro H. - change in match x in H : (\forall _.%) with (0+x). - change in H: (\forall _.(? ? ? (? % ?))) with 0. - constructor 1. -qed. - diff --git a/helm/matita/tests/clear.ma b/helm/matita/tests/clear.ma deleted file mode 100644 index 5aaf6c0d6..000000000 --- a/helm/matita/tests/clear.ma +++ /dev/null @@ -1,30 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/clear". -include "legacy/coq.ma". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". - -theorem stupid: - \forall a: True. - \forall b: 0 = 0. - 0 = 0. -intros 1 (H). -clear H. -intros 1 (H). -exact H. -qed. - diff --git a/helm/matita/tests/clearbody.ma b/helm/matita/tests/clearbody.ma deleted file mode 100644 index ca4b9316e..000000000 --- a/helm/matita/tests/clearbody.ma +++ /dev/null @@ -1,31 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/clearbody". -include "legacy/coq.ma". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". - - -theorem stupid : - let x \def 0 + 1 in x + 2 = x + 2. - intros. - clearbody x. - simplify. - generalize in \vdash (? ? (? % ?) (? % ?)). - intros. - reflexivity. - qed. - diff --git a/helm/matita/tests/coercions.ma b/helm/matita/tests/coercions.ma deleted file mode 100644 index 20b15cd26..000000000 --- a/helm/matita/tests/coercions.ma +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/coercions/". -include "legacy/coq.ma". - -inductive pos: Set \def -| one : pos -| next : pos \to pos. - -inductive nat:Set \def -| O : nat -| S : nat \to nat. - -inductive int: Set \def -| positive: nat \to int -| negative : nat \to int. - -inductive empty : Set \def . - -let rec pos2nat x \def - match x with - [ one \Rightarrow (S O) - | (next z) \Rightarrow S (pos2nat z)]. - -definition nat2int \def \lambda x. positive x. - -coercion cic:/matita/tests/coercions/pos2nat.con. - -coercion cic:/matita/tests/coercions/nat2int.con. - -definition fst \def \lambda x,y:int.x. - -theorem a: fst O one = fst (positive O) (next one). -reflexivity. -qed. - -definition double: - \forall f:int \to int. pos \to int -\def - \lambda f:int \to int. \lambda x : pos .f (nat2int x). - -definition double1: - \forall f:int \to int. pos \to int -\def - \lambda f:int \to int. \lambda x : pos .f (pos2nat x). - -definition double2: - \forall f:int \to int. pos \to int -\def - \lambda f:int \to int. \lambda x : pos .f (nat2int (pos2nat x)). - - diff --git a/helm/matita/tests/comments.ma b/helm/matita/tests/comments.ma deleted file mode 100644 index 41e8e9bb3..000000000 --- a/helm/matita/tests/comments.ma +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/comments/". -include "legacy/coq.ma". - -(* commento che va nell'ast, ma non viene contato - come step perche' non e' un executable -*) - -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -theorem a:0=0. - -(* nota *) -(** - - -apply Prop. -*) -reflexivity. -(* commenti che non devono essere colorati perche' - non c'e' nulla di eseguibile dopo di loro -*) -qed. diff --git a/helm/matita/tests/constructor.ma b/helm/matita/tests/constructor.ma deleted file mode 100644 index 7ea26d43c..000000000 --- a/helm/matita/tests/constructor.ma +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/constructor". -include "legacy/coq.ma". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". - - -theorem stupid: 1 = 1. -constructor 1. -qed. diff --git a/helm/matita/tests/continuationals.ma b/helm/matita/tests/continuationals.ma deleted file mode 100644 index f45061bad..000000000 --- a/helm/matita/tests/continuationals.ma +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/test/continuationals/". -include "legacy/coq.ma". - -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -alias id "trans_equal" = "cic:/Coq/Init/Logic/trans_equal.con". -alias id "refl_equal" = "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)". -alias id "Z" = "cic:/Coq/ZArith/BinInt/Z.ind#xpointer(1/1)". - -theorem semicolon: \forall p:Prop.p\to p\land p. -intros (p); split; assumption. -qed. - -theorem branch:\forall x:nat.x=x. -intros (n); -elim n -[ reflexivity; -| reflexivity ]. -qed. - -theorem pos:\forall x:Z.x=x. -intros (n); -elim n; -[ 3: reflexivity; -| 2: reflexivity; -| reflexivity ] -qed. - -theorem dot:\forall x:Z.x=x. -intros (x). -elim x. -reflexivity. reflexivity. reflexivity. -qed. - -theorem dot_slice:\forall x:Z.x=x. -intros (x). -elim x; -[ elim x. reflexivity. reflexivity. reflexivity; -| reflexivity -| reflexivity ]; -qed. - -theorem focus:\forall x:Z.x=x. -intros (x); elim x. -focus 16 17; - reflexivity; -unfocus. -reflexivity. -qed. - -theorem skip:\forall x:nat.x=x. -intros (x). -apply trans_equal; -[ 2: apply (refl_equal nat x); -| skip -| reflexivity -] -qed. - -theorem skip_focus:\forall x:nat.x=x. -intros (x). -apply trans_equal; -[ focus 18; apply (refl_equal nat x); unfocus; -| skip -| reflexivity ] -qed. diff --git a/helm/matita/tests/contradiction.ma b/helm/matita/tests/contradiction.ma deleted file mode 100644 index 305a862cf..000000000 --- a/helm/matita/tests/contradiction.ma +++ /dev/null @@ -1,31 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/contradiction". -include "legacy/coq.ma". -alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". -alias id "not" = "cic:/Coq/Init/Logic/not.con". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". - - - -theorem stupid: \forall a:Prop. a \to not a \to 0 = 2. -intros. -letin H \def (H1 H). -contradiction. -qed. - - - diff --git a/helm/matita/tests/cut.ma b/helm/matita/tests/cut.ma deleted file mode 100644 index a30fe2fab..000000000 --- a/helm/matita/tests/cut.ma +++ /dev/null @@ -1,25 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/cut". -include "legacy/coq.ma". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". - -theorem stupid: 3 = 3. - cut (3 = 3). - assumption. - reflexivity. -qed. - diff --git a/helm/matita/tests/decompose.ma b/helm/matita/tests/decompose.ma deleted file mode 100644 index fe72f710a..000000000 --- a/helm/matita/tests/decompose.ma +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/decompose". -include "legacy/coq.ma". -alias symbol "and" (instance 0) = "Coq's logical and". -alias symbol "or" (instance 0) = "Coq's logical or". - - - -theorem stupid: - \forall a,b,c:Prop. - (a \land c \lor b \land c) \to (c \land (b \lor a)). - intros.decompose H.split.assumption.right.assumption. - split.assumption.left.assumption.qed. - - diff --git a/helm/matita/tests/demodulation_coq.ma b/helm/matita/tests/demodulation_coq.ma deleted file mode 100644 index aa9d5f185..000000000 --- a/helm/matita/tests/demodulation_coq.ma +++ /dev/null @@ -1,52 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/demodulation/". - -include "legacy/coq.ma". - -alias num = "natural number". -alias symbol "times" = "Coq's natural times". -alias symbol "plus" = "Coq's natural plus". -alias symbol "eq" = "Coq's leibnitz's equality". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". - - -theorem p0 : \forall m:nat. m+O = m. -intro. demodulate. - -theorem p: \forall m.1*m = m. -intros.demodulate.reflexivity. -qed. - -theorem p2: \forall x,y:nat.(S x)*y = (y+x*y). -intros.demodulate.reflexivity. -qed. - -theorem p1: \forall x,y:nat.(S ((S x)*y+x))=(S x)+(y*x+y). -intros.demodulate.reflexivity. -qed. - -theorem p3: \forall x,y:nat. (x+y)*(x+y) = x*x + 2*(x*y) + (y*y). -intros.demodulate.reflexivity. -qed. - -theorem p4: \forall x:nat. (x+1)*(x-1)=x*x - 1. -intro. -apply (nat_case x) -[simplify.reflexivity -|intro.demodulate.reflexivity] -qed. - diff --git a/helm/matita/tests/demodulation_matita.ma b/helm/matita/tests/demodulation_matita.ma deleted file mode 100644 index 0f4827e46..000000000 --- a/helm/matita/tests/demodulation_matita.ma +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/demodulation_matita/". - -include "nat/minus.ma". - -theorem p2: \forall x,y:nat. x+x = (S(S O))*x. -intros.demodulate.reflexivity. -qed. - -theorem p4: \forall x:nat. (x+(S O))*(x-(S O))=x*x - (S O). -intro. -apply (nat_case x) -[simplify.reflexivity -|intro.demodulate.reflexivity] -qed. - -theorem p5: \forall x,y:nat. (x+y)*(x+y) = x*x + (S(S O))*(x*y) + (y*y). -intros.demodulate.reflexivity. -qed. - diff --git a/helm/matita/tests/discriminate.ma b/helm/matita/tests/discriminate.ma deleted file mode 100644 index d8e4bf2e2..000000000 --- a/helm/matita/tests/discriminate.ma +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/discriminate". -include "legacy/coq.ma". -alias id "not" = "cic:/Coq/Init/Logic/not.con". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". - -inductive foo: Prop \def I_foo: foo. - -theorem stupid: - 1 = 0 \to (\forall p:Prop. p \to not p). - intros. - generalize in match I_foo. - discriminate H. -qed. - -inductive bar_list (A:Set): Set \def - | bar_nil: bar_list A - | bar_cons: A \to bar_list A \to bar_list A. - -alias id "False" = "cic:/Coq/Init/Logic/False.ind#xpointer(1/1)". -theorem stupid2: - \forall A:Set.\forall x:A.\forall l:bar_list A. - bar_nil A = bar_cons A x l \to False. - intros. - discriminate H. -qed. diff --git a/helm/matita/tests/elim.ma b/helm/matita/tests/elim.ma deleted file mode 100644 index 67d7fada1..000000000 --- a/helm/matita/tests/elim.ma +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/elim". -include "legacy/coq.ma". - -inductive stupidtype: Set \def - | Base : stupidtype - | Next : stupidtype \to stupidtype - | Pair : stupidtype \to stupidtype \to stupidtype. - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "exists" (instance 0) = "Coq's exists". -alias symbol "or" (instance 0) = "Coq's logical or". -alias num (instance 0) = "natural number". -alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". -alias id "refl_equal" = "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)". - -theorem serious: - \forall a:stupidtype. - a = Base - \lor - (\exists b:stupidtype.a = Next b) - \lor - (\exists c,d:stupidtype.a = Pair c d). -intros. -elim a. -clear a.left.left. - reflexivity. -clear H.clear a.left.right. - exists.exact s.reflexivity. -clear H.clear H1.clear a.right. - exists.exact s.exists.exact s1.reflexivity. -qed. - -theorem t: 0=0 \to stupidtype. - intros; constructor 1. -qed. - -(* In this test "elim t" should open a new goal 0=0 and put it in the *) -(* goallist so that the THEN tactical closes it using reflexivity. *) -theorem foo: let ax \def refl_equal ? 0 in t ax = t ax. - elim t; reflexivity. -qed. - -(* This test shows a bug where elim opens a new unus{ed,eful} goal *) - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". - -inductive sum (n:nat) : nat \to nat \to Set \def - k: \forall x,y. n = x + y \to sum n x y. - -theorem t': \forall x,y. \forall H: sum x y O. - match H with [ (k a b p) \Rightarrow a ] = x. - intros. - cut (y = y \to O = O \to match H with [ (k a b p) \Rightarrow a] = x). - apply Hcut; reflexivity. - apply - (sum_ind ? - (\lambda a,b,K. y=a \to O=b \to - match K with [ (k a b p) \Rightarrow a ] = x) - ? ? ? H). - goal 16. - simplify. intros. - generalize in match H1. - rewrite < H2; rewrite < H3.intro. - rewrite > H4.auto. -qed. diff --git a/helm/matita/tests/fguidi.ma b/helm/matita/tests/fguidi.ma deleted file mode 100644 index c6eb2a9d8..000000000 --- a/helm/matita/tests/fguidi.ma +++ /dev/null @@ -1,114 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/fguidi/". -include "legacy/coq.ma". - -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -alias id "le" = "cic:/matita/fguidi/le.ind#xpointer(1/1)". -alias id "False_ind" = "cic:/Coq/Init/Logic/False_ind.con". -alias id "I" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1/1)". -alias id "ex_intro" = "cic:/Coq/Init/Logic/ex.ind#xpointer(1/1/1)". -alias id "False" = "cic:/Coq/Init/Logic/False.ind#xpointer(1/1)". -alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". - -alias symbol "and" (instance 0) = "Coq's logical and". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "exists" (instance 0) = "Coq's exists". - -definition is_S: nat \to Prop \def - \lambda n. match n with - [ O \Rightarrow False - | (S n) \Rightarrow True - ]. - -definition pred: nat \to nat \def - \lambda n. match n with - [ O \Rightarrow O - | (S n) \Rightarrow n - ]. - -theorem eq_gen_S_O: \forall x. (S x = O) \to \forall P:Prop. P. -intros. apply False_ind. cut (is_S O). auto paramodulation. elim H. exact I. -qed. - -theorem eq_gen_S_O_cc: (\forall P:Prop. P) \to \forall x. (S x = O). -intros. auto. -qed. - -theorem eq_gen_S_S: \forall m,n. (S m) = (S n) \to m = n. -intros. cut ((pred (S m)) = (pred (S n))). -assumption. elim H. auto paramodulation. -qed. - -theorem eq_gen_S_S_cc: \forall m,n. m = n \to (S m) = (S n). -intros. elim H. auto paramodulation. -qed. - -inductive le: nat \to nat \to Prop \def - le_zero: \forall n. (le O n) - | le_succ: \forall m, n. (le m n) \to (le (S m) (S n)). - -theorem le_refl: \forall x. (le x x). -intros. elim x. auto paramodulation. auto paramodulation. -qed. - -theorem le_gen_x_O_aux: \forall x, y. (le x y) \to (y =O) \to - (x = O). -intros 3. elim H. auto paramodulation. apply eq_gen_S_O. exact n1. auto paramodulation. -qed. - -theorem le_gen_x_O: \forall x. (le x O) \to (x = O). -intros. apply le_gen_x_O_aux. exact O. auto paramodulation. auto paramodulation. -qed. - -theorem le_gen_x_O_cc: \forall x. (x = O) \to (le x O). -intros. elim H. auto paramodulation. -qed. - -theorem le_gen_S_x_aux: \forall m,x,y. (le y x) \to (y = S m) \to - (\exists n. x = (S n) \land (le m n)). -intros 4. elim H. -apply eq_gen_S_O. exact m. elim H1. auto paramodulation. -cut (n = m). elim Hcut. apply ex_intro. exact n1. auto paramodulation. auto. (* paramodulation non trova la prova *) -qed. - -theorem le_gen_S_x: \forall m,x. (le (S m) x) \to - (\exists n. x = (S n) \land (le m n)). -intros. apply le_gen_S_x_aux. exact (S m). auto paramodulation. auto paramodulation. -qed. - -theorem le_gen_S_x_cc: \forall m,x. (\exists n. x = (S n) \land (le m n)) \to - (le (S m) x). -intros. elim H. elim H1. cut ((S x1) = x). elim Hcut. auto paramodulation. elim H2. auto paramodulation. -qed. - -theorem le_gen_S_S: \forall m,n. (le (S m) (S n)) \to (le m n). -intros. -lapply le_gen_S_x to H using H0. elim H0. elim H1. -lapply eq_gen_S_S to H2 using H4. rewrite > H4. assumption. -qed. - -theorem le_gen_S_S_cc: \forall m,n. (le m n) \to (le (S m) (S n)). -intros. auto paramodulation. -qed. - -(* -theorem le_trans: \forall x,y. (le x y) \to \forall z. (le y z) \to (le x z). -intros 1. elim x; clear H. clear x. -auto paramodulation. -fwd H1 [H]. decompose H. -*) diff --git a/helm/matita/tests/first.ma b/helm/matita/tests/first.ma deleted file mode 100644 index 4fca7b199..000000000 --- a/helm/matita/tests/first.ma +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/first/". - -inductive nat : Set \def - | O : nat - | S : nat \to nat. - -inductive eq (A:Set): A \to A \to Prop \def - refl: \forall x:A.eq A x x. - -inductive list (A:Set) : Set \def - | nil : list A - | cons : A \to list A \to list A. - -let rec list_len (A:Set) (l:list A) on l \def - match l with - [ nil \Rightarrow O - | (cons a tl) \Rightarrow S (list_len A tl)]. - -theorem stupid: \forall A:Set.eq ? (list_len A (nil ?)) O. -intros. -normalize. -apply refl. -qed. diff --git a/helm/matita/tests/fix_betareduction.ma b/helm/matita/tests/fix_betareduction.ma deleted file mode 100644 index 82f0b1cf6..000000000 --- a/helm/matita/tests/fix_betareduction.ma +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/fix_betareduction/". - -alias id "eq" = "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1)". -alias id "n" = "cic:/Suresnes/BDD/canonicite/Canonicity_BDT/n.con". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -theorem a: - (\forall p: nat \to Prop. - \forall n: nat. p n \to p n ) \to (eq nat n n). -intro. -apply (H (\lambda n:nat.(eq nat n n))). -reflexivity. -qed. diff --git a/helm/matita/tests/fold.ma b/helm/matita/tests/fold.ma deleted file mode 100644 index a8cee1021..000000000 --- a/helm/matita/tests/fold.ma +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/fold". -include "legacy/coq.ma". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". -theorem t: \forall x:nat. 0+x=x. - intro. - simplify in match (0+x) in \vdash (? ? % ?). - fold simplify (0 + x) in \vdash (? ? % ?). - reflexivity. -qed. diff --git a/helm/matita/tests/generalize.ma b/helm/matita/tests/generalize.ma deleted file mode 100644 index 68492baa3..000000000 --- a/helm/matita/tests/generalize.ma +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/generalize". -include "legacy/coq.ma". - -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". -alias id "plus_comm" = "cic:/Coq/Arith/Plus/plus_comm.con". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". - -(* This tests is for the case of a pattern that contains metavariables *) -theorem t: \forall x. x + 4 = 4 + x. - intro. - generalize in match (S ?). - intro; apply plus_comm. -qed. - -(* This test used to fail because x was used in the wrong context *) -(* Once this was fixed it still did not work since apply is not *) -(* able to solve a goal that ends in a product. *) -theorem test2: \forall x. 4 + x = x + 4. - generalize in match 4. - exact plus_comm. -qed. diff --git a/helm/matita/tests/interactive/automatic_insertion.ma b/helm/matita/tests/interactive/automatic_insertion.ma deleted file mode 100644 index 56212bdc5..000000000 --- a/helm/matita/tests/interactive/automatic_insertion.ma +++ /dev/null @@ -1,17 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/xxx". - -theorem t: And True (eq nat O O). split. exact (refl_equal nat O). exact I. qed. \ No newline at end of file diff --git a/helm/matita/tests/interactive/drop.ma b/helm/matita/tests/interactive/drop.ma deleted file mode 100644 index b8718cdb8..000000000 --- a/helm/matita/tests/interactive/drop.ma +++ /dev/null @@ -1,8 +0,0 @@ -set "baseuri" "cic:/matita/tests/drop". - -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "leibnitz's equality". -alias symbol "plus" (instance 0) = "natural plus". -theorem a : O + 1 = 1. -drop. diff --git a/helm/matita/tests/interactive/grafite.ma b/helm/matita/tests/interactive/grafite.ma deleted file mode 100644 index aaf570091..000000000 --- a/helm/matita/tests/interactive/grafite.ma +++ /dev/null @@ -1,34 +0,0 @@ -set "baseuri" "cic:/matita/tests/grafite/". - -(* commento *) -(** hint. *) - -inductive pippo : Type \def - | a : Type \to pippo - | b : Prop \to pippo - | c : Set \to pippo. - -definition pollo : Set \to Set \def - \lambda a:Set.a. - -inductive paolo : Prop \def t:paolo. - -theorem comeno : \forall p:pippo.pippo. -intros.assumption. -qed. - -definition f : pippo \to paolo \def - \lambda x:pippo. - match x with - [ (a z) \Rightarrow t - | (b z) \Rightarrow t - | (c z) \Rightarrow t ]. - -record w : Type \def { - mario : Prop; - pippo : Set -}. - -whelp locate pippo. - -print "coercions". diff --git a/helm/matita/tests/interactive/test5.ma b/helm/matita/tests/interactive/test5.ma deleted file mode 100644 index e48cc827e..000000000 --- a/helm/matita/tests/interactive/test5.ma +++ /dev/null @@ -1,7 +0,0 @@ -set "baseuri" "cic:/matita/tests/interactive/test5/". - -whelp instance - \lambda A:Set. - \lambda f: A \to A \to A. - \forall x,y : A. - f x y = f y x. diff --git a/helm/matita/tests/interactive/test6.ma b/helm/matita/tests/interactive/test6.ma deleted file mode 100644 index 4afdd3741..000000000 --- a/helm/matita/tests/interactive/test6.ma +++ /dev/null @@ -1,7 +0,0 @@ -set "baseuri" "cic:/matita/tests/interactive/test6/". - -whelp instance - \lambda A:Set. - \lambda f:A \to A \to A. - \forall x,y,z:A. - f x (f y z) = f (f x y) z. diff --git a/helm/matita/tests/interactive/test7.ma b/helm/matita/tests/interactive/test7.ma deleted file mode 100644 index d7347ed9f..000000000 --- a/helm/matita/tests/interactive/test7.ma +++ /dev/null @@ -1,7 +0,0 @@ -set "baseuri" "cic:/matita/tests/interactive/test7/". - -whelp instance - \lambda A:Set. - \lambda r:A \to A \to Prop. - \forall x:A. - r x x. diff --git a/helm/matita/tests/interactive/test_instance.ma b/helm/matita/tests/interactive/test_instance.ma deleted file mode 100644 index 7e02c0fff..000000000 --- a/helm/matita/tests/interactive/test_instance.ma +++ /dev/null @@ -1,16 +0,0 @@ -set "baseuri" "cic:/matita/tests/interactive/instance/". - -whelp instance \lambda A:Set.\lambda P:A \to A \to Prop.\forall x:A. P x x. -whelp instance \lambda A:Set.\lambda P:A \to A \to Prop.\forall x,y:A. P x y \to P y x. -whelp instance \lambda A:Set.\lambda P:A \to A \to Prop.\forall x,y,z:A. P x y \to P y z \to P y z. -whelp instance \lambda A:Set.\lambda f:A \to A \to A. \forall x,y:A. f x y = f y x. -whelp instance \lambda A:Set.\lambda r : A \to A \to Prop. \forall x,y,z:A. r x y \to r y z \to r x z. - - -whelp instance \lambda A:Set.\lambda R:A \to A \to Prop.\forall x:A.\forall y:A.(R x y) \to \forall z:A.(R x z) \to \exists u:A.(R y u) \land (R z u). - -whelp instance λA:Set.λR:A→A→Prop.∀x:A.∀y:A.(R x y)→∀z:A.(R x z)→∃u:A.(R y u)∧(R z u). - -whelp instance \lambda A:Set. \lambda R:A\to A\to Prop. confluence A R. - -whelp instance \lambda A:Set. \lambda f:A\to A\to A. \lambda g:A\to A\to A. \forall x,y,z : A . f x (g y z) = g (f x y ) (f x z). diff --git a/helm/matita/tests/inversion.ma b/helm/matita/tests/inversion.ma deleted file mode 100644 index 3e49e0668..000000000 --- a/helm/matita/tests/inversion.ma +++ /dev/null @@ -1,61 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/inversion_sum/". -include "legacy/coq.ma". - - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". - -inductive sum (n:nat) : nat \to nat \to Set \def - k: \forall x,y. n = x + y \to sum n x y. - - - - -theorem t: \forall x,y. \forall H: sum x y O. - match H with [ (k a b p) \Rightarrow a ] = x. - intros. - inversion H. - - (* - cut (y = y \to O = O \to match H with [ (k a b p) \Rightarrow a] = x). - apply Hcut; reflexivity. - apply - (sum_ind ? - (\lambda a,b,K. y=a \to O=b \to - match K with [ (k a b p) \Rightarrow a ] = x) - ? ? ? H). - goal 16.*) - simplify. intros. - generalize in match H1. - rewrite < H2; rewrite < H3.intro. - rewrite > H4.auto. -qed. - -theorem t1: \forall x,y. sum x y O \to x = y. -intros. - -(* -cut y=y \to O=O \to x = y. -apply Hcut.reflexivity. reflexivity. -apply (sum_ind ? (\lambda a,b,K. y=a \to O=b \to x=a) ? ? ? s).*) - -(*apply (sum_ind ? (\lambda a,b,K. y = a \to O = b \to x = a) ? ? ? s).*) -inversion s. -intros.simplify. -intros. -rewrite > H. rewrite < H2. auto. -qed. diff --git a/helm/matita/tests/inversion2.ma b/helm/matita/tests/inversion2.ma deleted file mode 100644 index 65dc75d40..000000000 --- a/helm/matita/tests/inversion2.ma +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/inversion/". -include "legacy/coq.ma". - -inductive nat : Set \def - O : nat - | S : nat \to nat. - - -inductive le (n:nat) : nat \to Prop \def - leO : le n n - | leS : \forall m. le n m \to le n (S m). - -theorem le_inv: - \forall n,m. - \forall P: nat -> nat -> Prop. - ? -> ? -> le n m -> P n m. -[7: - intros; - inversion H; - [ apply x - | simplify; - apply x1 - ] -| skip -| skip -| skip -| skip -| skip -| skip -] -qed. - -inductive ledx : nat \to nat \to Prop \def - ledxO : \forall n. ledx n n - | ledxS : \forall m.\forall n. ledx n m \to ledx n (S m). - - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". - -theorem test_inversion: \forall n. le n O \to n=O. - intros. - inversion H. - (* cut n=n \to O=O \to n=O. - apply Hcut; reflexivity. *) - (* elim H. BUG DI UNSHARING *) - (*apply (ledx_ind (\lambda x.\lambda y. n=x \to O=y \to x=y) ? ? ? ? H).*) - simplify. intros. reflexivity. - simplify. intros. discriminate H3. -qed. diff --git a/helm/matita/tests/letrec.ma b/helm/matita/tests/letrec.ma deleted file mode 100644 index 55933cd31..000000000 --- a/helm/matita/tests/letrec.ma +++ /dev/null @@ -1,25 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/letrec/". - - -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". - -let rec plus n m \def - match n with - [ O \Rightarrow m - | (S x) \Rightarrow S (plus x m) ]. diff --git a/helm/matita/tests/match_inference.ma b/helm/matita/tests/match_inference.ma deleted file mode 100644 index 0e27ce409..000000000 --- a/helm/matita/tests/match_inference.ma +++ /dev/null @@ -1,52 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/match_inference/". - -inductive pos: Set \def -| one : pos -| next : pos \to pos. - -inductive nat:Set \def -| O : nat -| S : nat \to nat. - -definition pos2nat : pos \to nat \def - \lambda x:pos . match x with - [ one \Rightarrow O - | (next z) \Rightarrow O]. - -inductive empty (x:nat) : nat \to Set \def . - -definition empty2nat : (empty O O) \to nat \def - \lambda x : (empty O O). S (match x in empty with []). - -inductive le (n:nat) : nat \to Prop \def - | le_n : le n n - | le_S : \forall m:nat. le n m \to le n (S m). - -inductive True : Prop \def - I : True. - -definition r : True \def - match (le_n O) with - [ le_n \Rightarrow I - | (le_S y p') \Rightarrow I ]. - -inductive Prod (A,B:Set): Set \def -pair : A \to B \to Prod A B. - -definition fst : \forall A,B:Set. (Prod A B) \to A \def -\lambda A,B:Set. \lambda p:(Prod A B). match p with -[(pair a b) \Rightarrow a]. diff --git a/helm/matita/tests/metasenv_ordering.ma b/helm/matita/tests/metasenv_ordering.ma deleted file mode 100644 index fc354e6ae..000000000 --- a/helm/matita/tests/metasenv_ordering.ma +++ /dev/null @@ -1,139 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/metasenv_ordering". - -include "legacy/coq.ma". - -alias num (instance 0) = "natural number". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". - -(* REWRITE *) - -theorem th1 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 2 = 2. - intros. split; split; - [ reflexivity - | rewrite > H; - [ reflexivity | exact nat | exact (0=0) | exact Type ] - ] -qed. - -theorem th2 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 3 = 3. - intros. split. split. - focus 13. - rewrite > (H ?); [reflexivity | exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -theorem th3 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 4 = 4. - intros. split. split. - focus 13. - rewrite > (H ? ?); [reflexivity | exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -theorem th4 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 5 = 5. - intros. split. split. - focus 13. - rewrite > (H ? ? ?); [reflexivity | exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -(* APPLY *) - -theorem th5 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 6 = 6. - intros. split. split. - focus 13. - apply H; [exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -theorem th6 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 7 = 7. - intros. split. split. - focus 13. - apply (H ?); [exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -theorem th7 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 8 = 8. - intros. split. split. - focus 13. - apply (H ? ?); [exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -theorem th8 : - \forall P:Prop. - \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). - 1 = 1 \land 1 = 0 \land 9 = 9. - intros. split. split. - focus 13. - apply (H ? ? ?); [exact nat | exact (0=0) | exact Type]. - unfocus. - reflexivity. - reflexivity. -qed. - -(* ELIM *) - -theorem th9: - \forall P,Q,R,S : Prop. R \to S \to \forall E:(R \to S \to P \land Q). P \land Q. - intros (P Q R S r s H). - elim (H ? ?); [split; assumption | exact r | exact s]. - qed. - -theorem th10: - \forall P,Q,R,S : Prop. R \to S \to \forall E:(R \to S \to P \land Q). P \land Q. - intros (P Q R S r s H). - elim (H ?); [split; assumption | exact r | exact s]. - qed. - -theorem th11: - \forall P,Q,R,S : Prop. R \to S \to \forall E:(R \to S \to P \land Q). P \land Q. - intros (P Q R S r s H). - elim H; [split; assumption | exact r | exact s]. - qed. diff --git a/helm/matita/tests/mysql_escaping.ma b/helm/matita/tests/mysql_escaping.ma deleted file mode 100644 index bd0eb8d5a..000000000 --- a/helm/matita/tests/mysql_escaping.ma +++ /dev/null @@ -1,17 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/mysql_escaping/". - -theorem a' : Prop \to Prop.intros.assumption.qed. diff --git a/helm/matita/tests/paramodulation.ma b/helm/matita/tests/paramodulation.ma deleted file mode 100644 index 311b9455a..000000000 --- a/helm/matita/tests/paramodulation.ma +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/paramodulation". -include "legacy/coq.ma". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". -alias num (instance 0) = "natural number". -alias symbol "times" (instance 0) = "Coq's natural times". - -theorem para1: - \forall n,m,n1,m1:nat. - n=m \to n1 = m1 \to (n + n1) = (m + m1). -intros. auto paramodulation. -qed. - -theorem para2: - \forall n:nat. n + n = 2 * n. -intros. auto paramodulation. -qed. diff --git a/helm/matita/tests/record.ma b/helm/matita/tests/record.ma deleted file mode 100644 index ed9ecfed8..000000000 --- a/helm/matita/tests/record.ma +++ /dev/null @@ -1,39 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/record/". - -record empty : Type \def {}. - -inductive True : Prop \def I: True. - -record pippo : Type \def -{ -a: Set ; -b: a \to Prop; -c: \forall x:a.(b x) \to a \to Type -}. - -record pluto (A, B:Set) : Type \def { -d: A \to B \to Prop; -e: \forall y:A.\forall z:B. (d y z) \to A \to B; -mario: \forall y:A.\forall z:B. \forall h:(d y z). \forall i : B \to Prop. - i (e y z h y) -}. - -record paperino: Prop \def { - paolo : Type; - pippo : paolo \to paolo; - piero : True -}. diff --git a/helm/matita/tests/replace.ma b/helm/matita/tests/replace.ma deleted file mode 100644 index 2b174af64..000000000 --- a/helm/matita/tests/replace.ma +++ /dev/null @@ -1,39 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/replace/". -include "legacy/coq.ma". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". -alias symbol "times" (instance 0) = "Coq's natural times". -alias id "mult_n_O" = "cic:/Coq/Init/Peano/mult_n_O.con". -alias id "plus_n_O" = "cic:/Coq/Init/Peano/plus_n_O.con". - -theorem t: \forall x:nat. x * (x + 0) = (0 + x) * (x + x * 0). - intro. - replace in \vdash (? ? (? ? %) (? % %)) with x. - reflexivity. - rewrite < (mult_n_O x). - rewrite < (plus_n_O x). - reflexivity. - reflexivity. - auto. -qed. - -(* This test tests "replace in match t" where t contains some metavariables *) -theorem t2: 2 + (3 * 4) = (5 + 5) + 2 * 2. - replace in match (5+?) with (6 + 4); [reflexivity | reflexivity]. -qed. diff --git a/helm/matita/tests/rewrite.ma b/helm/matita/tests/rewrite.ma deleted file mode 100644 index 580ad13ed..000000000 --- a/helm/matita/tests/rewrite.ma +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/rewrite/". -include "legacy/coq.ma". - -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias symbol "plus" (instance 0) = "Coq's natural plus". -alias id "plus_n_O" = "cic:/Coq/Init/Peano/plus_n_O.con". - -theorem a: - \forall a,b:nat. - a = b \to b + a + b + a= (\lambda j.((\lambda w.((\lambda x.x + b + w + j) a)) b)) a. -intros. -rewrite < H in \vdash (? ? ? ((\lambda j.((\lambda w.%) ?)) ?)). - -rewrite < H in \vdash (? ? % ?). - -simplify in \vdash (? ? ? ((\lambda _.((\lambda _.%) ?)) ?)). - -rewrite < H in \vdash (? ? ? (% ?)). -simplify. -reflexivity. -qed. - -theorem t: \forall n. 0=0 \to n = n + 0. - intros. - apply plus_n_O. -qed. - -(* In this test "rewrite < t" should open a new goal 0=0 and put it in *) -(* the goallist so that the THEN tactical closes it using reflexivity. *) -theorem foo: \forall n. n = n + 0. - intros. - rewrite < t; reflexivity. -qed. - -theorem test_rewrite_in_hyp: - \forall n,m. n + 0 = m \to m = n + 0 \to n=m \land m+0=n+0. - intros. - rewrite < plus_n_O in H. - rewrite > plus_n_O in H1. - split; [ exact H | exact H1]. -qed. - -theorem test_rewrite_in_hyp2: - \forall n,m. n + 0 = m \to n + 0 = m \to n=m \land n+0=m. - intros. - rewrite < plus_n_O in H H1 \vdash (? ? %). - split; [ exact H | exact H1]. -qed. diff --git a/helm/matita/tests/second.ma b/helm/matita/tests/second.ma deleted file mode 100644 index 450c67671..000000000 --- a/helm/matita/tests/second.ma +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/second/". -alias id "nat" = "cic:/matita/tests/first/nat.ind#xpointer(1/1)". -alias id "O" = "cic:/matita/tests/first/nat.ind#xpointer(1/1/1)". -alias id "eq" = "cic:/matita/tests/first/eq.ind#xpointer(1/1)". -alias id "refl" = "cic:/matita/tests/first/eq.ind#xpointer(1/1/1)". - -theorem ultrastupid : eq nat O O. -apply refl. -qed. - diff --git a/helm/matita/tests/simpl.ma b/helm/matita/tests/simpl.ma deleted file mode 100644 index 898122869..000000000 --- a/helm/matita/tests/simpl.ma +++ /dev/null @@ -1,39 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/simpl/". -include "legacy/coq.ma". - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -alias id "plus" = "cic:/Coq/Init/Peano/plus.con". -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -alias id "not" = "cic:/Coq/Init/Logic/not.con". -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias id "plus_comm" = "cic:/Coq/Arith/Plus/plus_comm.con". - -theorem t: let f \def \lambda x,y. x y in f (\lambda x.S x) O = S O. - intros. simplify. change in \vdash (? ? (? ? %) ?) with O. - reflexivity. qed. - -theorem X: \forall x:nat. let myplus \def plus x in myplus (S O) = S x. - intros. simplify. change in \vdash (? ? (% ?) ?) with (plus x). - -rewrite > plus_comm. reflexivity. qed. - -theorem R: \forall x:nat. let uno \def x + O in S O + uno = 1 + x. - intros. simplify. - change in \vdash (? ? (? %) ?) with (x + O). - rewrite > plus_comm. reflexivity. qed. - diff --git a/helm/matita/tests/test2.ma b/helm/matita/tests/test2.ma deleted file mode 100644 index 92d9a5330..000000000 --- a/helm/matita/tests/test2.ma +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/test2/". -include "legacy/coq.ma". - -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -alias symbol "and" (instance 0) = "Coq's logical and". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -theorem a:\forall x:nat.x=x\land x=x. -intro. -split. -reflexivity. -reflexivity. -qed. diff --git a/helm/matita/tests/test3.ma b/helm/matita/tests/test3.ma deleted file mode 100644 index cdf54906d..000000000 --- a/helm/matita/tests/test3.ma +++ /dev/null @@ -1,31 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/test3/". -include "legacy/coq.ma". - -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -theorem a:\forall x.x=x. -alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". -[ exact nat. -| intro. reflexivity. -] -qed. -alias num (instance 0) = "natural number". -alias symbol "times" (instance 0) = "Coq's natural times". - -theorem b:\forall p:nat. p * 0=0. -intro. -auto. -qed. diff --git a/helm/matita/tests/test4.ma b/helm/matita/tests/test4.ma deleted file mode 100644 index 6c3b7ec6f..000000000 --- a/helm/matita/tests/test4.ma +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/test4/". -include "legacy/coq.ma". - - -(* commento che va nell'ast, ma non viene contato - come step perche' non e' un executable -*) - -alias num (instance 0) = "natural number". -alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". -theorem a:0=0. - -(* nota *) -(** - - -apply Prop. -*) -apply cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1). - -(* commenti che non devono essere colorati perche' - non c'e' nulla di eseguibile dopo di loro -*) -qed. diff --git a/helm/matita/tests/third.ma b/helm/matita/tests/third.ma deleted file mode 100644 index 124cdc121..000000000 --- a/helm/matita/tests/third.ma +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/tests/third/". -alias id "nat" = "cic:/matita/tests/first/nat.ind#xpointer(1/1)". -alias id "O" = "cic:/matita/tests/first/nat.ind#xpointer(1/1/1)". -alias id "eq" = "cic:/matita/tests/first/eq.ind#xpointer(1/1)". -alias id "ultrastupid" = "cic:/matita/tests/second/ultrastupid.con". - -theorem iperstupid : eq nat O O. -exact ultrastupid. -qed. - diff --git a/helm/matita/tests/unfold.ma b/helm/matita/tests/unfold.ma deleted file mode 100644 index 99f3931c2..000000000 --- a/helm/matita/tests/unfold.ma +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* ___ *) -(* ||M|| *) -(* ||A|| A project by Andrea Asperti *) -(* ||T|| *) -(* ||I|| Developers: *) -(* ||T|| The HELM team. *) -(* ||A|| http://helm.cs.unibo.it *) -(* \ / *) -(* \ / This file is distributed under the terms of the *) -(* v GNU General Public License Version 2 *) -(* *) -(**************************************************************************) - -set "baseuri" "cic:/matita/unfold". - -include "legacy/coq.ma". - -alias symbol "plus" (instance 0) = "Coq's natural plus". -definition myplus \def \lambda x,y. x+y. - -alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". -lemma lem: \forall n. S (n + n) = (S n) + n. - intro; reflexivity. -qed. - -theorem trivial: \forall n. S (myplus n n) = myplus (S n) n. - unfold myplus in \vdash (\forall _.(? ? ? %)). - intro. - unfold myplus. - rewrite > lem. - reflexivity. -qed. - -(* This test needs to parse "uno" in the context of the hypothesis H, - not in the context of the goal. *) -alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". -theorem t: let uno \def S O in uno + uno = S uno \to uno=uno. - intros. unfold uno in H. - reflexivity. -qed. diff --git a/helm/ocaml/METAS/meta.helm-acic_content.src b/helm/ocaml/METAS/meta.helm-acic_content.src deleted file mode 100644 index 2ffa1551b..000000000 --- a/helm/ocaml/METAS/meta.helm-acic_content.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-cic_acic" -version="0.0.1" -archive(byte)="acic_content.cma" -archive(native)="acic_content.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-cic.src b/helm/ocaml/METAS/meta.helm-cic.src deleted file mode 100644 index 525cc9c22..000000000 --- a/helm/ocaml/METAS/meta.helm-cic.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-urimanager helm-xml expat" -version="0.0.1" -archive(byte)="cic.cma" -archive(native)="cic.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-cic_acic.src b/helm/ocaml/METAS/meta.helm-cic_acic.src deleted file mode 100644 index 51afe1bda..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_acic.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-cic_proof_checking" -version="0.0.1" -archive(byte)="cic_acic.cma" -archive(native)="cic_acic.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-cic_disambiguation.src b/helm/ocaml/METAS/meta.helm-cic_disambiguation.src deleted file mode 100644 index d2e467aae..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_disambiguation.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-whelp helm-acic_content helm-cic_unification" -version="0.0.1" -archive(byte)="cic_disambiguation.cma" -archive(native)="cic_disambiguation.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-cic_proof_checking.src b/helm/ocaml/METAS/meta.helm-cic_proof_checking.src deleted file mode 100644 index 223a182a9..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_proof_checking.src +++ /dev/null @@ -1,7 +0,0 @@ -requires="helm-cic helm-logger helm-getter" -version="0.0.1" -archive(byte)="cic_proof_checking.cma" -archive(native)="cic_proof_checking.cmxa" -archive(byte,miniReduction)="cicSubstitution.cmo cicMiniReduction.cmo" -archive(native,miniReduction)="cicSubstitution.cmx cicMiniReduction.cmx" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-cic_unification.src b/helm/ocaml/METAS/meta.helm-cic_unification.src deleted file mode 100644 index 75e2d4d31..000000000 --- a/helm/ocaml/METAS/meta.helm-cic_unification.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-cic_proof_checking helm-library" -version="0.0.1" -archive(byte)="cic_unification.cma" -archive(native)="cic_unification.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-content_pres.src b/helm/ocaml/METAS/meta.helm-content_pres.src deleted file mode 100644 index cd3d36854..000000000 --- a/helm/ocaml/METAS/meta.helm-content_pres.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-acic_content helm-utf8_macros camlp4.gramlib ulex" -version="0.0.1" -archive(byte)="content_pres.cma" -archive(native)="content_pres.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-extlib.src b/helm/ocaml/METAS/meta.helm-extlib.src deleted file mode 100644 index bfee89e3d..000000000 --- a/helm/ocaml/METAS/meta.helm-extlib.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="unix camlp4.gramlib" -version="0.0.1" -archive(byte)="extlib.cma" -archive(native)="extlib.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-getter.src b/helm/ocaml/METAS/meta.helm-getter.src deleted file mode 100644 index 8a7badf74..000000000 --- a/helm/ocaml/METAS/meta.helm-getter.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="http unix pcre zip helm-xml helm-logger helm-urimanager helm-registry" -version="0.0.1" -archive(byte)="getter.cma" -archive(native)="getter.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-grafite.src b/helm/ocaml/METAS/meta.helm-grafite.src deleted file mode 100644 index 0ae4a09d3..000000000 --- a/helm/ocaml/METAS/meta.helm-grafite.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-cic" -version="0.0.1" -archive(byte)="grafite.cma" -archive(native)="grafite.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-grafite_engine.src b/helm/ocaml/METAS/meta.helm-grafite_engine.src deleted file mode 100644 index c7203724c..000000000 --- a/helm/ocaml/METAS/meta.helm-grafite_engine.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-library helm-grafite helm-tactics" -version="0.0.1" -archive(byte)="grafite_engine.cma" -archive(native)="grafite_engine.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-grafite_parser.src b/helm/ocaml/METAS/meta.helm-grafite_parser.src deleted file mode 100644 index d921b5588..000000000 --- a/helm/ocaml/METAS/meta.helm-grafite_parser.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-lexicon helm-grafite ulex" -version="0.0.1" -archive(byte)="grafite_parser.cma" -archive(native)="grafite_parser.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-hgdome.src b/helm/ocaml/METAS/meta.helm-hgdome.src deleted file mode 100644 index d06666f43..000000000 --- a/helm/ocaml/METAS/meta.helm-hgdome.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-xml gdome2" -version="0.0.1" -archive(byte)="hgdome.cma" -archive(native)="hgdome.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-hmysql.src b/helm/ocaml/METAS/meta.helm-hmysql.src deleted file mode 100644 index 144141e28..000000000 --- a/helm/ocaml/METAS/meta.helm-hmysql.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-registry mysql helm-extlib" -version="0.0.1" -archive(byte)="hmysql.cma" -archive(native)="hmysql.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-lexicon.src b/helm/ocaml/METAS/meta.helm-lexicon.src deleted file mode 100644 index 35ab5dd36..000000000 --- a/helm/ocaml/METAS/meta.helm-lexicon.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-content_pres helm-cic_disambiguation camlp4.gramlib" -version="0.0.1" -archive(byte)="lexicon.cma" -archive(native)="lexicon.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-library.src b/helm/ocaml/METAS/meta.helm-library.src deleted file mode 100644 index d4955e05d..000000000 --- a/helm/ocaml/METAS/meta.helm-library.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-cic_acic helm-metadata" -version="0.0.1" -archive(byte)="library.cma" -archive(native)="library.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-logger.src b/helm/ocaml/METAS/meta.helm-logger.src deleted file mode 100644 index 5b2e8d8ff..000000000 --- a/helm/ocaml/METAS/meta.helm-logger.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="" -version="0.0.1" -archive(byte)="logger.cma" -archive(native)="logger.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-metadata.src b/helm/ocaml/METAS/meta.helm-metadata.src deleted file mode 100644 index a5b138301..000000000 --- a/helm/ocaml/METAS/meta.helm-metadata.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-hmysql helm-cic_proof_checking" -version="0.0.1" -archive(byte)="metadata.cma" -archive(native)="metadata.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-registry.src b/helm/ocaml/METAS/meta.helm-registry.src deleted file mode 100644 index 82d364016..000000000 --- a/helm/ocaml/METAS/meta.helm-registry.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="str netstring helm-xml" -version="0.0.1" -archive(byte)="registry.cma" -archive(native)="registry.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-tactics.src b/helm/ocaml/METAS/meta.helm-tactics.src deleted file mode 100644 index 6e704ba06..000000000 --- a/helm/ocaml/METAS/meta.helm-tactics.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-cic_proof_checking helm-cic_unification helm-whelp" -version="0.0.1" -archive(byte)="tactics.cma" -archive(native)="tactics.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-thread.src b/helm/ocaml/METAS/meta.helm-thread.src deleted file mode 100644 index 5253060d2..000000000 --- a/helm/ocaml/METAS/meta.helm-thread.src +++ /dev/null @@ -1,7 +0,0 @@ -requires="" -version="0.0.1" -archive(byte,mt)="thread.cma" -archive(native,mt)="thread.cmxa" -archive(byte)="thread_fake.cma" -archive(native)="thread_fake.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-urimanager.src b/helm/ocaml/METAS/meta.helm-urimanager.src deleted file mode 100644 index ff1874688..000000000 --- a/helm/ocaml/METAS/meta.helm-urimanager.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="str" -version="0.0.1" -archive(byte)="urimanager.cma" -archive(native)="urimanager.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-utf8_macros.src b/helm/ocaml/METAS/meta.helm-utf8_macros.src deleted file mode 100644 index c2da77649..000000000 --- a/helm/ocaml/METAS/meta.helm-utf8_macros.src +++ /dev/null @@ -1,7 +0,0 @@ -requires="" -version="0.0.1" -archive(byte)="utf8_macros.cma" -archive(native)="utf8_macros.cmxa" -requires(syntax,preprocessor)="camlp4" -archive(syntax,preprocessor)="pa_extend.cmo pa_unicode_macro.cma" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-whelp.src b/helm/ocaml/METAS/meta.helm-whelp.src deleted file mode 100644 index 20ea84329..000000000 --- a/helm/ocaml/METAS/meta.helm-whelp.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-metadata" -version="0.0.1" -archive(byte)="whelp.cma" -archive(native)="whelp.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-xml.src b/helm/ocaml/METAS/meta.helm-xml.src deleted file mode 100644 index 626e644fc..000000000 --- a/helm/ocaml/METAS/meta.helm-xml.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="zip expat helm-extlib" -version="0.0.1" -archive(byte)="xml.cma" -archive(native)="xml.cmxa" -linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-xmldiff.src b/helm/ocaml/METAS/meta.helm-xmldiff.src deleted file mode 100644 index 9cc918307..000000000 --- a/helm/ocaml/METAS/meta.helm-xmldiff.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="gdome2" -version="0.0.1" -archive(byte)="xmldiff.cma" -archive(native)="xmldiff.cmxa" diff --git a/helm/ocaml/Makefile b/helm/ocaml/Makefile deleted file mode 100644 index 2968a2405..000000000 --- a/helm/ocaml/Makefile +++ /dev/null @@ -1,124 +0,0 @@ - -export SHELL=/bin/bash - -include ../Makefile.defs - -# Warning: the modules must be in compilation order -NULL = -MODULES = \ - extlib \ - xml \ - hgdome \ - registry \ - hmysql \ - utf8_macros \ - thread \ - xmldiff \ - urimanager \ - logger \ - getter \ - cic \ - cic_proof_checking \ - cic_acic \ - acic_content \ - content_pres \ - grafite \ - metadata \ - library \ - cic_unification \ - whelp \ - tactics \ - cic_disambiguation \ - lexicon \ - grafite_engine \ - grafite_parser \ - tactics/paramodulation \ - $(NULL) - -METAS = $(filter-out %/paramodulation,$(MODULES:%=METAS/META.helm-%)) - -all: metas $(MODULES:%=%.all) -opt: metas $(MODULES:%=%.opt) -world: all opt -depend: $(MODULES:%=%.depend) -install: $(MODULES:%=%.install) -uninstall: $(MODULES:%=%.uninstall) -clean: $(MODULES:%=%.clean) clean_metas - -.stats: $(MODULES:%=%.stats) - (for m in $(MODULES); do echo -n "$$m:"; cat $$m/.stats; done) \ - | sort -t : -k 2 -n -r > .stats - -EXTRA_DIST_CLEAN = \ - libraries-clusters.ps \ - libraries-clusters.pdf \ - libraries-ext.ps \ - libraries.ps \ - .dep.dot \ - .extdep.dot \ - .clustersdep.dot \ - $(NULL) - -distclean: clean clean_metas - rm -f $(METAS) - rm -f configure config.log config.cache config.status - rm -f $(EXTRA_DIST_CLEAN) - -.PHONY: all opt world metas depend install uninstall clean clean_metas distclean - -%.all: - $(MAKE) -C $* all -%.opt: - $(MAKE) -C $* opt -%.clean: - $(MAKE) -C $* clean -%.depend: - $(MAKE) -C $* depend -%.stats: - @$(MAKE) -C $* .stats -%.install: - $(MAKE) -C $* install -%.uninstall: - $(MAKE) -C $* uninstall - -METAS/META.helm-%: METAS/meta.helm-%.src - cp $< $@ && echo "directory=\"$(shell pwd)/$*\"" >> $@ - -.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 "}" >> $@ - -.PHONY: .alldep.dot -.alldep.dot: - echo "digraph G {" > $@ - echo " rankdir = TB ;" >> $@ - for i in $(MODULES); do $(OCAMLFIND) query helm-$$i -recursive -p-format | grep -v "pxp-" | sed "s/^pxp/pxp[-*]/g" | sed "s/^/ \"helm-$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done - mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old - for i in $(MODULES); do echo "\"helm-$$i\" [shape=box,style=filled,fillcolor=yellow];" >> $@ ; done - echo "}" >> $@ - -.extdep.dot: .dep.dot - STATS/patch_deps.sh $< $@ -.clustersdep.dot: .dep.dot - USE_CLUSTERS=yes STATS/patch_deps.sh $< $@ - -libraries.ps: .dep.dot - dot -Tps -o $@ $< -libraries-ext.ps: .extdep.dot - dot -Tps -o $@ $< -libraries-clusters.ps: .clustersdep.dot - dot -Tps -o $@ $< -libraries-complete.ps: .alldep.dot - dot -Tps -o $@ $< - -ps: libraries.ps libraries-ext.ps libraries-clusters.ps - -tags: TAGS -.PHONY: TAGS -TAGS: - otags -vi -r . - diff --git a/helm/ocaml/Makefile.common b/helm/ocaml/Makefile.common deleted file mode 100644 index 9feae4f86..000000000 --- a/helm/ocaml/Makefile.common +++ /dev/null @@ -1,135 +0,0 @@ -H=@ - -# This Makefile must be included by another one defining: -# $PACKAGE -# $PREDICATES -# $INTERFACE_FILES -# $IMPLEMENTATION_FILES -# $EXTRA_OBJECTS_TO_INSTALL -# $EXTRA_OBJECTS_TO_CLEAN -# and put in a directory where there is a .depend file. - -# $OCAMLFIND must be set to a meaningful vaule, including OCAMLPATH= - -PREPROCOPTIONS = -pp camlp4o -SYNTAXOPTIONS = -syntax camlp4o -PREREQ = -OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread -OCAMLDEBUGOPTIONS = -g -OCAMLARCHIVEOPTIONS = -REQUIRES := $(shell $(OCAMLFIND) -query -format '%(requires)' helm-$(PACKAGE)) -OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(PREPROCOPTIONS) -OCAMLOPT = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(PREPROCOPTIONS) -OCAMLDEP = $(OCAMLFIND) ocamldep -package "camlp4 $(CAMLP4REQUIRES)" $(SYNTAXOPTIONS) $(OCAMLDEPOPTIONS) -OCAMLLEX = ocamllex -OCAMLYACC = ocamlyacc - -OCAMLC_P4 = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(SYNTAXOPTIONS) -OCAMLOPT_P4 = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(SYNTAXOPTIONS) - -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)) -LIBRARIES_DEPS := \ - $(foreach X,$(filter-out /usr/lib/ocaml%,$(LIBRARIES)),\ - $(wildcard \ - $(shell dirname $(X))/*.mli \ - $(shell dirname $(X))/*.ml \ - $(shell dirname $(X))/paramodulation/*.ml \ - $(shell dirname $(X))/paramodultation/*.mli)) - - -ARCHIVE = $(PACKAGE).cma -ARCHIVE_OPT = $(PACKAGE).cmxa -OBJECTS_TO_INSTALL = $(ARCHIVE) $(ARCHIVE_OPT) $(ARCHIVE_OPT:%.cmxa=%.a) \ - $(INTERFACE_FILES) $(INTERFACE_FILES:%.mli=%.cmi) \ - $(EXTRA_OBJECTS_TO_INSTALL) -DEPEND_FILES = $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) - -$(ARCHIVE): $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(LIBRARIES) - $(H)if [ $(PACKAGE) != dummy ]; then \ - echo " OCAMLC -a $@";\ - $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ - $(IMPLEMENTATION_FILES:%.ml=%.cmo); fi - -$(ARCHIVE_OPT): $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(LIBRARIES_OPT) - $(H)if [ $(PACKAGE) != dummy ]; then \ - echo " OCAMLOPT -a $@";\ - $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ - $(IMPLEMENTATION_FILES:%.ml=%.cmx); fi - -prereq: $(PREREQ) -all: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(ARCHIVE) - @echo -n -opt: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(ARCHIVE_OPT) - @echo -n -world: all opt -test: test.ml $(ARCHIVE) - $(OCAMLC) $(ARCHIVE) -linkpkg -o $@ $< -test.opt: test.ml $(ARCHIVE_OPT) - $(OCAMLOPT) $(ARCHIVE_OPT) -linkpkg -o $@ $< -install: -uninstall: - -depend: $(DEPEND_FILES) - $(OCAMLDEP) $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) > .depend - -$(PACKAGE).ps: .dep.dot - dot -Tps -o $@ $< - -.dep.dot: .depend - ocamldot < .depend > $@ - -%.cmi: %.mli - @echo " OCAMLC $<" - $(H)$(OCAMLC) -c $< -%.cmo %.cmi: %.ml - @echo " OCAMLC $<" - $(H)$(OCAMLC) -c $< -%.cmx: %.ml - @echo " OCAMLOPT $<" - $(H)$(OCAMLOPT) -c $< -%.annot: %.ml - $(OCAMLC) -dtypes $(PKGS) -c $< -%.ml %.mli: %.mly - $(OCAMLYACC) $< -%.ml: %.mll - $(OCAMLLEX) $< - -ifneq ($(MAKECMDGOALS), clean) -$(IMPLEMENTATION_FILES:%.ml=%.cmo): $(LIBRARIES) -$(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES_DEPS) -$(IMPLEMENTATION_FILES:%.ml=%.cmx): $(LIBRARIES_OPT) -endif - -clean: - rm -f *.cm[ioax] *.cmxa *.o *.a *.annot $(EXTRA_OBJECTS_TO_CLEAN) - if [ -f test ]; then rm -f test; else true; fi - if [ -f test.opt ]; then rm -f test.opt; else true; fi - -backup: - cd ..; tar cvzf $(PACKAGE)_$(shell date +%s).tar.gz $(PACKAGE) - -ocamlinit: - echo "#use \"topfind\";;" > .ocamlinit - echo "#thread;;" >> .ocamlinit - for p in $(REQUIRES); do echo "#require \"$$p\";;" >> .ocamlinit; done - echo "#load \"$(PACKAGE).cma\";;" >> .ocamlinit - -# $(STATS_EXCLUDE) may be defined in libraries' Makefile to exclude some file -# from statistics collection -STATS_FILES = \ - $(shell find . -maxdepth 1 -type f -name \*.ml $(foreach f,$(STATS_EXCLUDE),-not -name $(f))) \ - $(shell find . -maxdepth 1 -type f -name \*.mli $(foreach f,$(STATS_EXCLUDE),-not -name $(f))) -.stats: $(STATS_FILES) - rm -f .stats - echo -n "LOC:" >> .stats - wc -l $(STATS_FILES) | tail -1 | awk '{ print $$1 }' >> .stats - -.PHONY: all opt world backup depend install uninstall clean ocamlinit - -ifneq ($(MAKECMDGOALS), depend) - include .depend -endif - -NULL = - diff --git a/helm/ocaml/STATS/clusters.dot b/helm/ocaml/STATS/clusters.dot deleted file mode 100644 index b7298bce8..000000000 --- a/helm/ocaml/STATS/clusters.dot +++ /dev/null @@ -1,57 +0,0 @@ -// clusterrank = none; - fillcolor = "gray93"; - fontsize = 24; - node [fontsize = 24]; - /* libs clusters */ - subgraph cluster_presentation { - label = "Terms at the content and presentation level"; - labelloc = "b"; - labeljust = "r"; - style = "filled"; - color = "white" - acic_content; - cic_disambiguation; - content_pres; - grafite_parser; - lexicon; - } - subgraph cluster_partially { - label = "Partially specified terms"; - labelloc = "t"; - labeljust = "l"; - style = "filled"; - color = "white" - cic_unification; - tactics; - grafite; - grafite_engine; - } - subgraph cluster_fully { - label = "Fully specified terms"; - labelloc = "b"; - labeljust = "l"; - style = "filled"; - color = "white" - cic; - cic_proof_checking; - getter; - metadata; - urimanager; - whelp; - library; - cic_acic; - } - subgraph cluster_utilities { - label = "Utilities"; - labelloc = "b"; - labeljust = "r"; - style = "filled"; - color = "white" - extlib; - hgdome; - hmysql; - registry; - utf8_macros; - xml; - logger; - } diff --git a/helm/ocaml/STATS/daemons.dot b/helm/ocaml/STATS/daemons.dot deleted file mode 100644 index 4a8ba388f..000000000 --- a/helm/ocaml/STATS/daemons.dot +++ /dev/null @@ -1,19 +0,0 @@ - /* apps */ - subgraph applications { - node [shape=plaintext,style=filled,fillcolor=slategray2]; - DependencyAnalyzer [label="Dependency\nAnalyzer\n .3 klocs"]; - Getter [label="Getter\n .3 klocs"]; - Matita [label="Matita\n 6.7 klocs"]; - ProofChecker [label="Proof Checker\n .1 klocs"]; - Uwobo [label="Uwobo\n 2.1 klocs"]; - Whelp [label="Whelp\n .6 klocs"]; - } - /* apps dep */ - DependencyAnalyzer -> metadata; - Getter -> getter; - Matita -> grafite_engine; - Matita -> grafite_parser; - Matita -> hgdome; - ProofChecker -> cic_proof_checking; - Uwobo -> content_pres; - Whelp -> grafite_parser; diff --git a/helm/ocaml/STATS/deps.patch b/helm/ocaml/STATS/deps.patch deleted file mode 100644 index 90130dfe8..000000000 --- a/helm/ocaml/STATS/deps.patch +++ /dev/null @@ -1,23 +0,0 @@ ---- .clustersdep.dot 2006-01-26 10:10:46.000000000 +0100 -+++ .clustersdep.new 2006-01-26 10:10:44.000000000 +0100 -@@ -1,11 +1,8 @@ - digraph G { - xml [label="xml\n.5 klocs"]; -- xmldiff [label="xmldiff\n.3 klocs"]; - whelp [label="whelp\n.3 klocs"]; - utf8_macros [label="utf8_macros\n.2 klocs"]; - urimanager [label="urimanager\n.2 klocs"]; -- thread [label="thread\n.2 klocs"]; -- paramodulation [label="paramodulation\n5.9 klocs"]; - tactics [label="tactics\n10.0 klocs"]; - registry [label="registry\n.6 klocs"]; - metadata [label="metadata\n1.9 klocs"]; -@@ -42,7 +39,7 @@ - "cic_unification" -> "library"; - "library" -> "metadata"; - "library" -> "cic_acic"; --"metadata" -> "cic_proof_checking"; -+"metadata" -> "cic"; - "metadata" -> "hmysql"; - "grafite" -> "cic"; - "content_pres" -> "utf8_macros"; diff --git a/helm/ocaml/STATS/patch_deps.sh b/helm/ocaml/STATS/patch_deps.sh deleted file mode 100755 index d7dd7b3ba..000000000 --- a/helm/ocaml/STATS/patch_deps.sh +++ /dev/null @@ -1,53 +0,0 @@ -#!/bin/sh -# script args: source_file target_file - -use_clusters='no' -if [ ! -z "$USE_CLUSTERS" ]; then - use_clusters=$USE_CLUSTERS -fi - -# args: file snippet -# file will be modified in place -include_dot_snippet () -{ - echo "Adding to $1 graphviz snippet $2 ..." - sed -i "/digraph/r $2" $1 -} - -# args: stats file -# file will be modified in place -include_loc_stats () -{ - echo "Adding to $1 KLOCs stats from $2 ..." - tmp=`mktemp tmp.stats.XXXXXX` - for l in `cat $2`; do - module=$(basename $(echo $l | cut -d : -f 1)) - stat=$(echo $l | cut -d : -f 2) - if [ "$stat" = "LOC" ]; then - locs=$(echo $l | cut -d : -f 3) - klocs=$(echo "scale=1; $locs / 1000" | bc) - if [ "$klocs" = "0" ]; then klocs=".1"; fi - printf ' %s [label="%s\\n%s klocs"];\n' $module $module $klocs >> $tmp - fi - done - include_dot_snippet $1 $tmp - rm $tmp -} - -# args: file patch -apply_patch () -{ - if [ -f "$2" ]; then - echo "Applying to $1 patch $2 ..." - patch $1 $2 - fi -} - -cp $1 $2 -include_loc_stats $2 .stats -apply_patch $2 STATS/deps.patch -include_dot_snippet $2 STATS/daemons.dot -if [ "$use_clusters" = "yes" ]; then - include_dot_snippet $2 STATS/clusters.dot -fi - diff --git a/helm/ocaml/acic_content/.depend b/helm/ocaml/acic_content/.depend deleted file mode 100644 index f6399321e..000000000 --- a/helm/ocaml/acic_content/.depend +++ /dev/null @@ -1,30 +0,0 @@ -contentPp.cmi: content.cmi -acic2content.cmi: content.cmi -content2cic.cmi: content.cmi -cicNotationUtil.cmi: cicNotationPt.cmo -cicNotationEnv.cmi: cicNotationPt.cmo -cicNotationPp.cmi: cicNotationPt.cmo cicNotationEnv.cmi -acic2astMatcher.cmi: cicNotationPt.cmo -termAcicContent.cmi: cicNotationPt.cmo -content.cmo: content.cmi -content.cmx: content.cmi -contentPp.cmo: content.cmi contentPp.cmi -contentPp.cmx: content.cmx contentPp.cmi -acic2content.cmo: content.cmi acic2content.cmi -acic2content.cmx: content.cmx acic2content.cmi -content2cic.cmo: content.cmi content2cic.cmi -content2cic.cmx: content.cmx content2cic.cmi -cicNotationUtil.cmo: cicNotationPt.cmo cicNotationUtil.cmi -cicNotationUtil.cmx: cicNotationPt.cmx cicNotationUtil.cmi -cicNotationEnv.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationEnv.cmi -cicNotationEnv.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationEnv.cmi -cicNotationPp.cmo: cicNotationPt.cmo cicNotationEnv.cmi cicNotationPp.cmi -cicNotationPp.cmx: cicNotationPt.cmx cicNotationEnv.cmx cicNotationPp.cmi -acic2astMatcher.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \ - acic2astMatcher.cmi -acic2astMatcher.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ - acic2astMatcher.cmi -termAcicContent.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \ - acic2astMatcher.cmi termAcicContent.cmi -termAcicContent.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ - acic2astMatcher.cmx termAcicContent.cmi diff --git a/helm/ocaml/acic_content/Makefile b/helm/ocaml/acic_content/Makefile deleted file mode 100644 index 862a9eefb..000000000 --- a/helm/ocaml/acic_content/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -PACKAGE = acic_content -PREDICATES = - -INTERFACE_FILES = \ - content.mli \ - contentPp.mli \ - acic2content.mli \ - content2cic.mli \ - cicNotationUtil.mli \ - cicNotationEnv.mli \ - cicNotationPp.mli \ - acic2astMatcher.mli \ - termAcicContent.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - cicNotationPt.ml \ - $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/acic_content/acic2astMatcher.ml b/helm/ocaml/acic_content/acic2astMatcher.ml deleted file mode 100644 index d62786cc7..000000000 --- a/helm/ocaml/acic_content/acic2astMatcher.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module Ast = CicNotationPt -module Util = CicNotationUtil - -module Matcher32 = -struct - module Pattern32 = - struct - type cic_mask_t = - Blob - | Uri of UriManager.uri - | Appl of cic_mask_t list - - let uri_of_term t = CicUtil.uri_of_term (Deannotate.deannotate_term t) - - let mask_of_cic = function - | Cic.AAppl (_, tl) -> Appl (List.map (fun _ -> Blob) tl), tl - | Cic.AConst (_, _, []) - | Cic.AVar (_, _, []) - | Cic.AMutInd (_, _, _, []) - | Cic.AMutConstruct (_, _, _, _, []) as t -> Uri (uri_of_term t), [] - | _ -> Blob, [] - - let tag_of_term t = - let mask, tl = mask_of_cic t in - Hashtbl.hash mask, tl - - let mask_of_appl_pattern = function - | Ast.UriPattern uri -> Uri uri, [] - | Ast.ImplicitPattern - | Ast.VarPattern _ -> Blob, [] - | Ast.ApplPattern pl -> Appl (List.map (fun _ -> Blob) pl), pl - - let tag_of_pattern p = - let mask, pl = mask_of_appl_pattern p in - Hashtbl.hash mask, pl - - type pattern_t = Ast.cic_appl_pattern - type term_t = Cic.annterm - - let string_of_pattern = CicNotationPp.pp_cic_appl_pattern - let string_of_term t = CicPp.ppterm (Deannotate.deannotate_term t) - - let classify = function - | Ast.ImplicitPattern - | Ast.VarPattern _ -> PatternMatcher.Variable - | Ast.UriPattern _ - | Ast.ApplPattern _ -> PatternMatcher.Constructor - end - - module M = PatternMatcher.Matcher (Pattern32) - - let compiler rows = - let match_cb rows = - let pl, pid = try List.hd rows with Not_found -> assert false in - (fun matched_terms constructors -> - let env = - try - List.map2 - (fun p t -> - match p with - | Ast.ImplicitPattern -> Util.fresh_name (), t - | Ast.VarPattern name -> name, t - | _ -> assert false) - pl matched_terms - with Invalid_argument _ -> assert false - in - Some (env, constructors, pid)) - in - M.compiler rows match_cb (fun () -> None) -end - diff --git a/helm/ocaml/acic_content/acic2astMatcher.mli b/helm/ocaml/acic_content/acic2astMatcher.mli deleted file mode 100644 index 0a9ec6a6b..000000000 --- a/helm/ocaml/acic_content/acic2astMatcher.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -module Matcher32: -sig - (** @param l3_patterns level 3 (CIC) patterns (AKA cic_appl_pattern) *) - val compiler : - (CicNotationPt.cic_appl_pattern * int) list -> - (Cic.annterm -> - ((string * Cic.annterm) list * Cic.annterm list * int) option) -end - diff --git a/helm/ocaml/acic_content/acic2content.ml b/helm/ocaml/acic_content/acic2content.ml deleted file mode 100644 index 57b8502bb..000000000 --- a/helm/ocaml/acic_content/acic2content.ml +++ /dev/null @@ -1,995 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 16/6/2003 *) -(* *) -(**************************************************************************) - -(* $Id$ *) - -let object_prefix = "obj:";; -let declaration_prefix = "decl:";; -let definition_prefix = "def:";; -let inductive_prefix = "ind:";; -let joint_prefix = "joint:";; -let proof_prefix = "proof:";; -let conclude_prefix = "concl:";; -let premise_prefix = "prem:";; -let lemma_prefix = "lemma:";; - -(* e se mettessi la conversione di BY nell'apply_context ? *) -(* sarebbe carino avere l'invariante che la proof2pres -generasse sempre prove con contesto vuoto *) - -let gen_id prefix seed = - let res = prefix ^ string_of_int !seed in - incr seed ; - res -;; - -let name_of = function - Cic.Anonymous -> None - | Cic.Name b -> Some b;; - -exception Not_a_proof;; -exception NotImplemented;; -exception NotApplicable;; - -(* we do not care for positivity, here, that in any case is enforced by - well typing. Just a brutal search *) - -let rec occur uri = - let module C = Cic in - function - C.Rel _ -> false - | C.Var _ -> false - | C.Meta _ -> false - | C.Sort _ -> false - | C.Implicit _ -> assert false - | C.Prod (_,s,t) -> (occur uri s) or (occur uri t) - | C.Cast (te,ty) -> (occur uri te) - | C.Lambda (_,s,t) -> (occur uri s) or (occur uri t) (* or false ?? *) - | C.LetIn (_,s,t) -> (occur uri s) or (occur uri t) - | C.Appl l -> - List.fold_left - (fun b a -> - if b then b - else (occur uri a)) false l - | C.Const (_,_) -> false - | C.MutInd (uri1,_,_) -> if uri = uri1 then true else false - | C.MutConstruct (_,_,_,_) -> false - | C.MutCase _ -> false (* presuming too much?? *) - | C.Fix _ -> false (* presuming too much?? *) - | C.CoFix (_,_) -> false (* presuming too much?? *) -;; - -let get_id = - let module C = Cic in - function - C.ARel (id,_,_,_) -> id - | C.AVar (id,_,_) -> id - | C.AMeta (id,_,_) -> id - | C.ASort (id,_) -> id - | C.AImplicit _ -> raise NotImplemented - | C.AProd (id,_,_,_) -> id - | C.ACast (id,_,_) -> id - | C.ALambda (id,_,_,_) -> id - | C.ALetIn (id,_,_,_) -> id - | C.AAppl (id,_) -> id - | C.AConst (id,_,_) -> id - | C.AMutInd (id,_,_,_) -> id - | C.AMutConstruct (id,_,_,_,_) -> id - | C.AMutCase (id,_,_,_,_,_) -> id - | C.AFix (id,_,_) -> id - | C.ACoFix (id,_,_) -> id -;; - -let test_for_lifting ~ids_to_inner_types ~ids_to_inner_sorts= - let module C = Cic in - let module C2A = Cic2acic in - (* atomic terms are never lifted, according to my policy *) - function - C.ARel (id,_,_,_) -> false - | C.AVar (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AMeta (id,_,_) -> - (try - Hashtbl.find ids_to_inner_sorts id = `Prop - with Not_found -> assert false) - | C.ASort (id,_) -> false - | C.AImplicit _ -> raise NotImplemented - | C.AProd (id,_,_,_) -> false - | C.ACast (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.ALambda (id,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.ALetIn (id,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AAppl (id,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AConst (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AMutInd (id,_,_,_) -> false - | C.AMutConstruct (id,_,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - (* oppure: false *) - | C.AMutCase (id,_,_,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AFix (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.ACoFix (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) -;; - -(* transform a proof p into a proof list, concatenating the last -conclude element to the apply_context list, in case context is -empty. Otherwise, it just returns [p] *) - -let flat seed p = - let module K = Content in - if (p.K.proof_context = []) then - if p.K.proof_apply_context = [] then [p] - else - let p1 = - { p with - K.proof_context = []; - K.proof_apply_context = [] - } in - p.K.proof_apply_context@[p1] - else - [p] -;; - -let rec serialize seed = - function - [] -> [] - | a::l -> (flat seed a)@(serialize seed l) -;; - -(* top_down = true if the term is a LAMBDA or a decl *) -let generate_conversion seed top_down id inner_proof ~ids_to_inner_types = - let module C2A = Cic2acic in - let module K = Content in - let exp = (try ((Hashtbl.find ids_to_inner_types id).C2A.annexpected) - with Not_found -> None) - in - match exp with - None -> inner_proof - | Some expty -> - if inner_proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then - { K.proof_name = inner_proof.K.proof_name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [] ; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "TD_Conversion"; - K.conclude_args = - [K.ArgProof {inner_proof with K.proof_name = None}]; - K.conclude_conclusion = Some expty - }; - } - else - { K.proof_name = inner_proof.K.proof_name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [] ; - K.proof_apply_context = [{inner_proof with K.proof_name = None}]; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "BU_Conversion"; - K.conclude_args = - [K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = inner_proof.K.proof_id; - K.premise_binder = None; - K.premise_n = None - } - ]; - K.conclude_conclusion = Some expty - }; - } -;; - -let generate_exact seed t id name ~ids_to_inner_types = - let module C2A = Cic2acic in - let module K = Content in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed ; - K.proof_context = [] ; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Exact"; - K.conclude_args = [K.Term t]; - K.conclude_conclusion = - try Some (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - }; - } -;; - -let generate_intros_let_tac seed id n s is_intro inner_proof name ~ids_to_inner_types = - let module C2A = Cic2acic in - let module C = Cic in - let module K = Content in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed ; - K.proof_context = [] ; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Intros+LetTac"; - K.conclude_args = [K.ArgProof inner_proof]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> - (match inner_proof.K.proof_conclude.K.conclude_conclusion with - None -> None - | Some t -> - if is_intro then Some (C.AProd ("gen"^id,n,s,t)) - else Some (C.ALetIn ("gen"^id,n,s,t))) - }; - } -;; - -let build_decl_item seed id n s ~ids_to_inner_sorts = - let module K = Content in - let sort = - try - Some (Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)) - with Not_found -> None - in - match sort with - | Some `Prop -> - `Hypothesis - { K.dec_name = name_of n; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = id; - K.dec_type = s - } - | _ -> - `Declaration - { K.dec_name = name_of n; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = id; - K.dec_type = s - } -;; - -let rec build_subproofs_and_args seed l ~ids_to_inner_types ~ids_to_inner_sorts = - let module C = Cic in - let module K = Content in - let rec aux = - function - [] -> [],[] - | t::l1 -> - let subproofs,args = aux l1 in - if (test_for_lifting t ~ids_to_inner_types ~ids_to_inner_sorts) then - let new_subproof = - acic2content - seed ~name:"H" ~ids_to_inner_types ~ids_to_inner_sorts t in - let new_arg = - K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = new_subproof.K.proof_id; - K.premise_binder = new_subproof.K.proof_name; - K.premise_n = None - } in - new_subproof::subproofs,new_arg::args - else - let hd = - (match t with - C.ARel (idr,idref,n,b) -> - let sort = - (try - Hashtbl.find ids_to_inner_sorts idr - with Not_found -> `Type (CicUniv.fresh())) in - if sort = `Prop then - K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = idr; - K.premise_binder = Some b; - K.premise_n = Some n - } - else (K.Term t) - | C.AConst(id,uri,[]) -> - let sort = - (try - Hashtbl.find ids_to_inner_sorts id - with Not_found -> `Type (CicUniv.fresh())) in - if sort = `Prop then - K.Lemma - { K.lemma_id = gen_id lemma_prefix seed; - K.lemma_name = UriManager.name_of_uri uri; - K.lemma_uri = UriManager.string_of_uri uri - } - else (K.Term t) - | C.AMutConstruct(id,uri,tyno,consno,[]) -> - let sort = - (try - Hashtbl.find ids_to_inner_sorts id - with Not_found -> `Type (CicUniv.fresh())) in - if sort = `Prop then - let inductive_types = - (let o,_ = - CicEnvironment.get_obj CicUniv.empty_ugraph uri - in - match o with - | Cic.InductiveDefinition (l,_,_,_) -> l - | _ -> assert false - ) in - let (_,_,_,constructors) = - List.nth inductive_types tyno in - let name,_ = List.nth constructors (consno - 1) in - K.Lemma - { K.lemma_id = gen_id lemma_prefix seed; - K.lemma_name = name; - K.lemma_uri = - UriManager.string_of_uri uri ^ "#xpointer(1/" ^ - string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^ - ")" - } - else (K.Term t) - | _ -> (K.Term t)) in - subproofs,hd::args - in - match (aux l) with - [p],args -> - [{p with K.proof_name = None}], - List.map - (function - K.Premise prem when prem.K.premise_xref = p.K.proof_id -> - K.Premise {prem with K.premise_binder = None} - | i -> i) args - | p,a as c -> c - -and - -build_def_item seed id n t ~ids_to_inner_sorts ~ids_to_inner_types = - let module K = Content in - try - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - (let p = - (acic2content seed ?name:(name_of n) ~ids_to_inner_sorts ~ids_to_inner_types t) - in - `Proof p;) - else - `Definition - { K.def_name = name_of n; - K.def_id = gen_id definition_prefix seed; - K.def_aref = id; - K.def_term = t - } - with - Not_found -> assert false - -(* the following function must be called with an object of sort -Prop. For debugging purposes this is tested again, possibly raising an -Not_a_proof exception *) - -and acic2content seed ?name ~ids_to_inner_sorts ~ids_to_inner_types t = - let rec aux ?name t = - let module C = Cic in - let module K = Content in - let module C2A = Cic2acic in - let t1 = - match t with - C.ARel (id,idref,n,b) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AVar (id,uri,exp_named_subst) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AMeta (id,n,l) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.ASort (id,s) -> raise Not_a_proof - | C.AImplicit _ -> raise NotImplemented - | C.AProd (_,_,_,_) -> raise Not_a_proof - | C.ACast (id,v,t) -> aux v - | C.ALambda (id,n,s,t) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - let proof = aux t in - let proof' = - if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then - match proof.K.proof_conclude.K.conclude_args with - [K.ArgProof p] -> p - | _ -> assert false - else proof in - let proof'' = - { proof' with - K.proof_name = None; - K.proof_context = - (build_decl_item seed id n s ids_to_inner_sorts):: - proof'.K.proof_context - } - in - generate_intros_let_tac seed id n s true proof'' name ~ids_to_inner_types - else raise Not_a_proof - | C.ALetIn (id,n,s,t) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - let proof = aux t in - let proof' = - if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then - match proof.K.proof_conclude.K.conclude_args with - [K.ArgProof p] -> p - | _ -> assert false - else proof in - let proof'' = - { proof' with - K.proof_name = None; - K.proof_context = - ((build_def_item seed id n s ids_to_inner_sorts - ids_to_inner_types):> Cic.annterm K.in_proof_context_element) - ::proof'.K.proof_context; - } - in - generate_intros_let_tac seed id n s false proof'' name ~ids_to_inner_types - else raise Not_a_proof - | C.AAppl (id,li) -> - (try rewrite - seed name id li ~ids_to_inner_types ~ids_to_inner_sorts - with NotApplicable -> - try inductive - seed name id li ~ids_to_inner_types ~ids_to_inner_sorts - with NotApplicable -> - let subproofs, args = - build_subproofs_and_args - seed li ~ids_to_inner_types ~ids_to_inner_sorts in -(* - let args_to_lift = - List.filter (test_for_lifting ~ids_to_inner_types) li in - let subproofs = - match args_to_lift with - [_] -> List.map aux args_to_lift - | _ -> List.map (aux ~name:"H") args_to_lift in - let args = build_args seed li subproofs - ~ids_to_inner_types ~ids_to_inner_sorts in *) - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed subproofs; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Apply"; - K.conclude_args = args; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - }; - }) - | C.AConst (id,uri,exp_named_subst) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AMutInd (id,uri,i,exp_named_subst) -> raise Not_a_proof - | C.AMutConstruct (id,uri,i,j,exp_named_subst) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AMutCase (id,uri,typeno,ty,te,patterns) -> - let inductive_types,noparams = - (let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - Cic.Constant _ -> assert false - | Cic.Variable _ -> assert false - | Cic.CurrentProof _ -> assert false - | Cic.InductiveDefinition (l,_,n,_) -> l,n - ) in - let (_,_,_,constructors) = List.nth inductive_types typeno in - let name_and_arities = - let rec count_prods = - function - C.Prod (_,_,t) -> 1 + count_prods t - | _ -> 0 in - List.map - (function (n,t) -> Some n,((count_prods t) - noparams)) constructors in - let pp = - let build_proof p (name,arity) = - let rec make_context_and_body c p n = - if n = 0 then c,(aux p) - else - (match p with - Cic.ALambda(idl,vname,s1,t1) -> - let ce = - build_decl_item seed idl vname s1 ~ids_to_inner_sorts in - make_context_and_body (ce::c) t1 (n-1) - | _ -> assert false) in - let context,body = make_context_and_body [] p arity in - K.ArgProof - {body with K.proof_name = name; K.proof_context=context} in - List.map2 build_proof patterns name_and_arities in - let context,term = - (match - build_subproofs_and_args - seed ~ids_to_inner_types ~ids_to_inner_sorts [te] - with - l,[t] -> l,t - | _ -> assert false) in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed context; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Case"; - K.conclude_args = - (K.Aux (UriManager.string_of_uri uri)):: - (K.Aux (string_of_int typeno))::(K.Term ty)::term::pp; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | C.AFix (id, no, funs) -> - let proofs = - List.map - (function (_,name,_,_,bo) -> `Proof (aux ~name bo)) funs in - let fun_name = - List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no - in - let decreasing_args = - List.map (function (_,_,n,_,_) -> n) funs in - let jo = - { K.joint_id = gen_id joint_prefix seed; - K.joint_kind = `Recursive decreasing_args; - K.joint_defs = proofs - } - in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [`Joint jo]; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Exact"; - K.conclude_args = - [ K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = jo.K.joint_id; - K.premise_binder = Some fun_name; - K.premise_n = Some no; - } - ]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | C.ACoFix (id,no,funs) -> - let proofs = - List.map - (function (_,name,_,bo) -> `Proof (aux ~name bo)) funs in - let jo = - { K.joint_id = gen_id joint_prefix seed; - K.joint_kind = `CoRecursive; - K.joint_defs = proofs - } - in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [`Joint jo]; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Exact"; - K.conclude_args = - [ K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = jo.K.joint_id; - K.premise_binder = Some "tiralo fuori"; - K.premise_n = Some no; - } - ]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - }; - } - in - let id = get_id t in - generate_conversion seed false id t1 ~ids_to_inner_types -in aux ?name t - -and inductive seed name id li ~ids_to_inner_types ~ids_to_inner_sorts = - let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in - let module C2A = Cic2acic in - let module K = Content in - let module C = Cic in - match li with - C.AConst (idc,uri,exp_named_subst)::args -> - let uri_str = UriManager.string_of_uri uri in - let suffix = Str.regexp_string "_ind.con" in - let len = String.length uri_str in - let n = (try (Str.search_backward suffix uri_str len) - with Not_found -> -1) in - if n<0 then raise NotApplicable - else - let method_name = - if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists" - else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd" - else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd" - else "ByInduction" in - let prefix = String.sub uri_str 0 n in - let ind_str = (prefix ^ ".ind") in - let ind_uri = UriManager.uri_of_string ind_str in - let inductive_types,noparams = - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph ind_uri in - match o with - | Cic.InductiveDefinition (l,_,n,_) -> (l,n) - | _ -> assert false - ) in - let rec split n l = - if n = 0 then ([],l) else - let p,a = split (n-1) (List.tl l) in - ((List.hd l::p),a) in - let params_and_IP,tail_args = split (noparams+1) args in - let constructors = - (match inductive_types with - [(_,_,_,l)] -> l - | _ -> raise NotApplicable) (* don't care for mutual ind *) in - let constructors1 = - let rec clean_up n t = - if n = 0 then t else - (match t with - (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t) - | _ -> assert false) in - List.map (clean_up noparams) constructors in - let no_constructors= List.length constructors in - let args_for_cases, other_args = - split no_constructors tail_args in - let subproofs,other_method_args = - build_subproofs_and_args seed other_args - ~ids_to_inner_types ~ids_to_inner_sorts in - let method_args= - let rec build_method_args = - function - [],_-> [] (* extra args are ignored ???? *) - | (name,ty)::tlc,arg::tla -> - let idarg = get_id arg in - let sortarg = - (try (Hashtbl.find ids_to_inner_sorts idarg) - with Not_found -> `Type (CicUniv.fresh())) in - let hdarg = - if sortarg = `Prop then - let (co,bo) = - let rec bc = - function - Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) -> - let ce = - build_decl_item - seed idl n s1 ~ids_to_inner_sorts in - if (occur ind_uri s) then - ( match t1 with - Cic.ALambda(id2,n2,s2,t2) -> - let inductive_hyp = - `Hypothesis - { K.dec_name = name_of n2; - K.dec_id = - gen_id declaration_prefix seed; - K.dec_inductive = true; - K.dec_aref = id2; - K.dec_type = s2 - } in - let (context,body) = bc (t,t2) in - (ce::inductive_hyp::context,body) - | _ -> assert false) - else - ( - let (context,body) = bc (t,t1) in - (ce::context,body)) - | _ , t -> ([],aux t) in - bc (ty,arg) in - K.ArgProof - { bo with - K.proof_name = Some name; - K.proof_context = co; - }; - else (K.Term arg) in - hdarg::(build_method_args (tlc,tla)) - | _ -> assert false in - build_method_args (constructors1,args_for_cases) in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed subproofs; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = method_name; - K.conclude_args = - K.Aux (string_of_int no_constructors) - ::K.Term (C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP))) - ::method_args@other_method_args; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | _ -> raise NotApplicable - -and rewrite seed name id li ~ids_to_inner_types ~ids_to_inner_sorts = - let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in - let module C2A = Cic2acic in - let module K = Content in - let module C = Cic in - match li with - C.AConst (sid,uri,exp_named_subst)::args -> - if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or - UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI or - LibraryObjects.is_eq_ind_URI uri or - LibraryObjects.is_eq_ind_r_URI uri then - let subproofs,arg = - (match - build_subproofs_and_args - seed ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3] - with - l,[p] -> l,p - | _,_ -> assert false) in - let method_args = - let rec ma_aux n = function - [] -> [] - | a::tl -> - let hd = - if n = 0 then arg - else - let aid = get_id a in - let asort = (try (Hashtbl.find ids_to_inner_sorts aid) - with Not_found -> `Type (CicUniv.fresh())) in - if asort = `Prop then - K.ArgProof (aux a) - else K.Term a in - hd::(ma_aux (n-1) tl) in - (ma_aux 3 args) in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed subproofs; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Rewrite"; - K.conclude_args = - K.Term (C.AConst (sid,uri,exp_named_subst))::method_args; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - else raise NotApplicable - | _ -> raise NotApplicable -;; - -let map_conjectures - seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty) -= - let module K = Content in - let context' = - List.map - (function - (id,None) -> None - | (id,Some (name,Cic.ADecl t)) -> - Some - (* We should call build_decl_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Declaration - { K.dec_name = name_of name; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = get_id t; - K.dec_type = t - }) - | (id,Some (name,Cic.ADef t)) -> - Some - (* We should call build_def_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Definition - { K.def_name = name_of name; - K.def_id = gen_id definition_prefix seed; - K.def_aref = get_id t; - K.def_term = t - }) - ) context - in - (id,n,context',ty) -;; - -(* map_sequent is similar to map_conjectures, but the for the hid -of the hypothesis, which are preserved instead of generating -fresh ones. We shall have to adopt a uniform policy, soon or later *) - -let map_sequent ((id,n,context,ty):Cic.annconjecture) = - let module K = Content in - let context' = - List.map - (function - (id,None) -> None - | (id,Some (name,Cic.ADecl t)) -> - Some - (* We should call build_decl_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Declaration - { K.dec_name = name_of name; - K.dec_id = id; - K.dec_inductive = false; - K.dec_aref = get_id t; - K.dec_type = t - }) - | (id,Some (name,Cic.ADef t)) -> - Some - (* We should call build_def_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Definition - { K.def_name = name_of name; - K.def_id = id; - K.def_aref = get_id t; - K.def_term = t - }) - ) context - in - (id,n,context',ty) -;; - -let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types = - let module C = Cic in - let module K = Content in - let module C2A = Cic2acic in - let seed = ref 0 in - function - C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) -> - (gen_id object_prefix seed, params, - Some - (List.map - (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types) - conjectures), - `Def (K.Const,ty, - build_def_item seed (get_id bo) (C.Name n) bo - ~ids_to_inner_sorts ~ids_to_inner_types)) - | C.AConstant (_,_,n,Some bo,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Def (K.Const,ty, - build_def_item seed (get_id bo) (C.Name n) bo - ~ids_to_inner_sorts ~ids_to_inner_types)) - | C.AConstant (id,_,n,None,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Decl (K.Const, - build_decl_item seed id (C.Name n) ty - ~ids_to_inner_sorts)) - | C.AVariable (_,n,Some bo,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Def (K.Var,ty, - build_def_item seed (get_id bo) (C.Name n) bo - ~ids_to_inner_sorts ~ids_to_inner_types)) - | C.AVariable (id,n,None,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Decl (K.Var, - build_decl_item seed id (C.Name n) ty - ~ids_to_inner_sorts)) - | C.AInductiveDefinition (id,l,params,nparams,_) -> - (gen_id object_prefix seed, params, None, - `Joint - { K.joint_id = gen_id joint_prefix seed; - K.joint_kind = `Inductive nparams; - K.joint_defs = List.map (build_inductive seed) l - }) - -and - build_inductive seed = - let module K = Content in - fun (_,n,b,ty,l) -> - `Inductive - { K.inductive_id = gen_id inductive_prefix seed; - K.inductive_name = n; - K.inductive_kind = b; - K.inductive_type = ty; - K.inductive_constructors = build_constructors seed l - } - -and - build_constructors seed l = - let module K = Content in - List.map - (fun (n,t) -> - { K.dec_name = Some n; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = ""; - K.dec_type = t - }) l -;; - -(* -and 'term cinductiveType = - id * string * bool * 'term * (* typename, inductive, arity *) - 'term cconstructor list (* constructors *) - -and 'term cconstructor = - string * 'term -*) - - diff --git a/helm/ocaml/acic_content/acic2content.mli b/helm/ocaml/acic_content/acic2content.mli deleted file mode 100644 index e1dfb82de..000000000 --- a/helm/ocaml/acic_content/acic2content.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* 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 annobj2content : - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> - Cic.annobj -> - Cic.annterm Content.cobj - -val map_sequent : - Cic.annconjecture -> Cic.annterm Content.conjecture diff --git a/helm/ocaml/acic_content/cicNotationEnv.ml b/helm/ocaml/acic_content/cicNotationEnv.ml deleted file mode 100644 index 32d4f0df5..000000000 --- a/helm/ocaml/acic_content/cicNotationEnv.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module Ast = CicNotationPt - -type value = - | TermValue of Ast.term - | StringValue of string - | NumValue of string - | OptValue of value option - | ListValue of value list - -type value_type = - | TermType - | StringType - | NumType - | OptType of value_type - | ListType of value_type - -exception Value_not_found of string -exception Type_mismatch of string * value_type - -type declaration = string * value_type -type binding = string * (value_type * value) -type t = binding list - -let lookup env name = - try - List.assoc name env - with Not_found -> raise (Value_not_found name) - -let lookup_value env name = - try - snd (List.assoc name env) - with Not_found -> raise (Value_not_found name) - -let remove_name env name = List.remove_assoc name env - -let remove_names env names = - List.filter (fun name, _ -> not (List.mem name names)) env - -let lookup_term env name = - match lookup env name with - | _, TermValue x -> x - | ty, _ -> raise (Type_mismatch (name, ty)) - -let lookup_num env name = - match lookup env name with - | _, NumValue x -> x - | ty, _ -> raise (Type_mismatch (name, ty)) - -let lookup_string env name = - match lookup env name with - | _, StringValue x -> x - | ty, _ -> raise (Type_mismatch (name, ty)) - -let lookup_opt env name = - match lookup env name with - | _, OptValue x -> x - | ty, _ -> raise (Type_mismatch (name, ty)) - -let lookup_list env name = - match lookup env name with - | _, ListValue x -> x - | ty, _ -> raise (Type_mismatch (name, ty)) - -let opt_binding_some (n, (ty, v)) = (n, (OptType ty, OptValue (Some v))) -let opt_binding_none (n, (ty, v)) = (n, (OptType ty, OptValue None)) -let opt_binding_of_name (n, ty) = (n, (OptType ty, OptValue None)) -let list_binding_of_name (n, ty) = (n, (ListType ty, ListValue [])) -let opt_declaration (n, ty) = (n, OptType ty) -let list_declaration (n, ty) = (n, ListType ty) - -let declaration_of_var = function - | Ast.NumVar s -> s, NumType - | Ast.IdentVar s -> s, StringType - | Ast.TermVar s -> s, TermType - | _ -> assert false - -let value_of_term = function - | Ast.Num (s, _) -> NumValue s - | Ast.Ident (s, None) -> StringValue s - | t -> TermValue t - -let term_of_value = function - | NumValue s -> Ast.Num (s, 0) - | StringValue s -> Ast.Ident (s, None) - | TermValue t -> t - | _ -> assert false (* TO BE UNDERSTOOD *) - -let rec well_typed ty value = - match ty, value with - | TermType, TermValue _ - | StringType, StringValue _ - | OptType _, OptValue None - | NumType, NumValue _ -> true - | OptType ty', OptValue (Some value') -> well_typed ty' value' - | ListType ty', ListValue vl -> - List.for_all (fun value' -> well_typed ty' value') vl - | _ -> false - -let declarations_of_env = List.map (fun (name, (ty, _)) -> (name, ty)) -let declarations_of_term p = - List.map declaration_of_var (CicNotationUtil.variables_of_term p) - -let rec combine decls values = - match decls, values with - | [], [] -> [] - | (name, ty) :: decls, v :: values -> - (name, (ty, v)) :: (combine decls values) - | _ -> assert false - -let coalesce_env declarations env_list = - let env0 = List.map list_binding_of_name declarations in - let grow_env_entry env n v = - List.map - (function - | (n', (ty, ListValue vl)) as entry -> - if n' = n then n', (ty, ListValue (v :: vl)) else entry - | _ -> assert false) - env - in - let grow_env env_i env = - List.fold_left - (fun env (n, (_, v)) -> grow_env_entry env n v) - env env_i - in - List.fold_right grow_env env_list env0 - diff --git a/helm/ocaml/acic_content/cicNotationEnv.mli b/helm/ocaml/acic_content/cicNotationEnv.mli deleted file mode 100644 index d4f87097e..000000000 --- a/helm/ocaml/acic_content/cicNotationEnv.mli +++ /dev/null @@ -1,92 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** {2 Types} *) - -type value = - | TermValue of CicNotationPt.term - | StringValue of string - | NumValue of string - | OptValue of value option - | ListValue of value list - -type value_type = - | TermType - | StringType - | NumType - | OptType of value_type - | ListType of value_type - - (** looked up value not found in environment *) -exception Value_not_found of string - - (** looked up value has the wrong type - * parameters are value name and value type in environment *) -exception Type_mismatch of string * value_type - -type declaration = string * value_type -type binding = string * (value_type * value) -type t = binding list - -val declaration_of_var: CicNotationPt.pattern_variable -> declaration -val value_of_term: CicNotationPt.term -> value -val term_of_value: value -> CicNotationPt.term -val well_typed: value_type -> value -> bool - -val declarations_of_env: t -> declaration list -val declarations_of_term: CicNotationPt.term -> declaration list -val combine: declaration list -> value list -> t (** @raise Invalid_argument *) - -(** {2 Environment lookup} *) - -val lookup_value: t -> string -> value (** @raise Value_not_found *) - -(** lookup_* functions below may raise Value_not_found and Type_mismatch *) - -val lookup_term: t -> string -> CicNotationPt.term -val lookup_string: t -> string -> string -val lookup_num: t -> string -> string -val lookup_opt: t -> string -> value option -val lookup_list: t -> string -> value list - -val remove_name: t -> string -> t -val remove_names: t -> string list -> t - -(** {2 Bindings mangling} *) - -val opt_binding_some: binding -> binding (* v -> Some v *) -val opt_binding_none: binding -> binding (* v -> None *) - -val opt_binding_of_name: declaration -> binding (* None binding *) -val list_binding_of_name: declaration -> binding (* [] binding *) - -val opt_declaration: declaration -> declaration (* t -> OptType t *) -val list_declaration: declaration -> declaration (* t -> ListType t *) - -(** given a list of environments bindings a set of names n_1, ..., n_k, returns - * a single environment where n_i is bound to the list of values bound in the - * starting environments *) -val coalesce_env: declaration list -> t list -> t - diff --git a/helm/ocaml/acic_content/cicNotationPp.ml b/helm/ocaml/acic_content/cicNotationPp.ml deleted file mode 100644 index 5dc6fd821..000000000 --- a/helm/ocaml/acic_content/cicNotationPp.ml +++ /dev/null @@ -1,325 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt -module Env = CicNotationEnv - - (* when set to true debugging information, not in sync with input syntax, will - * be added to the output of pp_term. - * set to false if you need, for example, cut and paste from matitac output to - * matitatop *) -let debug_printing = true - -let pp_binder = function - | `Lambda -> "lambda" - | `Pi -> "Pi" - | `Exists -> "exists" - | `Forall -> "forall" - -let pp_literal = - if debug_printing then - (function (* debugging version *) - | `Symbol s -> sprintf "symbol(%s)" s - | `Keyword s -> sprintf "keyword(%s)" s - | `Number s -> sprintf "number(%s)" s) - else - (function - | `Symbol s - | `Keyword s - | `Number s -> s) - -let pp_assoc = - function - | Gramext.NonA -> "NonA" - | Gramext.LeftA -> "LeftA" - | Gramext.RightA -> "RightA" - -let pp_pos = - function -(* `None -> "`None" *) - | `Left -> "`Left" - | `Right -> "`Right" - | `Inner -> "`Inner" - -let pp_attribute = - function - | `IdRef id -> sprintf "x(%s)" id - | `XmlAttrs attrs -> - sprintf "X(%s)" - (String.concat ";" - (List.map (fun (_, n, v) -> sprintf "%s=%s" n v) attrs)) - | `Level (prec, assoc) -> sprintf "L(%d%s)" prec (pp_assoc assoc) - | `Raw _ -> "R" - | `Loc _ -> "@" - | `ChildPos p -> sprintf "P(%s)" (pp_pos p) - -let rec pp_term ?(pp_parens = true) t = - let t_pp = - match t with - | Ast.AttributedTerm (attr, term) when debug_printing -> - sprintf "%s[%s]" (pp_attribute attr) (pp_term ~pp_parens:false term) - | Ast.AttributedTerm (`Raw text, _) -> text - | Ast.AttributedTerm (_, term) -> pp_term ~pp_parens:false term - | Ast.Appl terms -> - sprintf "%s" (String.concat " " (List.map pp_term terms)) - | Ast.Binder (`Forall, (Ast.Ident ("_", None), typ), body) - | Ast.Binder (`Pi, (Ast.Ident ("_", None), typ), body) -> - sprintf "%s \\to %s" - (match typ with None -> "?" | Some typ -> pp_term typ) - (pp_term body) - | Ast.Binder (kind, var, body) -> - sprintf "\\%s %s.%s" (pp_binder kind) (pp_capture_variable var) - (pp_term body) - | Ast.Case (term, indtype, typ, patterns) -> - sprintf "%smatch %s%s with %s" - (match typ with None -> "" | Some t -> sprintf "[%s]" (pp_term t)) - (pp_term term) - (match indtype with - | None -> "" - | Some (ty, href_opt) -> - sprintf " in %s%s" ty - (match debug_printing, href_opt with - | true, Some uri -> - sprintf "(i.e.%s)" (UriManager.string_of_uri uri) - | _ -> "")) - (pp_patterns patterns) - | Ast.Cast (t1, t2) -> sprintf "(%s: %s)" (pp_term t1) (pp_term t2) - | Ast.LetIn (var, t1, t2) -> - sprintf "let %s = %s in %s" (pp_capture_variable var) (pp_term t1) - (pp_term t2) - | Ast.LetRec (kind, definitions, term) -> - sprintf "let %s %s in %s" - (match kind with `Inductive -> "rec" | `CoInductive -> "corec") - (String.concat " and " - (List.map - (fun (var, body, _) -> - sprintf "%s = %s" (pp_capture_variable var) (pp_term body)) - definitions)) - (pp_term term) - | Ast.Ident (name, Some []) | Ast.Ident (name, None) - | Ast.Uri (name, Some []) | Ast.Uri (name, None) -> - name - | Ast.Ident (name, Some substs) - | Ast.Uri (name, Some substs) -> - sprintf "%s \\subst [%s]" name (pp_substs substs) - | Ast.Implicit -> "?" - | Ast.Meta (index, substs) -> - sprintf "%d[%s]" index - (String.concat "; " - (List.map (function None -> "_" | Some t -> pp_term t) substs)) - | Ast.Num (num, _) -> num - | Ast.Sort `Set -> "Set" - | Ast.Sort `Prop -> "Prop" - | Ast.Sort (`Type _) -> "Type" - | Ast.Sort `CProp -> "CProp" - | Ast.Symbol (name, _) -> "'" ^ name - - | Ast.UserInput -> "" - - | Ast.Literal l -> pp_literal l - | Ast.Layout l -> pp_layout l - | Ast.Magic m -> pp_magic m - | Ast.Variable v -> pp_variable v - in - if pp_parens then sprintf "(%s)" t_pp - else t_pp - -and pp_subst (name, term) = sprintf "%s \\Assign %s" name (pp_term term) -and pp_substs substs = String.concat "; " (List.map pp_subst substs) - -and pp_pattern ((head, href, vars), term) = - let head_pp = - head ^ - (match debug_printing, href with - | true, Some uri -> sprintf "(i.e.%s)" (UriManager.string_of_uri uri) - | _ -> "") - in - sprintf "%s \\Rightarrow %s" - (match vars with - | [] -> head_pp - | _ -> - sprintf "(%s %s)" head_pp - (String.concat " " (List.map pp_capture_variable vars))) - (pp_term term) - -and pp_patterns patterns = - sprintf "[%s]" (String.concat " | " (List.map pp_pattern patterns)) - -and pp_capture_variable = function - | term, None -> pp_term term - | term, Some typ -> "(" ^ pp_term term ^ ": " ^ pp_term typ ^ ")" - -and pp_box_spec (kind, spacing, indent) = - let int_of_bool b = if b then 1 else 0 in - let kind_string = - match kind with - Ast.H -> "H" | Ast.V -> "V" | Ast.HV -> "HV" | Ast.HOV -> "HOV" - in - sprintf "%sBOX%d%d" kind_string (int_of_bool spacing) (int_of_bool indent) - -and pp_layout = function - | Ast.Sub (t1, t2) -> sprintf "%s \\SUB %s" (pp_term t1) (pp_term t2) - | Ast.Sup (t1, t2) -> sprintf "%s \\SUP %s" (pp_term t1) (pp_term t2) - | Ast.Below (t1, t2) -> sprintf "%s \\BELOW %s" (pp_term t1) (pp_term t2) - | Ast.Above (t1, t2) -> sprintf "%s \\ABOVE %s" (pp_term t1) (pp_term t2) - | Ast.Over (t1, t2) -> sprintf "[%s \\OVER %s]" (pp_term t1) (pp_term t2) - | Ast.Atop (t1, t2) -> sprintf "[%s \\ATOP %s]" (pp_term t1) (pp_term t2) - | Ast.Frac (t1, t2) -> sprintf "\\FRAC %s %s" (pp_term t1) (pp_term t2) - | Ast.Sqrt t -> sprintf "\\SQRT %s" (pp_term t) - | Ast.Root (arg, index) -> - sprintf "\\ROOT %s \\OF %s" (pp_term index) (pp_term arg) - | Ast.Break -> "\\BREAK" -(* | Space -> "\\SPACE" *) - | Ast.Box (box_spec, terms) -> - sprintf "\\%s [%s]" (pp_box_spec box_spec) - (String.concat " " (List.map pp_term terms)) - | Ast.Group terms -> - sprintf "\\GROUP [%s]" (String.concat " " (List.map pp_term terms)) - -and pp_magic = function - | Ast.List0 (t, sep_opt) -> - sprintf "list0 %s%s" (pp_term t) (pp_sep_opt sep_opt) - | Ast.List1 (t, sep_opt) -> - sprintf "list1 %s%s" (pp_term t) (pp_sep_opt sep_opt) - | Ast.Opt t -> sprintf "opt %s" (pp_term t) - | Ast.Fold (kind, p_base, names, p_rec) -> - let acc = match names with acc :: _ -> acc | _ -> assert false in - sprintf "fold %s %s rec %s %s" - (pp_fold_kind kind) (pp_term p_base) acc (pp_term p_rec) - | Ast.Default (p_some, p_none) -> - sprintf "default %s %s" (pp_term p_some) (pp_term p_none) - | Ast.If (p_test, p_true, p_false) -> - sprintf "if %s then %s else %s" - (pp_term p_test) (pp_term p_true) (pp_term p_false) - | Ast.Fail -> "fail" - -and pp_fold_kind = function - | `Left -> "left" - | `Right -> "right" - -and pp_sep_opt = function - | None -> "" - | Some sep -> sprintf " sep %s" (pp_literal sep) - -and pp_variable = function - | Ast.NumVar s -> "number " ^ s - | Ast.IdentVar s -> "ident " ^ s - | Ast.TermVar s -> "term " ^ s - | Ast.Ascription (t, n) -> assert false - | Ast.FreshVar n -> "fresh " ^ n - -let pp_term t = pp_term ~pp_parens:false t - -let pp_params = function - | [] -> "" - | params -> - " " ^ - String.concat " " - (List.map - (fun (name, typ) -> sprintf "(%s:%s)" name (pp_term typ)) - params) - -let pp_flavour = function - | `Definition -> "Definition" - | `Fact -> "Fact" - | `Goal -> "Goal" - | `Lemma -> "Lemma" - | `Remark -> "Remark" - | `Theorem -> "Theorem" - | `Variant -> "Variant" - -let pp_fields fields = - (if fields <> [] then "\n" else "") ^ - String.concat ";\n" - (List.map - (fun (name,ty,coercion) -> - " " ^ name ^ if coercion then ":>" else ": " ^ pp_term ty) fields) - -let pp_obj = function - | Ast.Inductive (params, types) -> - let pp_constructors constructors = - String.concat "\n" - (List.map (fun (name, typ) -> sprintf "| %s: %s" name (pp_term typ)) - constructors) - in - let pp_type (name, _, typ, constructors) = - sprintf "\nwith %s: %s \\def\n%s" name (pp_term typ) - (pp_constructors constructors) - in - (match types with - | [] -> assert false - | (name, inductive, typ, constructors) :: tl -> - let fst_typ_pp = - sprintf "%sinductive %s%s: %s \\def\n%s" - (if inductive then "" else "co") name (pp_params params) - (pp_term typ) (pp_constructors constructors) - in - fst_typ_pp ^ String.concat "" (List.map pp_type tl)) - | Ast.Theorem (flavour, name, typ, body) -> - sprintf "%s %s: %s %s" - (pp_flavour flavour) - name - (pp_term typ) - (match body with - | None -> "" - | Some body -> "\\def " ^ pp_term body) - | Ast.Record (params,name,ty,fields) -> - "record " ^ name ^ " " ^ pp_params params ^ " \\def {" ^ - pp_fields fields ^ "}" - -let rec pp_value = function - | Env.TermValue t -> sprintf "$%s$" (pp_term t) - | Env.StringValue s -> sprintf "\"%s\"" s - | Env.NumValue n -> n - | Env.OptValue (Some v) -> "Some " ^ pp_value v - | Env.OptValue None -> "None" - | Env.ListValue l -> sprintf "[%s]" (String.concat "; " (List.map pp_value l)) - -let rec pp_value_type = - function - | Env.TermType -> "Term" - | Env.StringType -> "String" - | Env.NumType -> "Number" - | Env.OptType t -> "Maybe " ^ pp_value_type t - | Env.ListType l -> "List " ^ pp_value_type l - -let pp_env env = - String.concat "; " - (List.map - (fun (name, (ty, value)) -> - sprintf "%s : %s = %s" name (pp_value_type ty) (pp_value value)) - env) - -let rec pp_cic_appl_pattern = function - | Ast.UriPattern uri -> UriManager.string_of_uri uri - | Ast.VarPattern name -> name - | Ast.ImplicitPattern -> "_" - | Ast.ApplPattern aps -> - sprintf "(%s)" (String.concat " " (List.map pp_cic_appl_pattern aps)) - diff --git a/helm/ocaml/acic_content/cicNotationPp.mli b/helm/ocaml/acic_content/cicNotationPp.mli deleted file mode 100644 index 57a4d6b82..000000000 --- a/helm/ocaml/acic_content/cicNotationPp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val pp_term: CicNotationPt.term -> string -val pp_obj: CicNotationPt.obj -> string - -val pp_env: CicNotationEnv.t -> string -val pp_value: CicNotationEnv.value -> string -val pp_value_type: CicNotationEnv.value_type -> string - -val pp_pos: CicNotationPt.child_pos -> string -val pp_attribute: CicNotationPt.term_attribute -> string - -val pp_cic_appl_pattern: CicNotationPt.cic_appl_pattern -> string - diff --git a/helm/ocaml/acic_content/cicNotationPt.ml b/helm/ocaml/acic_content/cicNotationPt.ml deleted file mode 100644 index a66aa5feb..000000000 --- a/helm/ocaml/acic_content/cicNotationPt.ml +++ /dev/null @@ -1,190 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -(** CIC Notation Parse Tree *) - -type binder_kind = [ `Lambda | `Pi | `Exists | `Forall ] -type induction_kind = [ `Inductive | `CoInductive ] -type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ] -type fold_kind = [ `Left | `Right ] - -type location = Token.flocation -let fail floc msg = - let (x, y) = HExtlib.loc_of_floc floc in - failwith (Printf.sprintf "Error at characters %d - %d: %s" x y msg) - -type href = UriManager.uri - -type child_pos = [ `Left | `Right | `Inner ] - -type term_attribute = - [ `Loc of location (* source file location *) - | `IdRef of string (* ACic pointer *) - | `Level of int * Gramext.g_assoc (* precedence, associativity *) - | `ChildPos of child_pos (* position of l1 pattern variables *) - | `XmlAttrs of (string option * string * string) list - (* list of XML attributes: namespace, name, value *) - | `Raw of string (* unparsed version *) - ] - -type literal = - [ `Symbol of string - | `Keyword of string - | `Number of string - ] - -type case_indtype = string * href option - -(** To be increased each time the term type below changes, used for "safe" - * marshalling *) -let magic = 1 - -type term = - (* CIC AST *) - - | AttributedTerm of term_attribute * term - - | Appl of term list - | Binder of binder_kind * capture_variable * term (* kind, name, body *) - | Case of term * case_indtype option * term option * - (case_pattern * term) list - (* what to match, inductive type, out type, list *) - | Cast of term * term - | LetIn of capture_variable * term * term (* name, body, where *) - | LetRec of induction_kind * (capture_variable * term * int) list * term - (* (name, body, decreasing argument) list, where *) - | Ident of string * subst list option - (* literal, substitutions. - * Some [] -> user has given an empty explicit substitution list - * None -> user has given no explicit substitution list *) - | Implicit - | Meta of int * meta_subst list - | Num of string * int (* literal, instance *) - | Sort of sort_kind - | Symbol of string * int (* canonical name, instance *) - - | UserInput (* place holder for user input, used by MatitaConsole, not to be - used elsewhere *) - | Uri of string * subst list option (* as Ident, for long names *) - - (* Syntax pattern extensions *) - - | Literal of literal - | Layout of layout_pattern - - | Magic of magic_term - | Variable of pattern_variable - - (* name, type. First component must be Ident or Variable (FreshVar _) *) -and capture_variable = term * term option - -and meta_subst = term option -and subst = string * term -and case_pattern = string * href option * capture_variable list - -and box_kind = H | V | HV | HOV -and box_spec = box_kind * bool * bool (* kind, spacing, indent *) - -and layout_pattern = - | Sub of term * term - | Sup of term * term - | Below of term * term - | Above of term * term - | Frac of term * term - | Over of term * term - | Atop of term * term -(* | array of term * literal option * literal option - |+ column separator, row separator +| *) - | Sqrt of term - | Root of term * term (* argument, index *) - | Break - | Box of box_spec * term list - | Group of term list - -and magic_term = - (* level 1 magics *) - | List0 of term * literal option (* pattern, separator *) - | List1 of term * literal option (* pattern, separator *) - | Opt of term - - (* level 2 magics *) - | Fold of fold_kind * term * string list * term - (* base case pattern, recursive case bound names, recursive case pattern *) - | Default of term * term (* "some" case pattern, "none" case pattern *) - | Fail - | If of term * term * term (* test, pattern if true, pattern if false *) - -and pattern_variable = - (* level 1 and 2 variables *) - | NumVar of string - | IdentVar of string - | TermVar of string - - (* level 1 variables *) - | Ascription of term * string - - (* level 2 variables *) - | FreshVar of string - -type argument_pattern = - | IdentArg of int * string (* eta-depth, name *) - -type cic_appl_pattern = - | UriPattern of UriManager.uri - | VarPattern of string - | ImplicitPattern - | ApplPattern of cic_appl_pattern list - - (** - * true means inductive, false coinductive *) -type 'term inductive_type = string * bool * 'term * (string * 'term) list - -type obj = - | Inductive of (string * term) list * term inductive_type list - (** parameters, list of loc * mutual inductive types *) - | Theorem of Cic.object_flavour * string * term * term option - (** flavour, name, type, body - * - name is absent when an unnamed theorem is being proved, tipically in - * interactive usage - * - body is present when its given along with the command, otherwise it - * will be given in proof editing mode using the tactical language - *) - | Record of (string * term) list * string * term * (string * term * bool) list - (** left parameters, name, type, fields *) - -(** {2 Standard precedences} *) - -let let_in_prec = 10 -let binder_prec = 20 -let apply_prec = 70 -let simple_prec = 90 - -let let_in_assoc = Gramext.NonA -let binder_assoc = Gramext.RightA -let apply_assoc = Gramext.LeftA -let simple_assoc = Gramext.NonA - diff --git a/helm/ocaml/acic_content/cicNotationUtil.ml b/helm/ocaml/acic_content/cicNotationUtil.ml deleted file mode 100644 index 8e487ed11..000000000 --- a/helm/ocaml/acic_content/cicNotationUtil.ml +++ /dev/null @@ -1,388 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module Ast = CicNotationPt - -let visit_ast ?(special_k = fun _ -> assert false) k = - let rec aux = function - | Ast.Appl terms -> Ast.Appl (List.map k terms) - | Ast.Binder (kind, var, body) -> - Ast.Binder (kind, aux_capture_variable var, k body) - | Ast.Case (term, indtype, typ, patterns) -> - Ast.Case (k term, indtype, aux_opt typ, aux_patterns patterns) - | Ast.Cast (t1, t2) -> Ast.Cast (k t1, k t2) - | Ast.LetIn (var, t1, t2) -> - Ast.LetIn (aux_capture_variable var, k t1, k t2) - | Ast.LetRec (kind, definitions, term) -> - let definitions = - List.map - (fun (var, ty, n) -> aux_capture_variable var, k ty, n) - definitions - in - Ast.LetRec (kind, definitions, k term) - | Ast.Ident (name, Some substs) -> - Ast.Ident (name, Some (aux_substs substs)) - | Ast.Uri (name, Some substs) -> Ast.Uri (name, Some (aux_substs substs)) - | Ast.Meta (index, substs) -> Ast.Meta (index, List.map aux_opt substs) - | (Ast.AttributedTerm _ - | Ast.Layout _ - | Ast.Literal _ - | Ast.Magic _ - | Ast.Variable _) as t -> special_k t - | (Ast.Ident _ - | Ast.Implicit - | Ast.Num _ - | Ast.Sort _ - | Ast.Symbol _ - | Ast.Uri _ - | Ast.UserInput) as t -> t - and aux_opt = function - | None -> None - | Some term -> Some (k term) - and aux_capture_variable (term, typ_opt) = k term, aux_opt typ_opt - and aux_patterns patterns = List.map aux_pattern patterns - and aux_pattern ((head, hrefs, vars), term) = - ((head, hrefs, List.map aux_capture_variable vars), k term) - and aux_subst (name, term) = (name, k term) - and aux_substs substs = List.map aux_subst substs - in - aux - -let visit_layout k = function - | Ast.Sub (t1, t2) -> Ast.Sub (k t1, k t2) - | Ast.Sup (t1, t2) -> Ast.Sup (k t1, k t2) - | Ast.Below (t1, t2) -> Ast.Below (k t1, k t2) - | Ast.Above (t1, t2) -> Ast.Above (k t1, k t2) - | Ast.Over (t1, t2) -> Ast.Over (k t1, k t2) - | Ast.Atop (t1, t2) -> Ast.Atop (k t1, k t2) - | Ast.Frac (t1, t2) -> Ast.Frac (k t1, k t2) - | Ast.Sqrt t -> Ast.Sqrt (k t) - | Ast.Root (arg, index) -> Ast.Root (k arg, k index) - | Ast.Break -> Ast.Break - | Ast.Box (kind, terms) -> Ast.Box (kind, List.map k terms) - | Ast.Group terms -> Ast.Group (List.map k terms) - -let visit_magic k = function - | Ast.List0 (t, l) -> Ast.List0 (k t, l) - | Ast.List1 (t, l) -> Ast.List1 (k t, l) - | Ast.Opt t -> Ast.Opt (k t) - | Ast.Fold (kind, t1, names, t2) -> Ast.Fold (kind, k t1, names, k t2) - | Ast.Default (t1, t2) -> Ast.Default (k t1, k t2) - | Ast.If (t1, t2, t3) -> Ast.If (k t1, k t2, k t3) - | Ast.Fail -> Ast.Fail - -let visit_variable k = function - | Ast.NumVar _ - | Ast.IdentVar _ - | Ast.TermVar _ - | Ast.FreshVar _ as t -> t - | Ast.Ascription (t, s) -> Ast.Ascription (k t, s) - -let variables_of_term t = - let rec vars = ref [] in - let add_variable v = - if List.mem v !vars then () - else vars := v :: !vars - in - let rec aux = function - | Ast.Magic m -> Ast.Magic (visit_magic aux m) - | Ast.Layout l -> Ast.Layout (visit_layout aux l) - | Ast.Variable v -> Ast.Variable (aux_variable v) - | Ast.Literal _ as t -> t - | Ast.AttributedTerm (_, t) -> aux t - | t -> visit_ast aux t - and aux_variable = function - | (Ast.NumVar _ - | Ast.IdentVar _ - | Ast.TermVar _) as t -> - add_variable t ; - t - | Ast.FreshVar _ as t -> t - | Ast.Ascription _ -> assert false - in - ignore (aux t) ; - !vars - -let names_of_term t = - let aux = function - | Ast.NumVar s - | Ast.IdentVar s - | Ast.TermVar s -> s - | _ -> assert false - in - List.map aux (variables_of_term t) - -let keywords_of_term t = - let rec keywords = ref [] in - let add_keyword k = keywords := k :: !keywords in - let rec aux = function - | Ast.AttributedTerm (_, t) -> aux t - | Ast.Layout l -> Ast.Layout (visit_layout aux l) - | Ast.Literal (`Keyword k) as t -> - add_keyword k; - t - | Ast.Literal _ as t -> t - | Ast.Magic m -> Ast.Magic (visit_magic aux m) - | Ast.Variable _ as v -> v - | t -> visit_ast aux t - in - ignore (aux t) ; - !keywords - -let rec strip_attributes t = - let special_k = function - | Ast.AttributedTerm (_, term) -> strip_attributes term - | Ast.Magic m -> Ast.Magic (visit_magic strip_attributes m) - | Ast.Variable _ as t -> t - | t -> assert false - in - visit_ast ~special_k strip_attributes t - -let rec get_idrefs = - function - | Ast.AttributedTerm (`IdRef id, t) -> id :: get_idrefs t - | Ast.AttributedTerm (_, t) -> get_idrefs t - | _ -> [] - -let meta_names_of_term term = - let rec names = ref [] in - let add_name n = - if List.mem n !names then () - else names := n :: !names - in - let rec aux = function - | Ast.AttributedTerm (_, term) -> aux term - | Ast.Appl terms -> List.iter aux terms - | Ast.Binder (_, _, body) -> aux body - | Ast.Case (term, indty, outty_opt, patterns) -> - aux term ; - aux_opt outty_opt ; - List.iter aux_branch patterns - | Ast.LetIn (_, t1, t2) -> - aux t1 ; - aux t2 - | Ast.LetRec (_, definitions, body) -> - List.iter aux_definition definitions ; - aux body - | Ast.Uri (_, Some substs) -> aux_substs substs - | Ast.Ident (_, Some substs) -> aux_substs substs - | Ast.Meta (_, substs) -> aux_meta_substs substs - - | Ast.Implicit - | Ast.Ident _ - | Ast.Num _ - | Ast.Sort _ - | Ast.Symbol _ - | Ast.Uri _ - | Ast.UserInput -> () - - | Ast.Magic magic -> aux_magic magic - | Ast.Variable var -> aux_variable var - - | _ -> assert false - and aux_opt = function - | Some term -> aux term - | None -> () - and aux_capture_var (_, ty_opt) = aux_opt ty_opt - and aux_branch (pattern, term) = - aux_pattern pattern ; - aux term - and aux_pattern (head, _, vars) = - List.iter aux_capture_var vars - and aux_definition (var, term, i) = - aux_capture_var var ; - aux term - and aux_substs substs = List.iter (fun (_, term) -> aux term) substs - and aux_meta_substs meta_substs = List.iter aux_opt meta_substs - and aux_variable = function - | Ast.NumVar name -> add_name name - | Ast.IdentVar name -> add_name name - | Ast.TermVar name -> add_name name - | Ast.FreshVar _ -> () - | Ast.Ascription _ -> assert false - and aux_magic = function - | Ast.Default (t1, t2) - | Ast.Fold (_, t1, _, t2) -> - aux t1 ; - aux t2 - | Ast.If (t1, t2, t3) -> - aux t1 ; - aux t2 ; - aux t3 - | Ast.Fail -> () - | _ -> assert false - in - aux term ; - !names - -let rectangular matrix = - let columns = Array.length matrix.(0) in - try - Array.iter (fun a -> if Array.length a <> columns then raise Exit) matrix; - true - with Exit -> false - -let ncombine ll = - let matrix = Array.of_list (List.map Array.of_list ll) in - assert (rectangular matrix); - let rows = Array.length matrix in - let columns = Array.length matrix.(0) in - let lists = ref [] in - for j = 0 to columns - 1 do - let l = ref [] in - for i = 0 to rows - 1 do - l := matrix.(i).(j) :: !l - done; - lists := List.rev !l :: !lists - done; - List.rev !lists - -let string_of_literal = function - | `Symbol s - | `Keyword s - | `Number s -> s - -let boxify = function - | [ a ] -> a - | l -> Ast.Layout (Ast.Box ((Ast.H, false, false), l)) - -let unboxify = function - | Ast.Layout (Ast.Box ((Ast.H, false, false), [ a ])) -> a - | l -> l - -let group = function - | [ a ] -> a - | l -> Ast.Layout (Ast.Group l) - -let ungroup = - let rec aux acc = - function - [] -> List.rev acc - | Ast.Layout (Ast.Group terms) :: terms' -> aux acc (terms @ terms') - | term :: terms -> aux (term :: acc) terms - in - aux [] - -let dress ~sep:sauce = - let rec aux = - function - | [] -> [] - | [hd] -> [hd] - | hd :: tl -> hd :: sauce :: aux tl - in - aux - -let dressn ~sep:sauces = - let rec aux = - function - | [] -> [] - | [hd] -> [hd] - | hd :: tl -> hd :: sauces @ aux tl - in - aux - -let find_appl_pattern_uris ap = - let rec aux acc = - function - | Ast.UriPattern uri -> uri :: acc - | Ast.ImplicitPattern - | Ast.VarPattern _ -> acc - | Ast.ApplPattern apl -> List.fold_left aux acc apl - in - let uris = aux [] ap in - HExtlib.list_uniq (List.fast_sort UriManager.compare uris) - -let rec find_branch = - function - Ast.Magic (Ast.If (_, Ast.Magic Ast.Fail, t)) -> find_branch t - | Ast.Magic (Ast.If (_, t, _)) -> find_branch t - | t -> t - -let cic_name_of_name = function - | Ast.Ident ("_", None) -> Cic.Anonymous - | Ast.Ident (name, None) -> Cic.Name name - | _ -> assert false - -let name_of_cic_name = -(* let add_dummy_xref t = Ast.AttributedTerm (`IdRef "", t) in *) - (* ZACK why we used to generate dummy xrefs? *) - let add_dummy_xref t = t in - function - | Cic.Name s -> add_dummy_xref (Ast.Ident (s, None)) - | Cic.Anonymous -> add_dummy_xref (Ast.Ident ("_", None)) - -let fresh_index = ref ~-1 - -type notation_id = int - -let fresh_id () = - incr fresh_index; - !fresh_index - - (* TODO ensure that names generated by fresh_var do not clash with user's *) -let fresh_name () = "fresh" ^ string_of_int (fresh_id ()) - -let rec freshen_term ?(index = ref 0) term = - let freshen_term = freshen_term ~index in - let fresh_instance () = incr index; !index in - let special_k = function - | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, freshen_term t) - | Ast.Layout l -> Ast.Layout (visit_layout freshen_term l) - | Ast.Magic m -> Ast.Magic (visit_magic freshen_term m) - | Ast.Variable v -> Ast.Variable (visit_variable freshen_term v) - | Ast.Literal _ as t -> t - | _ -> assert false - in - match term with - | Ast.Symbol (s, instance) -> Ast.Symbol (s, fresh_instance ()) - | Ast.Num (s, instance) -> Ast.Num (s, fresh_instance ()) - | t -> visit_ast ~special_k freshen_term t - -let freshen_obj obj = - let index = ref 0 in - let freshen_term = freshen_term ~index in - let freshen_name_ty = List.map (fun (n, t) -> (n, freshen_term t)) in - let freshen_name_ty_b = List.map (fun (n, t, b) -> (n, freshen_term t, b)) in - match obj with - | CicNotationPt.Inductive (params, indtypes) -> - let indtypes = - List.map - (fun (n, co, ty, ctors) -> (n, co, ty, freshen_name_ty ctors)) - indtypes - in - CicNotationPt.Inductive (freshen_name_ty params, indtypes) - | CicNotationPt.Theorem (flav, n, t, ty_opt) -> - let ty_opt = - match ty_opt with None -> None | Some ty -> Some (freshen_term ty) - in - CicNotationPt.Theorem (flav, n, freshen_term t, ty_opt) - | CicNotationPt.Record (params, n, ty, fields) -> - CicNotationPt.Record (freshen_name_ty params, n, freshen_term ty, - freshen_name_ty_b fields) - -let freshen_term = freshen_term ?index:None - diff --git a/helm/ocaml/acic_content/cicNotationUtil.mli b/helm/ocaml/acic_content/cicNotationUtil.mli deleted file mode 100644 index 5d309d68f..000000000 --- a/helm/ocaml/acic_content/cicNotationUtil.mli +++ /dev/null @@ -1,91 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val fresh_name: unit -> string - -val variables_of_term: CicNotationPt.term -> CicNotationPt.pattern_variable list -val names_of_term: CicNotationPt.term -> string list - - (** extract all keywords (i.e. string literals) from a level 1 pattern *) -val keywords_of_term: CicNotationPt.term -> string list - -val visit_ast: - ?special_k:(CicNotationPt.term -> CicNotationPt.term) -> - (CicNotationPt.term -> CicNotationPt.term) -> - CicNotationPt.term -> - CicNotationPt.term - -val visit_layout: - (CicNotationPt.term -> CicNotationPt.term) -> - CicNotationPt.layout_pattern -> - CicNotationPt.layout_pattern - -val visit_magic: - (CicNotationPt.term -> CicNotationPt.term) -> - CicNotationPt.magic_term -> - CicNotationPt.magic_term - -val visit_variable: - (CicNotationPt.term -> CicNotationPt.term) -> - CicNotationPt.pattern_variable -> - CicNotationPt.pattern_variable - -val strip_attributes: CicNotationPt.term -> CicNotationPt.term - - (** @return the list of proper (i.e. non recursive) IdRef of a term *) -val get_idrefs: CicNotationPt.term -> string list - - (** generalization of List.combine to n lists *) -val ncombine: 'a list list -> 'a list list - -val string_of_literal: CicNotationPt.literal -> string - -val dress: sep:'a -> 'a list -> 'a list -val dressn: sep:'a list -> 'a list -> 'a list - -val boxify: CicNotationPt.term list -> CicNotationPt.term -val group: CicNotationPt.term list -> CicNotationPt.term -val ungroup: CicNotationPt.term list -> CicNotationPt.term list - -val find_appl_pattern_uris: - CicNotationPt.cic_appl_pattern -> UriManager.uri list - -val find_branch: - CicNotationPt.term -> CicNotationPt.term - -val cic_name_of_name: CicNotationPt.term -> Cic.name -val name_of_cic_name: Cic.name -> CicNotationPt.term - - (** Symbol/Numbers instances *) - -val freshen_term: CicNotationPt.term -> CicNotationPt.term -val freshen_obj: CicNotationPt.obj -> CicNotationPt.obj - - (** Notation id handling *) - -type notation_id - -val fresh_id: unit -> notation_id - diff --git a/helm/ocaml/acic_content/content.ml b/helm/ocaml/acic_content/content.ml deleted file mode 100644 index 22733dcaa..000000000 --- a/helm/ocaml/acic_content/content.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 16/6/2003 *) -(* *) -(**************************************************************************) - -(* $Id$ *) - -type id = string;; -type joint_recursion_kind = - [ `Recursive of int list - | `CoRecursive - | `Inductive of int (* paramsno *) - | `CoInductive of int (* paramsno *) - ] -;; - -type var_or_const = Var | Const;; - -type 'term declaration = - { dec_name : string option; - dec_id : id ; - dec_inductive : bool; - dec_aref : string; - dec_type : 'term - } -;; - -type 'term definition = - { def_name : string option; - def_id : id ; - def_aref : string ; - def_term : 'term - } -;; - -type 'term inductive = - { inductive_id : id ; - inductive_name : string; - inductive_kind : bool; - inductive_type : 'term; - inductive_constructors : 'term declaration list - } -;; - -type 'term decl_context_element = - [ `Declaration of 'term declaration - | `Hypothesis of 'term declaration - ] -;; - -type ('term,'proof) def_context_element = - [ `Proof of 'proof - | `Definition of 'term definition - ] -;; - -type ('term,'proof) in_joint_context_element = - [ `Inductive of 'term inductive - | 'term decl_context_element - | ('term,'proof) def_context_element - ] -;; - -type ('term,'proof) joint = - { joint_id : id ; - joint_kind : joint_recursion_kind ; - joint_defs : ('term,'proof) in_joint_context_element list - } -;; - -type ('term,'proof) joint_context_element = - [ `Joint of ('term,'proof) joint ] -;; - -type 'term proof = - { proof_name : string option; - proof_id : id ; - proof_context : 'term in_proof_context_element list ; - proof_apply_context: 'term proof list; - proof_conclude : 'term conclude_item - } - -and 'term in_proof_context_element = - [ 'term decl_context_element - | ('term,'term proof) def_context_element - | ('term,'term proof) joint_context_element - ] - -and 'term conclude_item = - { conclude_id : id; - conclude_aref : string; - conclude_method : string; - conclude_args : ('term arg) list ; - conclude_conclusion : 'term option - } - -and 'term arg = - Aux of string - | Premise of premise - | Lemma of lemma - | Term of 'term - | ArgProof of 'term proof - | ArgMethod of string (* ???? *) - -and premise = - { premise_id: id; - premise_xref : string ; - premise_binder : string option; - premise_n : int option; - } - -and lemma = - { lemma_id: id; - lemma_name: string; - lemma_uri: string - } - -;; - -type 'term conjecture = id * int * 'term context * 'term - -and 'term context = 'term hypothesis list - -and 'term hypothesis = - ['term decl_context_element | ('term,'term proof) def_context_element ] option -;; - -type 'term in_object_context_element = - [ `Decl of var_or_const * 'term decl_context_element - | `Def of var_or_const * 'term * ('term,'term proof) def_context_element - | ('term,'term proof) joint_context_element - ] -;; - -type 'term cobj = - id * (* id *) - UriManager.uri list * (* params *) - 'term conjecture list option * (* optional metasenv *) - 'term in_object_context_element (* actual object *) -;; diff --git a/helm/ocaml/acic_content/content.mli b/helm/ocaml/acic_content/content.mli deleted file mode 100644 index c1122b8f2..000000000 --- a/helm/ocaml/acic_content/content.mli +++ /dev/null @@ -1,157 +0,0 @@ -(* 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/. - *) - -type id = string;; -type joint_recursion_kind = - [ `Recursive of int list (* decreasing arguments *) - | `CoRecursive - | `Inductive of int (* paramsno *) - | `CoInductive of int (* paramsno *) - ] -;; - -type var_or_const = Var | Const;; - -type 'term declaration = - { dec_name : string option; - dec_id : id ; - dec_inductive : bool; - dec_aref : string; - dec_type : 'term - } -;; - -type 'term definition = - { def_name : string option; - def_id : id ; - def_aref : string ; - def_term : 'term - } -;; - -type 'term inductive = - { inductive_id : id ; - inductive_name : string; - inductive_kind : bool; - inductive_type : 'term; - inductive_constructors : 'term declaration list - } -;; - -type 'term decl_context_element = - [ `Declaration of 'term declaration - | `Hypothesis of 'term declaration - ] -;; - -type ('term,'proof) def_context_element = - [ `Proof of 'proof - | `Definition of 'term definition - ] -;; - -type ('term,'proof) in_joint_context_element = - [ `Inductive of 'term inductive - | 'term decl_context_element - | ('term,'proof) def_context_element - ] -;; - -type ('term,'proof) joint = - { joint_id : id ; - joint_kind : joint_recursion_kind ; - joint_defs : ('term,'proof) in_joint_context_element list - } -;; - -type ('term,'proof) joint_context_element = - [ `Joint of ('term,'proof) joint ] -;; - -type 'term proof = - { proof_name : string option; - proof_id : id ; - proof_context : 'term in_proof_context_element list ; - proof_apply_context: 'term proof list; - proof_conclude : 'term conclude_item - } - -and 'term in_proof_context_element = - [ 'term decl_context_element - | ('term,'term proof) def_context_element - | ('term,'term proof) joint_context_element - ] - -and 'term conclude_item = - { conclude_id : id; - conclude_aref : string; - conclude_method : string; - conclude_args : ('term arg) list ; - conclude_conclusion : 'term option - } - -and 'term arg = - Aux of string - | Premise of premise - | Lemma of lemma - | Term of 'term - | ArgProof of 'term proof - | ArgMethod of string (* ???? *) - -and premise = - { premise_id: id; - premise_xref : string ; - premise_binder : string option; - premise_n : int option; - } - -and lemma = - { lemma_id: id; - lemma_name : string; - lemma_uri: string - } -;; - -type 'term conjecture = id * int * 'term context * 'term - -and 'term context = 'term hypothesis list - -and 'term hypothesis = - ['term decl_context_element | ('term,'term proof) def_context_element ] option -;; - -type 'term in_object_context_element = - [ `Decl of var_or_const * 'term decl_context_element - | `Def of var_or_const * 'term * ('term,'term proof) def_context_element - | ('term,'term proof) joint_context_element - ] -;; - -type 'term cobj = - id * (* id *) - UriManager.uri list * (* params *) - 'term conjecture list option * (* optional metasenv *) - 'term in_object_context_element (* actual object *) -;; diff --git a/helm/ocaml/acic_content/content2cic.ml b/helm/ocaml/acic_content/content2cic.ml deleted file mode 100644 index 9acea81fa..000000000 --- a/helm/ocaml/acic_content/content2cic.ml +++ /dev/null @@ -1,270 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 17/06/2003 *) -(* *) -(***************************************************************************) - -(* $Id$ *) - -exception TO_DO;; - -let proof2cic deannotate p = - let rec proof2cic premise_env p = - let module C = Cic in - let module Con = Content in - let rec extend_premise_env current_env = - function - [] -> current_env - | p::atl -> - extend_premise_env - ((p.Con.proof_id,(proof2cic current_env p))::current_env) atl in - let new_premise_env = extend_premise_env premise_env p.Con.proof_apply_context in - let body = conclude2cic new_premise_env p.Con.proof_conclude in - context2cic premise_env p.Con.proof_context body - - and context2cic premise_env context body = - List.fold_right (ce2cic premise_env) context body - - and ce2cic premise_env ce target = - let module C = Cic in - let module Con = Content in - match ce with - `Declaration d -> - (match d.Con.dec_name with - Some s -> - C.Lambda (C.Name s, deannotate d.Con.dec_type, target) - | None -> - C.Lambda (C.Anonymous, deannotate d.Con.dec_type, target)) - | `Hypothesis h -> - (match h.Con.dec_name with - Some s -> - C.Lambda (C.Name s, deannotate h.Con.dec_type, target) - | None -> - C.Lambda (C.Anonymous, deannotate h.Con.dec_type, target)) - | `Proof p -> - (match p.Con.proof_name with - Some s -> - C.LetIn (C.Name s, proof2cic premise_env p, target) - | None -> - C.LetIn (C.Anonymous, proof2cic premise_env p, target)) - | `Definition d -> - (match d.Con.def_name with - Some s -> - C.LetIn (C.Name s, proof2cic premise_env p, target) - | None -> - C.LetIn (C.Anonymous, proof2cic premise_env p, target)) - | `Joint {Con.joint_kind = kind; Con.joint_defs = defs} -> - (match target with - C.Rel n -> - (match kind with - `Recursive l -> - let funs = - List.map2 - (fun n bo -> - match bo with - `Proof bo -> - (match - bo.Con.proof_conclude.Con.conclude_conclusion, - bo.Con.proof_name - with - Some ty, Some name -> - (name,n,deannotate ty, - proof2cic premise_env bo) - | _,_ -> assert false) - | _ -> assert false) - l defs in - C.Fix (n, funs) - | `CoRecursive -> - let funs = - List.map - (function bo -> - match bo with - `Proof bo -> - (match - bo.Con.proof_conclude.Con.conclude_conclusion, - bo.Con.proof_name - with - Some ty, Some name -> - (name,deannotate ty, - proof2cic premise_env bo) - | _,_ -> assert false) - | _ -> assert false) - defs in - C.CoFix (n, funs) - | _ -> (* no inductive types in local contexts *) - assert false) - | _ -> assert false) - - and conclude2cic premise_env conclude = - let module C = Cic in - let module Con = Content in - if conclude.Con.conclude_method = "TD_Conversion" then - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> proof2cic [] p (* empty! *) - | _ -> prerr_endline "1"; assert false) - else if conclude.Con.conclude_method = "BU_Conversion" then - (match conclude.Con.conclude_args with - [Con.Premise prem] -> - (try List.assoc prem.Con.premise_xref premise_env - with Not_found -> - prerr_endline - ("Not_found in BU_Conversion: " ^ prem.Con.premise_xref); - raise Not_found) - | _ -> prerr_endline "2"; assert false) - else if conclude.Con.conclude_method = "Exact" then - (match conclude.Con.conclude_args with - [Con.Term t] -> deannotate t - | [Con.Premise prem] -> - (match prem.Con.premise_n with - None -> assert false - | Some n -> C.Rel n) - | _ -> prerr_endline "3"; assert false) - else if conclude.Con.conclude_method = "Intros+LetTac" then - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> proof2cic [] p (* empty! *) - | _ -> prerr_endline "4"; assert false) - else if (conclude.Con.conclude_method = "ByInduction" || - conclude.Con.conclude_method = "AndInd" || - conclude.Con.conclude_method = "Exists" || - conclude.Con.conclude_method = "FalseInd") then - (match (List.tl conclude.Con.conclude_args) with - Con.Term (C.AAppl ( - id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))::args -> - let subst = - List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in - let cargs = args2cic premise_env args in - let cparams_and_IP = List.map deannotate params_and_IP in - C.Appl (C.Const(uri,subst)::cparams_and_IP@cargs) - | _ -> prerr_endline "5"; assert false) - else if (conclude.Con.conclude_method = "Rewrite") then - (match conclude.Con.conclude_args with - Con.Term (C.AConst (sid,uri,exp_named_subst))::args -> - let subst = - List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in - let cargs = args2cic premise_env args in - C.Appl (C.Const(uri,subst)::cargs) - | _ -> prerr_endline "6"; assert false) - else if (conclude.Con.conclude_method = "Case") then - (match conclude.Con.conclude_args with - Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Premise(prem)::patterns -> - C.MutCase - (UriManager.uri_of_string uri, - int_of_string notype, deannotate ty, - List.assoc prem.Con.premise_xref premise_env, - List.map - (function - Con.ArgProof p -> proof2cic [] p - | _ -> prerr_endline "7a"; assert false) patterns) - | Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Term(te)::patterns -> C.MutCase - (UriManager.uri_of_string uri, - int_of_string notype, deannotate ty, deannotate te, - List.map - (function - (Con.ArgProof p) -> proof2cic [] p - | _ -> prerr_endline "7a"; assert false) patterns) - | _ -> (prerr_endline "7"; assert false)) - else if (conclude.Con.conclude_method = "Apply") then - let cargs = (args2cic premise_env conclude.Con.conclude_args) in - C.Appl cargs - else (prerr_endline "8"; assert false) - - and args2cic premise_env l = - List.map (arg2cic premise_env) l - - and arg2cic premise_env = - let module C = Cic in - let module Con = Content in - function - Con.Aux n -> prerr_endline "8"; assert false - | Con.Premise prem -> - (match prem.Con.premise_n with - Some n -> C.Rel n - | None -> - (try List.assoc prem.Con.premise_xref premise_env - with Not_found -> - prerr_endline ("Not_found in arg2cic: premise " ^ (match prem.Con.premise_binder with None -> "previous" | Some p -> p) ^ ", xref=" ^ prem.Con.premise_xref); - raise Not_found)) - | Con.Lemma lemma -> - CicUtil.term_of_uri (UriManager.uri_of_string lemma.Con.lemma_uri) - | Con.Term t -> deannotate t - | Con.ArgProof p -> proof2cic [] p (* empty! *) - | Con.ArgMethod s -> raise TO_DO - -in proof2cic [] p -;; - -exception ToDo;; - -let cobj2obj deannotate (id,params,metasenv,obj) = - let module K = Content in - match obj with - `Def (Content.Const,ty,`Proof bo) -> - (match metasenv with - None -> - Cic.Constant - (id, Some (proof2cic deannotate bo), deannotate ty, params, []) - | Some metasenv' -> - let metasenv'' = - List.map - (function (_,i,canonical_context,term) -> - let canonical_context' = - List.map - (function - None -> None - | Some (`Declaration d) - | Some (`Hypothesis d) -> - (match d with - {K.dec_name = Some n ; K.dec_type = t} -> - Some (Cic.Name n, Cic.Decl (deannotate t)) - | _ -> assert false) - | Some (`Definition d) -> - (match d with - {K.def_name = Some n ; K.def_term = t} -> - Some (Cic.Name n, Cic.Def ((deannotate t),None)) - | _ -> assert false) - | Some (`Proof d) -> - (match d with - {K.proof_name = Some n } -> - Some (Cic.Name n, - Cic.Def ((proof2cic deannotate d),None)) - | _ -> assert false) - ) canonical_context - in - (i,canonical_context',deannotate term) - ) metasenv' - in - Cic.CurrentProof - (id, metasenv'', proof2cic deannotate bo, deannotate ty, params, - [])) - | _ -> raise ToDo -;; - -let cobj2obj = cobj2obj Deannotate.deannotate_term;; diff --git a/helm/ocaml/acic_content/content2cic.mli b/helm/ocaml/acic_content/content2cic.mli deleted file mode 100644 index 9bb6509cc..000000000 --- a/helm/ocaml/acic_content/content2cic.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 27/6/2003 *) -(* *) -(**************************************************************************) - -val cobj2obj : Cic.annterm Content.cobj -> Cic.obj diff --git a/helm/ocaml/acic_content/contentPp.ml b/helm/ocaml/acic_content/contentPp.ml deleted file mode 100644 index ca89fad7d..000000000 --- a/helm/ocaml/acic_content/contentPp.ml +++ /dev/null @@ -1,158 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 17/06/2003 *) -(* *) -(***************************************************************************) - -(* $Id$ *) - -exception ContentPpInternalError;; -exception NotEnoughElements;; -exception TO_DO - -(* Utility functions *) - - -let string_of_name = - function - Some s -> s - | None -> "_" -;; - -(* get_nth l n returns the nth element of the list l if it exists or *) -(* raises NotEnoughElements if l has less than n elements *) -let rec get_nth l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth tail (n-1) - | (_,_) -> raise NotEnoughElements -;; - -let rec blanks n = - if n = 0 then "" - else (" " ^ (blanks (n-1)));; - -let rec pproof (p: Cic.annterm Content.proof) indent = - let module Con = Content in - let new_indent = - (match p.Con.proof_name with - Some s -> - prerr_endline - ((blanks indent) ^ "(" ^ s ^ ")"); flush stderr ;(indent + 1) - | None ->indent) in - let new_indent1 = - if (p.Con.proof_context = []) then new_indent - else - (pcontext p.Con.proof_context new_indent; (new_indent + 1)) in - papply_context p.Con.proof_apply_context new_indent1; - pconclude p.Con.proof_conclude new_indent1; - -and pcontext c indent = - List.iter (pcontext_element indent) c - -and pcontext_element indent = - let module Con = Content in - function - `Declaration d -> - (match d.Con.dec_name with - Some s -> - prerr_endline - ((blanks indent) - ^ "Assume " ^ s ^ " : " - ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.dec_type))); - flush stderr - | None -> - prerr_endline ((blanks indent) ^ "NO NAME!!")) - | `Hypothesis h -> - (match h.Con.dec_name with - Some s -> - prerr_endline - ((blanks indent) - ^ "Suppose " ^ s ^ " : " - ^ (CicPp.ppterm (Deannotate.deannotate_term h.Con.dec_type))); - flush stderr - | None -> - prerr_endline ((blanks indent) ^ "NO NAME!!")) - | `Proof p -> pproof p indent - | `Definition d -> - (match d.Con.def_name with - Some s -> - prerr_endline - ((blanks indent) ^ "Let " ^ s ^ " = " - ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.def_term))); - flush stderr - | None -> - prerr_endline ((blanks indent) ^ "NO NAME!!")) - | `Joint ho -> - prerr_endline ((blanks indent) ^ "Joint Def"); - flush stderr - -and papply_context ac indent = - List.iter(function p -> (pproof p indent)) ac - -and pconclude concl indent = - let module Con = Content in - prerr_endline ((blanks indent) ^ "Apply method " ^ concl.Con.conclude_method ^ " to");flush stderr; - pargs concl.Con.conclude_args indent; - match concl.Con.conclude_conclusion with - None -> prerr_endline ((blanks indent) ^"No conclude conclusion");flush stderr - | Some t -> prerr_endline ((blanks indent) ^ "conclude" ^ concl.Con.conclude_method ^ (CicPp.ppterm (Deannotate.deannotate_term t)));flush stderr - -and pargs args indent = - List.iter (parg indent) args - -and parg indent = - let module Con = Content in - function - Con.Aux n -> prerr_endline ((blanks (indent+1)) ^ n) - | Con.Premise prem -> prerr_endline ((blanks (indent+1)) ^ "Premise") - | Con.Lemma lemma -> prerr_endline ((blanks (indent+1)) ^ "Lemma") - | Con.Term t -> - prerr_endline ((blanks (indent+1)) ^ (CicPp.ppterm (Deannotate.deannotate_term t))) - | Con.ArgProof p -> pproof p (indent+1) - | Con.ArgMethod s -> prerr_endline ((blanks (indent+1)) ^ "A Method !!!") -;; - -let print_proof p = pproof p 0;; - -let print_obj (_,_,_,obj) = - match obj with - `Decl (_,decl) -> - pcontext_element 0 (decl:> Cic.annterm Content.in_proof_context_element) - | `Def (_,_,def) -> - pcontext_element 0 (def:> Cic.annterm Content.in_proof_context_element) - | `Joint _ as jo -> pcontext_element 0 jo -;; - - - - - diff --git a/helm/ocaml/acic_content/contentPp.mli b/helm/ocaml/acic_content/contentPp.mli deleted file mode 100644 index a160ab1ff..000000000 --- a/helm/ocaml/acic_content/contentPp.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* 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 print_proof: Cic.annterm Content.proof -> unit - -val print_obj: Cic.annterm Content.cobj -> unit - -val parg: int -> Cic.annterm Content.arg ->unit diff --git a/helm/ocaml/acic_content/termAcicContent.ml b/helm/ocaml/acic_content/termAcicContent.ml deleted file mode 100644 index fddd777f7..000000000 --- a/helm/ocaml/acic_content/termAcicContent.ml +++ /dev/null @@ -1,371 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) else () - -type interpretation_id = int - -let idref id t = Ast.AttributedTerm (`IdRef id, t) - -type term_info = - { sort: (Cic.id, Ast.sort_kind) Hashtbl.t; - uri: (Cic.id, UriManager.uri) Hashtbl.t; - } - -let get_types uri = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - | Cic.InductiveDefinition (l,_,_,_) -> l - | _ -> assert false - -let name_of_inductive_type uri i = - let types = get_types uri in - let (name, _, _, _) = try List.nth types i with Not_found -> assert false in - name - - (* returns pairs *) -let constructors_of_inductive_type uri i = - let types = get_types uri in - let (_, _, _, constructors) = - try List.nth types i with Not_found -> assert false - in - constructors - - (* returns name only *) -let constructor_of_inductive_type uri i j = - (try - fst (List.nth (constructors_of_inductive_type uri i) (j-1)) - with Not_found -> assert false) - -let ast_of_acic0 term_info acic k = - let k = k term_info in - let id_to_uris = term_info.uri in - let register_uri id uri = Hashtbl.add id_to_uris id uri in - let sort_of_id id = - try - Hashtbl.find term_info.sort id - with Not_found -> - prerr_endline (sprintf "warning: sort of id %s not found, using Type" id); - `Type (CicUniv.fresh ()) - in - let aux_substs substs = - Some - (List.map - (fun (uri, annterm) -> (UriManager.name_of_uri uri, k annterm)) - substs) - in - let aux_context context = - List.map - (function - | None -> None - | Some annterm -> Some (k annterm)) - context - in - let aux = function - | Cic.ARel (id,_,_,b) -> idref id (Ast.Ident (b, None)) - | Cic.AVar (id,uri,substs) -> - register_uri id uri; - idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs)) - | Cic.AMeta (id,n,l) -> idref id (Ast.Meta (n, aux_context l)) - | Cic.ASort (id,Cic.Prop) -> idref id (Ast.Sort `Prop) - | Cic.ASort (id,Cic.Set) -> idref id (Ast.Sort `Set) - | Cic.ASort (id,Cic.Type u) -> idref id (Ast.Sort (`Type u)) - | Cic.ASort (id,Cic.CProp) -> idref id (Ast.Sort `CProp) - | Cic.AImplicit (id, Some `Hole) -> idref id Ast.UserInput - | Cic.AImplicit (id, _) -> idref id Ast.Implicit - | Cic.AProd (id,n,s,t) -> - let binder_kind = - match sort_of_id id with - | `Set | `Type _ -> `Pi - | `Prop | `CProp -> `Forall - in - idref id (Ast.Binder (binder_kind, - (CicNotationUtil.name_of_cic_name n, Some (k s)), k t)) - | Cic.ACast (id,v,t) -> idref id (Ast.Cast (k v, k t)) - | Cic.ALambda (id,n,s,t) -> - idref id (Ast.Binder (`Lambda, - (CicNotationUtil.name_of_cic_name n, Some (k s)), k t)) - | Cic.ALetIn (id,n,s,t) -> - idref id (Ast.LetIn ((CicNotationUtil.name_of_cic_name n, None), - k s, k t)) - | Cic.AAppl (aid,args) -> idref aid (Ast.Appl (List.map k args)) - | Cic.AConst (id,uri,substs) -> - register_uri id uri; - idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs)) - | Cic.AMutInd (id,uri,i,substs) -> - let name = name_of_inductive_type uri i in - let uri_str = UriManager.string_of_uri uri in - let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (i+1) in - register_uri id (UriManager.uri_of_string puri_str); - idref id (Ast.Ident (name, aux_substs substs)) - | Cic.AMutConstruct (id,uri,i,j,substs) -> - let name = constructor_of_inductive_type uri i j in - let uri_str = UriManager.string_of_uri uri in - let puri_str = sprintf "%s#xpointer(1/%d/%d)" uri_str (i + 1) j in - register_uri id (UriManager.uri_of_string puri_str); - idref id (Ast.Ident (name, aux_substs substs)) - | Cic.AMutCase (id,uri,typeno,ty,te,patterns) -> - let name = name_of_inductive_type uri typeno in - let uri_str = UriManager.string_of_uri uri in - let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (typeno+1) in - let ctor_puri j = - UriManager.uri_of_string - (sprintf "%s#xpointer(1/%d/%d)" uri_str (typeno+1) j) - in - let case_indty = name, Some (UriManager.uri_of_string puri_str) in - let constructors = constructors_of_inductive_type uri typeno in - let rec eat_branch ty pat = - match (ty, pat) with - | Cic.Prod (_, _, t), Cic.ALambda (_, name, s, t') -> - let (cv, rhs) = eat_branch t t' in - (CicNotationUtil.name_of_cic_name name, Some (k s)) :: cv, rhs - | _, _ -> [], k pat - in - let j = ref 0 in - let patterns = - try - List.map2 - (fun (name, ty) pat -> - incr j; - let (capture_variables, rhs) = eat_branch ty pat in - ((name, Some (ctor_puri !j), capture_variables), rhs)) - constructors patterns - with Invalid_argument _ -> assert false - in - idref id (Ast.Case (k te, Some case_indty, Some (k ty), patterns)) - | Cic.AFix (id, no, funs) -> - let defs = - List.map - (fun (_, n, decr_idx, ty, bo) -> - ((Ast.Ident (n, None), Some (k ty)), k bo, decr_idx)) - funs - in - let name = - try - (match List.nth defs no with - | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n - | _ -> assert false) - with Not_found -> assert false - in - idref id (Ast.LetRec (`Inductive, defs, Ast.Ident (name, None))) - | Cic.ACoFix (id, no, funs) -> - let defs = - List.map - (fun (_, n, ty, bo) -> - ((Ast.Ident (n, None), Some (k ty)), k bo, 0)) - funs - in - let name = - try - (match List.nth defs no with - | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n - | _ -> assert false) - with Not_found -> assert false - in - idref id (Ast.LetRec (`CoInductive, defs, Ast.Ident (name, None))) - in - aux acic - - (* persistent state *) - -let level2_patterns32 = Hashtbl.create 211 -let interpretations = Hashtbl.create 211 (* symb -> id list ref *) - -let compiled32 = ref None -let pattern32_matrix = ref [] - -let get_compiled32 () = - match !compiled32 with - | None -> assert false - | Some f -> Lazy.force f - -let set_compiled32 f = compiled32 := Some f - -let add_idrefs = - List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t)) - -let instantiate32 term_info idrefs env symbol args = - let rec instantiate_arg = function - | Ast.IdentArg (n, name) -> - let t = (try List.assoc name env with Not_found -> assert false) in - let rec count_lambda = function - | Ast.AttributedTerm (_, t) -> count_lambda t - | Ast.Binder (`Lambda, _, body) -> 1 + count_lambda body - | _ -> 0 - in - let rec add_lambda t n = - if n > 0 then - let name = CicNotationUtil.fresh_name () in - Ast.Binder (`Lambda, (Ast.Ident (name, None), None), - Ast.Appl [add_lambda t (n - 1); Ast.Ident (name, None)]) - else - t - in - add_lambda t (n - count_lambda t) - in - let head = - let symbol = Ast.Symbol (symbol, 0) in - add_idrefs idrefs symbol - in - if args = [] then head - else Ast.Appl (head :: List.map instantiate_arg args) - -let rec ast_of_acic1 term_info annterm = - let id_to_uris = term_info.uri in - let register_uri id uri = Hashtbl.add id_to_uris id uri in - match (get_compiled32 ()) annterm with - | None -> ast_of_acic0 term_info annterm ast_of_acic1 - | Some (env, ctors, pid) -> - let idrefs = - List.map - (fun annterm -> - let idref = CicUtil.id_of_annterm annterm in - (try - register_uri idref - (CicUtil.uri_of_term (Deannotate.deannotate_term annterm)) - with Invalid_argument _ -> ()); - idref) - ctors - in - let env' = - List.map (fun (name, term) -> (name, ast_of_acic1 term_info term)) env - in - let _, symbol, args, _ = - try - Hashtbl.find level2_patterns32 pid - with Not_found -> assert false - in - let ast = instantiate32 term_info idrefs env' symbol args in - Ast.AttributedTerm (`IdRef (CicUtil.id_of_annterm annterm), ast) - -let load_patterns32 t = - let t = - HExtlib.filter_map (function (true, ap, id) -> Some (ap, id) | _ -> None) t - in - set_compiled32 (lazy (Acic2astMatcher.Matcher32.compiler t)) - -let ast_of_acic id_to_sort annterm = - debug_print (lazy ("ast_of_acic <- " - ^ CicPp.ppterm (Deannotate.deannotate_term annterm))); - let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in - let ast = ast_of_acic1 term_info annterm in - debug_print (lazy ("ast_of_acic -> " ^ CicNotationPp.pp_term ast)); - ast, term_info.uri - -let fresh_id = - let counter = ref ~-1 in - fun () -> - incr counter; - !counter - -let add_interpretation dsc (symbol, args) appl_pattern = - let id = fresh_id () in - Hashtbl.add level2_patterns32 id (dsc, symbol, args, appl_pattern); - pattern32_matrix := (true, appl_pattern, id) :: !pattern32_matrix; - load_patterns32 !pattern32_matrix; - (try - let ids = Hashtbl.find interpretations symbol in - ids := id :: !ids - with Not_found -> Hashtbl.add interpretations symbol (ref [id])); - id - -let get_all_interpretations () = - List.map - (function (_, _, id) -> - let (dsc, _, _, _) = - try - Hashtbl.find level2_patterns32 id - with Not_found -> assert false - in - (id, dsc)) - !pattern32_matrix - -let get_active_interpretations () = - HExtlib.filter_map (function (true, _, id) -> Some id | _ -> None) - !pattern32_matrix - -let set_active_interpretations ids = - let pattern32_matrix' = - List.map - (function - | (_, ap, id) when List.mem id ids -> (true, ap, id) - | (_, ap, id) -> (false, ap, id)) - !pattern32_matrix - in - pattern32_matrix := pattern32_matrix'; - load_patterns32 !pattern32_matrix - -exception Interpretation_not_found - -let lookup_interpretations symbol = - try - HExtlib.list_uniq - (List.sort Pervasives.compare - (List.map - (fun id -> - let (dsc, _, args, appl_pattern) = - try - Hashtbl.find level2_patterns32 id - with Not_found -> assert false - in - dsc, args, appl_pattern) - !(Hashtbl.find interpretations symbol))) - with Not_found -> raise Interpretation_not_found - -let remove_interpretation id = - (try - let _, symbol, _, _ = Hashtbl.find level2_patterns32 id in - let ids = Hashtbl.find interpretations symbol in - ids := List.filter ((<>) id) !ids; - Hashtbl.remove level2_patterns32 id; - with Not_found -> raise Interpretation_not_found); - pattern32_matrix := - List.filter (fun (_, _, id') -> id <> id') !pattern32_matrix; - load_patterns32 !pattern32_matrix - -let _ = load_patterns32 [] - -let instantiate_appl_pattern env appl_pattern = - let lookup name = - try List.assoc name env - with Not_found -> - prerr_endline (sprintf "Name %s not found" name); - assert false - in - let rec aux = function - | Ast.UriPattern uri -> CicUtil.term_of_uri uri - | Ast.ImplicitPattern -> Cic.Implicit None - | Ast.VarPattern name -> lookup name - | Ast.ApplPattern terms -> Cic.Appl (List.map aux terms) - in - aux appl_pattern - diff --git a/helm/ocaml/acic_content/termAcicContent.mli b/helm/ocaml/acic_content/termAcicContent.mli deleted file mode 100644 index 1fd57e0d0..000000000 --- a/helm/ocaml/acic_content/termAcicContent.mli +++ /dev/null @@ -1,68 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - - (** {2 Persistant state handling} *) - -type interpretation_id - -val add_interpretation: - string -> (* id / description *) - string * CicNotationPt.argument_pattern list -> (* symbol, level 2 pattern *) - CicNotationPt.cic_appl_pattern -> (* level 3 pattern *) - interpretation_id - - (** @raise Interpretation_not_found *) -val lookup_interpretations: - string -> (* symbol *) - (string * CicNotationPt.argument_pattern list * - CicNotationPt.cic_appl_pattern) list - -exception Interpretation_not_found - - (** @raise Interpretation_not_found *) -val remove_interpretation: interpretation_id -> unit - - (** {3 Interpretations toggling} *) - -val get_all_interpretations: unit -> (interpretation_id * string) list -val get_active_interpretations: unit -> interpretation_id list -val set_active_interpretations: interpretation_id list -> unit - - (** {2 acic -> content} *) - -val ast_of_acic: - (Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> (* id -> sort *) - Cic.annterm -> (* acic *) - CicNotationPt.term (* ast *) - * (Cic.id, UriManager.uri) Hashtbl.t (* id -> uri *) - - (** {2 content -> acic} *) - - (** @param env environment from argument_pattern to cic terms - * @param pat cic_appl_pattern *) -val instantiate_appl_pattern: - (string * Cic.term) list -> CicNotationPt.cic_appl_pattern -> - Cic.term - diff --git a/helm/ocaml/cic/.depend b/helm/ocaml/cic/.depend deleted file mode 100644 index a35156331..000000000 --- a/helm/ocaml/cic/.depend +++ /dev/null @@ -1,27 +0,0 @@ -unshare.cmi: cic.cmo -deannotate.cmi: cic.cmo -cicParser.cmi: cic.cmo -cicUtil.cmi: cic.cmo -helmLibraryObjects.cmi: cic.cmo -discrimination_tree.cmi: cic.cmo -path_indexing.cmi: cic.cmo -cic.cmo: cicUniv.cmi -cic.cmx: cicUniv.cmx -unshare.cmo: cic.cmo unshare.cmi -unshare.cmx: cic.cmx unshare.cmi -cicUniv.cmo: cicUniv.cmi -cicUniv.cmx: cicUniv.cmi -deannotate.cmo: cic.cmo deannotate.cmi -deannotate.cmx: cic.cmx deannotate.cmi -cicParser.cmo: deannotate.cmi cicUniv.cmi cic.cmo cicParser.cmi -cicParser.cmx: deannotate.cmx cicUniv.cmx cic.cmx cicParser.cmi -cicUtil.cmo: cicUniv.cmi cic.cmo cicUtil.cmi -cicUtil.cmx: cicUniv.cmx cic.cmx cicUtil.cmi -helmLibraryObjects.cmo: cic.cmo helmLibraryObjects.cmi -helmLibraryObjects.cmx: cic.cmx helmLibraryObjects.cmi -libraryObjects.cmo: helmLibraryObjects.cmi libraryObjects.cmi -libraryObjects.cmx: helmLibraryObjects.cmx libraryObjects.cmi -discrimination_tree.cmo: cic.cmo discrimination_tree.cmi -discrimination_tree.cmx: cic.cmx discrimination_tree.cmi -path_indexing.cmo: cic.cmo path_indexing.cmi -path_indexing.cmx: cic.cmx path_indexing.cmi diff --git a/helm/ocaml/cic/Makefile b/helm/ocaml/cic/Makefile deleted file mode 100644 index f3d9df425..000000000 --- a/helm/ocaml/cic/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -PACKAGE = cic -PREDICATES = - -INTERFACE_FILES = \ - unshare.mli \ - cicUniv.mli \ - deannotate.mli \ - cicParser.mli \ - cicUtil.mli \ - helmLibraryObjects.mli \ - libraryObjects.mli \ - discrimination_tree.mli \ - path_indexing.mli -IMPLEMENTATION_FILES = \ - cic.ml $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = cic.ml cic.cmi -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/cic/cic.ml b/helm/ocaml/cic/cic.ml deleted file mode 100644 index 64825e505..000000000 --- a/helm/ocaml/cic/cic.ml +++ /dev/null @@ -1,240 +0,0 @@ -(* 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 *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 29/11/2000 *) -(* *) -(* This module defines the internal representation of the objects (variables,*) -(* blocks of (co)inductive definitions and constants) and the terms of cic *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -(* 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 implicit_annotation = [ `Closed | `Type | `Hole ] - -(* INTERNAL REPRESENTATION OF CIC OBJECTS AND TERMS *) - -type sort = - Prop - | Set - | Type of CicUniv.universe - | CProp - -type name = - | Name of string - | Anonymous - -type object_flavour = - [ `Definition - | `Fact - | `Lemma - | `Remark - | `Theorem - | `Variant - ] - -type object_class = - [ `Coercion - | `Elim of sort (** elimination principle; if sort is Type, the universe is - * not relevant *) - | `Record of (string * bool) list (** - inductive type that encodes a record; the arguments are - the record fields names and if they are coercions *) - | `Projection (** record projection *) - ] - -type attribute = - [ `Class of object_class - | `Flavour of object_flavour - | `Generated - ] - -type term = - Rel of int (* DeBrujin index, 1 based*) - | 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 *) - | Implicit of implicit_annotation option (* *) - | Cast of term * term (* value, type *) - | Prod of name * term * term (* binder, source, target *) - | 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 * (* 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 (0 based), funs *) - | CoFix of int * coInductiveFun list (* funno (0 based), funs *) -and obj = - Constant of string * term option * term * (* id, body, type, *) - UriManager.uri list * attribute list (* parameters *) - | Variable of string * term option * term * (* name, body, type *) - UriManager.uri list * attribute list (* parameters *) - | CurrentProof of string * metasenv * term * (* name, conjectures, body, *) - term * UriManager.uri list * attribute list (* type, parameters *) - | InductiveDefinition of inductiveType list * (* inductive types, *) - UriManager.uri list * int * attribute list (* params, left params no *) -and inductiveType = - string * bool * term * (* typename, inductive, arity *) - constructor list (* constructors *) -and constructor = - 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 in declarations *) -(* order (i.e. [oldest ; ... ; newest]). Older variables can not *) -(* depend on new ones. *) -and conjecture = int * context * term -and metasenv = conjecture list -and substitution = (int * (context * term * term)) list - - - -(* 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 * 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 *) - | AImplicit of id * implicit_annotation option (* *) - | ACast of id * annterm * annterm (* value, type *) - | AProd of id * name * annterm * annterm (* binder, source, target *) - | 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 * (* 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 *) - (* consno is 1 based *) - | 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 = - AConstant of id * id option * string * (* name, *) - annterm option * annterm * (* body, type, *) - UriManager.uri list * attribute list (* parameters *) - | AVariable of id * - string * annterm option * annterm * (* name, body, type *) - UriManager.uri list * attribute list (* parameters *) - | ACurrentProof of id * id * - string * annmetasenv * (* name, conjectures, *) - annterm * annterm * UriManager.uri list * (* body,type,parameters *) - attribute list - | AInductiveDefinition of id * - anninductiveType list * (* inductive types , *) - UriManager.uri list * int * attribute list (* parameters,n ind. pars*) -and anninductiveType = - id * string * bool * annterm * (* typename, inductive, arity *) - annconstructor list (* constructors *) -and annconstructor = - string * annterm (* id, type *) -and anninductiveFun = - id * string * int * annterm * annterm (* name, ind. index, type, body *) -and anncoInductiveFun = - id * string * annterm * annterm (* name, type, body *) -and annotation = - string - -and context_entry = (* A declaration or definition *) - Decl of term - | Def of term * term option (* body, type (if known) *) - -and hypothesis = - (name * context_entry) option (* None means no more accessible *) - -and context = hypothesis list - -and anncontext_entry = (* A declaration or definition *) - ADecl of annterm - | ADef of annterm - -and annhypothesis = - id * (name * anncontext_entry) option (* None means no more accessible *) - -and anncontext = annhypothesis list -;; - -type lazy_term = - context -> metasenv -> CicUniv.universe_graph -> - term * metasenv * CicUniv.universe_graph - -type anntarget = - Object of annobj (* if annobj is a Constant, this is its type *) - | ConstantBody of annobj - | Term of annterm - | Conjecture of annconjecture - | Hypothesis of annhypothesis - -module CicHash = - Hashtbl.Make - (struct - type t = term - let equal = (==) - let hash = Hashtbl.hash - end) -;; - diff --git a/helm/ocaml/cic/cicParser.ml b/helm/ocaml/cic/cicParser.ml deleted file mode 100644 index a7ad3c9cf..000000000 --- a/helm/ocaml/cic/cicParser.ml +++ /dev/null @@ -1,780 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -open Printf - -(* ZACK TODO element from the DTD still to be handled: - - - - - - - -*) - -exception Getter_failure of string * string -exception Parser_failure of string - -type stack_entry = - | Arg of string * Cic.annterm (* relative uri, term *) - (* constants' body and types resides in differne files, thus we can't simple - * keep constants in Cic_obj stack entries *) - | Cic_attributes of Cic.attribute list - | Cic_constant_body of string * string * UriManager.uri list * Cic.annterm - * Cic.attribute list - (* id, for, params, body, object attributes *) - | Cic_constant_type of string * string * UriManager.uri list * Cic.annterm - * Cic.attribute list - (* id, name, params, type, object attributes *) - | Cic_term of Cic.annterm (* term *) - | Cic_obj of Cic.annobj (* object *) - | Cofix_fun of Cic.id * string * Cic.annterm * Cic.annterm - (* id, name, type, body *) - | Constructor of string * Cic.annterm (* name, type *) - | Decl of Cic.id * Cic.name * Cic.annterm (* id, binder, source *) - | Def of Cic.id * Cic.name * Cic.annterm (* id, binder, source *) - | Fix_fun of Cic.id * string * int * Cic.annterm * Cic.annterm - (* id, name, ind. index, type, body *) - | Inductive_type of string * string * bool * Cic.annterm * - (string * Cic.annterm) list (* id, name, inductive, arity, constructors *) - | Meta_subst of Cic.annterm option - | Obj_class of Cic.object_class - | Obj_flavour of Cic.object_flavour - | Obj_field of string (* field name *) - | Obj_generated - | Tag of string * (string * string) list (* tag name, attributes *) - (* ZACK TODO add file position to tag stack entry so that when attribute - * errors occur, the position of their _start_tag_ could be printed - * instead of the current position (usually the end tag) *) - -type ctxt = { - mutable stack: stack_entry list; - mutable xml_parser: XmlPushParser.xml_parser option; - mutable filename: string; - uri: UriManager.uri; -} - -let string_of_stack ctxt = - "[" ^ (String.concat "; " - (List.map - (function - | Arg (reluri, _) -> sprintf "Arg %s" reluri - | Cic_attributes _ -> "Cic_attributes" - | Cic_constant_body (id, name, _, _, _) -> - sprintf "Cic_constant_body %s (id=%s)" name id - | Cic_constant_type (id, name, _, _, _) -> - sprintf "Cic_constant_type %s (id=%s)" name id - | Cic_term _ -> "Cic_term" - | Cic_obj _ -> "Cic_obj" - | Constructor (name, _) -> "Constructor " ^ name - | Cofix_fun (id, _, _, _) -> sprintf "Cofix_fun (id=%s)" id - | Decl (id, _, _) -> sprintf "Decl (id=%s)" id - | Def (id, _, _) -> sprintf "Def (id=%s)" id - | Fix_fun (id, _, _, _, _) -> sprintf "Fix_fun (id=%s)" id - | Inductive_type (id, name, _, _, _) -> - sprintf "Inductive_type %s (id=%s)" name id - | Meta_subst _ -> "Meta_subst" - | Obj_class _ -> "Obj_class" - | Obj_flavour _ -> "Obj_flavour" - | Obj_field name -> "Obj_field " ^ name - | Obj_generated -> "Obj_generated" - | Tag (tag, _) -> "Tag " ^ tag) - ctxt.stack)) ^ "]" - -let compare_attrs (a1, v1) (a2, v2) = Pervasives.compare a1 a2 -let sort_attrs = List.sort compare_attrs - -let new_parser_context uri = { - stack = []; - xml_parser = None; - filename = "-"; - uri = uri; -} - -let get_parser ctxt = - match ctxt.xml_parser with - | Some p -> p - | None -> assert false - -(** {2 Error handling} *) - -let parse_error ctxt msg = - let (line, col) = XmlPushParser.get_position (get_parser ctxt) in - raise (Parser_failure (sprintf "[%s: line %d, column %d] %s" - ctxt.filename line col msg)) - -let attribute_error ctxt tag = - parse_error ctxt ("wrong attribute set for " ^ tag) - -(** {2 Parsing context management} *) - -let pop ctxt = -(* debug_print (lazy "pop");*) - match ctxt.stack with - | hd :: tl -> (ctxt.stack <- tl) - | _ -> assert false - -let push ctxt v = -(* debug_print (lazy "push");*) - ctxt.stack <- v :: ctxt.stack - -let set_top ctxt v = -(* debug_print (lazy "set_top");*) - match ctxt.stack with - | _ :: tl -> (ctxt.stack <- v :: tl) - | _ -> assert false - - (** pop the last tag from the open tags stack returning a pair *) -let pop_tag ctxt = - match ctxt.stack with - | Tag (tag, attrs) :: tl -> - ctxt.stack <- tl; - (tag, attrs) - | _ -> parse_error ctxt "unexpected extra content" - - (** pop the last tag from the open tags stack returning its attributes. - * Attributes are returned as a list of pair _sorted_ by - * attribute name *) -let pop_tag_attrs ctxt = sort_attrs (snd (pop_tag ctxt)) - -let pop_cics ctxt = - let rec aux acc stack = - match stack with - | Cic_term t :: tl -> aux (t :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - values - -let pop_class_modifiers ctxt = - let rec aux acc stack = - match stack with - | (Cic_term (Cic.ASort _) as m) :: tl - | (Obj_field _ as m) :: tl -> - aux (m :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - values - -let pop_meta_substs ctxt = - let rec aux acc stack = - match stack with - | Meta_subst t :: tl -> aux (t :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - values - -let pop_fix_funs ctxt = - let rec aux acc stack = - match stack with - | Fix_fun (id, name, index, typ, body) :: tl -> - aux ((id, name, index, typ, body) :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - values - -let pop_cofix_funs ctxt = - let rec aux acc stack = - match stack with - | Cofix_fun (id, name, typ, body) :: tl -> - aux ((id, name, typ, body) :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - values - -let pop_constructors ctxt = - let rec aux acc stack = - match stack with - | Constructor (name, t) :: tl -> aux ((name, t) :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - values - -let pop_inductive_types ctxt = - let rec aux acc stack = - match stack with - | Inductive_type (id, name, ind, arity, ctors) :: tl -> - aux ((id, name, ind, arity, ctors) :: acc) tl - | tl -> acc, tl - in - let values, new_stack = aux [] ctxt.stack in - if values = [] then - parse_error ctxt "no \"InductiveType\" element found"; - ctxt.stack <- new_stack; - values - - (** travels the stack (without popping) for the first term subject of explicit - * named substitution and return its URI *) -let find_base_uri ctxt = - let rec aux = function - | Cic_term (Cic.AConst (_, uri, _)) :: _ - | Cic_term (Cic.AMutInd (_, uri, _, _)) :: _ - | Cic_term (Cic.AMutConstruct (_, uri, _, _, _)) :: _ - | Cic_term (Cic.AVar (_, uri, _)) :: _ -> - uri - | Arg _ :: tl -> aux tl - | _ -> parse_error ctxt "no \"arg\" element found" - in - UriManager.buri_of_uri (aux ctxt.stack) - - (** backwardly eats the stack building an explicit named substitution from Arg - * stack entries *) -let pop_subst ctxt base_uri = - let rec aux acc stack = - match stack with - | Arg (rel_uri, term) :: tl -> - let uri = UriManager.uri_of_string (base_uri ^ "/" ^ rel_uri) in - aux ((uri, term) :: acc) tl - | tl -> acc, tl - in - let subst, new_stack = aux [] ctxt.stack in - if subst = [] then - parse_error ctxt "no \"arg\" element found"; - ctxt.stack <- new_stack; - subst - -let pop_cic ctxt = - match ctxt.stack with - | Cic_term t :: tl -> - ctxt.stack <- tl; - t - | _ -> parse_error ctxt "no cic term found" - -let pop_obj_attributes ctxt = - match ctxt.stack with - | Cic_attributes attributes :: tl -> - ctxt.stack <- tl; - attributes - | _ -> [] - -(** {2 Auxiliary functions} *) - -let uri_of_string = UriManager.uri_of_string - -let uri_list_of_string = - let space_RE = Str.regexp " " in - fun s -> - List.map uri_of_string (Str.split space_RE s) - -let sort_of_string ctxt = function - | "Prop" -> Cic.Prop - | "Set" -> Cic.Set - | "CProp" -> Cic.CProp - (* THIS CASE IS HERE ONLY TO ALLOW THE PARSING OF COQ LIBRARY - * THIS SHOULD BE REMOVED AS SOON AS univ_maker OR COQ'S EXPORTATION - * IS FIXED *) - | "Type" -> Cic.Type (CicUniv.fresh ~uri:ctxt.uri ()) - | s -> - let len = String.length s in - if not(len > 5) then parse_error ctxt "sort expected"; - if not(String.sub s 0 5 = "Type:") then parse_error ctxt "sort expected"; - try - Cic.Type - (CicUniv.fresh - ~uri:ctxt.uri - ~id:(int_of_string (String.sub s 5 (len - 5))) ()) - with - | Failure "int_of_string" - | Invalid_argument _ -> parse_error ctxt "sort expected" - -let patch_subst ctxt subst = function - | Cic.AConst (id, uri, _) -> Cic.AConst (id, uri, subst) - | Cic.AMutInd (id, uri, typeno, _) -> - Cic.AMutInd (id, uri, typeno, subst) - | Cic.AMutConstruct (id, uri, typeno, consno, _) -> - Cic.AMutConstruct (id, uri, typeno, consno, subst) - | Cic.AVar (id, uri, _) -> Cic.AVar (id, uri, subst) - | _ -> - parse_error ctxt - ("only \"CONST\", \"VAR\", \"MUTIND\", and \"MUTCONSTRUCT\" can be" ^ - " instantiated") - - (** backwardly eats the stack seeking for the first open tag carrying - * "helm:exception" attributes. If found return Some of a pair containing - * exception name and argument. Return None otherwise *) -let find_helm_exception ctxt = - let rec aux = function - | [] -> None - | Tag (_, attrs) :: tl -> - (try - let exn = List.assoc "helm:exception" attrs in - let arg = - try List.assoc "helm:exception_arg" attrs with Not_found -> "" - in - Some (exn, arg) - with Not_found -> aux tl) - | _ :: tl -> aux tl - in - aux ctxt.stack - -(** {2 Push parser callbacks} - * each callback needs to be instantiated to a parsing context *) - -let start_element ctxt tag attrs = -(* debug_print (lazy (sprintf "<%s%s>" tag (match attrs with | [] -> "" | _ -> " " ^ String.concat " " (List.map (fun (a,v) -> sprintf "%s=\"%s\"" a v) attrs))));*) - push ctxt (Tag (tag, attrs)) - -let end_element ctxt tag = -(* debug_print (lazy (sprintf "" tag));*) -(* debug_print (lazy (string_of_stack ctxt));*) - let attribute_error () = attribute_error ctxt tag in - let parse_error = parse_error ctxt in - let sort_of_string = sort_of_string ctxt in - match tag with - | "REL" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["binder", binder; "id", id; "idref", idref; "value", value] - | ["binder", binder; "id", id; "idref", idref; "sort", _; - "value", value] -> - Cic.ARel (id, idref, int_of_string value, binder) - | _ -> attribute_error ())) - | "VAR" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "uri", uri] - | ["id", id; "sort", _; "uri", uri] -> - Cic.AVar (id, uri_of_string uri, []) - | _ -> attribute_error ())) - | "CONST" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "uri", uri] - | ["id", id; "sort", _; "uri", uri] -> - Cic.AConst (id, uri_of_string uri, []) - | _ -> attribute_error ())) - | "SORT" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "value", sort] -> Cic.ASort (id, sort_of_string sort) - | _ -> attribute_error ())) - | "APPLY" -> - let args = pop_cics ctxt in - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id ] - | ["id", id; "sort", _] -> Cic.AAppl (id, args) - | _ -> attribute_error ())) - | "decl" -> - let source = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["binder", binder; "id", id ] - | ["binder", binder; "id", id; "type", _] -> - Decl (id, Cic.Name binder, source) - | ["id", id] - | ["id", id; "type", _] -> Decl (id, Cic.Anonymous, source) - | _ -> attribute_error ()) - | "def" -> (* same as "decl" above *) - let source = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["binder", binder; "id", id] - | ["binder", binder; "id", id; "sort", _] -> - Def (id, Cic.Name binder, source) - | ["id", id] - | ["id", id; "sort", _] -> Def (id, Cic.Anonymous, source) - | _ -> attribute_error ()) - | "arity" (* transparent elements (i.e. which contain a CIC) *) - | "body" - | "inductiveTerm" - | "pattern" - | "patternsType" - | "target" - | "term" - | "type" -> - let term = pop_cic ctxt in - pop ctxt; (* pops start tag matching current end tag (e.g. ) *) - push ctxt (Cic_term term) - | "substitution" -> (* optional transparent elements (i.e. which _may_ - * contain a CIC) *) - set_top ctxt (* replace *) - (match ctxt.stack with - | Cic_term term :: tl -> - ctxt.stack <- tl; - (Meta_subst (Some term)) - | _ -> Meta_subst None) - | "PROD" -> - let target = pop_cic ctxt in - let rec add_decl target = function - | Decl (id, binder, source) :: tl -> - add_decl (Cic.AProd (id, binder, source, target)) tl - | tl -> - ctxt.stack <- tl; - target - in - let term = add_decl target ctxt.stack in - (match pop_tag_attrs ctxt with - [] - | ["type", _] -> () - | _ -> attribute_error ()); - push ctxt (Cic_term term) - | "LAMBDA" -> - let target = pop_cic ctxt in - let rec add_decl target = function - | Decl (id, binder, source) :: tl -> - add_decl (Cic.ALambda (id, binder, source, target)) tl - | tl -> - ctxt.stack <- tl; - target - in - let term = add_decl target ctxt.stack in - (match pop_tag_attrs ctxt with - [] - | ["sort", _] -> () - | _ -> attribute_error ()); - push ctxt (Cic_term term) - | "LETIN" -> - let target = pop_cic ctxt in - let rec add_def target = function - | Def (id, binder, source) :: tl -> - add_def (Cic.ALetIn (id, binder, source, target)) tl - | tl -> - ctxt.stack <- tl; - target - in - let term = add_def target ctxt.stack in - (match pop_tag_attrs ctxt with - [] - | ["sort", _] -> () - | _ -> attribute_error ()); - push ctxt (Cic_term term) - | "CAST" -> - let typ = pop_cic ctxt in - let term = pop_cic ctxt in - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - ["id", id] - | ["id", id; "sort", _] -> Cic.ACast (id, term, typ) - | _ -> attribute_error ())); - | "IMPLICIT" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id] -> Cic.AImplicit (id, None) - | ["annotation", annotation; "id", id] -> - let implicit_annotation = - match annotation with - | "closed" -> `Closed - | "hole" -> `Hole - | "type" -> `Type - | _ -> parse_error "invalid value for \"annotation\" attribute" - in - Cic.AImplicit (id, Some implicit_annotation) - | _ -> attribute_error ())) - | "META" -> - let meta_substs = pop_meta_substs ctxt in - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "no", no] - | ["id", id; "no", no; "sort", _] -> - Cic.AMeta (id, int_of_string no, meta_substs) - | _ -> attribute_error ())); - | "MUTIND" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "noType", noType; "uri", uri] -> - Cic.AMutInd (id, uri_of_string uri, int_of_string noType, []) - | _ -> attribute_error ())); - | "MUTCONSTRUCT" -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "noConstr", noConstr; "noType", noType; "uri", uri] - | ["id", id; "noConstr", noConstr; "noType", noType; "sort", _; - "uri", uri] -> - Cic.AMutConstruct (id, uri_of_string uri, int_of_string noType, - int_of_string noConstr, []) - | _ -> attribute_error ())); - | "FixFunction" -> - let body = pop_cic ctxt in - let typ = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["id", id; "name", name; "recIndex", recIndex] -> - Fix_fun (id, name, int_of_string recIndex, typ, body) - | _ -> attribute_error ()) - | "CofixFunction" -> - let body = pop_cic ctxt in - let typ = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["id", id; "name", name] -> - Cofix_fun (id, name, typ, body) - | _ -> attribute_error ()) - | "FIX" -> - let fix_funs = pop_fix_funs ctxt in - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "noFun", noFun] - | ["id", id; "noFun", noFun; "sort", _] -> - Cic.AFix (id, int_of_string noFun, fix_funs) - | _ -> attribute_error ())) - | "COFIX" -> - let cofix_funs = pop_cofix_funs ctxt in - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "noFun", noFun] - | ["id", id; "noFun", noFun; "sort", _] -> - Cic.ACoFix (id, int_of_string noFun, cofix_funs) - | _ -> attribute_error ())) - | "MUTCASE" -> - (match pop_cics ctxt with - | patternsType :: inductiveTerm :: patterns -> - push ctxt (Cic_term - (match pop_tag_attrs ctxt with - | ["id", id; "noType", noType; "uriType", uriType] - | ["id", id; "noType", noType; "sort", _; "uriType", uriType] -> - Cic.AMutCase (id, uri_of_string uriType, int_of_string noType, - patternsType, inductiveTerm, patterns) - | _ -> attribute_error ())) - | _ -> parse_error "invalid \"MUTCASE\" content") - | "Constructor" -> - let typ = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["name", name] -> Constructor (name, typ) - | _ -> attribute_error ()) - | "InductiveType" -> - let constructors = pop_constructors ctxt in - let arity = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["id", id; "inductive", inductive; "name", name] -> - Inductive_type (id, name, bool_of_string inductive, arity, - constructors) - | _ -> attribute_error ()) - | "InductiveDefinition" -> - let inductive_types = pop_inductive_types ctxt in - let obj_attributes = pop_obj_attributes ctxt in - push ctxt (Cic_obj - (match pop_tag_attrs ctxt with - | ["id", id; "noParams", noParams; "params", params] -> - Cic.AInductiveDefinition (id, inductive_types, - uri_list_of_string params, int_of_string noParams, obj_attributes) - | _ -> attribute_error ())) - | "ConstantType" -> - let typ = pop_cic ctxt in - let obj_attributes = pop_obj_attributes ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["id", id; "name", name; "params", params] -> - Cic_constant_type (id, name, uri_list_of_string params, typ, - obj_attributes) - | _ -> attribute_error ()) - | "ConstantBody" -> - let body = pop_cic ctxt in - let obj_attributes = pop_obj_attributes ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["for", for_; "id", id; "params", params] -> - Cic_constant_body (id, for_, uri_list_of_string params, body, - obj_attributes) - | _ -> attribute_error ()) - | "Variable" -> - let typ = pop_cic ctxt in - let body = - match pop_cics ctxt with - | [] -> None - | [t] -> Some t - | _ -> parse_error "wrong content for \"Variable\"" - in - let obj_attributes = pop_obj_attributes ctxt in - push ctxt (Cic_obj - (match pop_tag_attrs ctxt with - | ["id", id; "name", name; "params", params] -> - Cic.AVariable (id, name, body, typ, uri_list_of_string params, - obj_attributes) - | _ -> attribute_error ())) - | "arg" -> - let term = pop_cic ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["relUri", relUri] -> Arg (relUri, term) - | _ -> attribute_error ()) - | "instantiate" -> - (* explicit named substitution handling: when the end tag of an element - * subject of exlicit named subst (MUTIND, MUTCONSTRUCT, CONST, VAR) it - * is stored on the stack with no substitutions (i.e. []). When the end - * tag of an "instantiate" element is found we patch the term currently - * on the stack with the substitution built from "instantiate" children - *) - (* XXX inefficiency here: first travels the elements in order to - * find the baseUri, then in order to build the explicit named subst *) - let base_uri = find_base_uri ctxt in - let subst = pop_subst ctxt base_uri in - let term = pop_cic ctxt in - (* comment from CicParser3.ml: - * CSC: the "id" optional attribute should be parsed and reflected in - * Cic.annterm and id = string_of_xml_attr (n#attribute "id") *) - (* replace *) - set_top ctxt (Cic_term (patch_subst ctxt subst term)) - | "attributes" -> - let rec aux acc = function (* retrieve object attributes *) - | Obj_class c :: tl -> aux (`Class c :: acc) tl - | Obj_flavour f :: tl -> aux (`Flavour f :: acc) tl - | Obj_generated :: tl -> aux (`Generated :: acc) tl - | tl -> acc, tl - in - let obj_attrs, new_stack = aux [] ctxt.stack in - ctxt.stack <- new_stack; - set_top ctxt (Cic_attributes obj_attrs) - | "generated" -> set_top ctxt Obj_generated - | "field" -> - push ctxt - (match pop_tag_attrs ctxt with - | ["name", name] -> Obj_field name - | _ -> attribute_error ()) - | "flavour" -> - push ctxt - (match pop_tag_attrs ctxt with - | [ "value", "definition"] -> Obj_flavour `Definition - | [ "value", "fact"] -> Obj_flavour `Fact - | [ "value", "lemma"] -> Obj_flavour `Lemma - | [ "value", "remark"] -> Obj_flavour `Remark - | [ "value", "theorem"] -> Obj_flavour `Theorem - | [ "value", "variant"] -> Obj_flavour `Variant - | _ -> attribute_error ()) - | "class" -> - let class_modifiers = pop_class_modifiers ctxt in - push ctxt - (match pop_tag_attrs ctxt with - | ["value", "coercion"] -> Obj_class `Coercion - | ["value", "elim"] -> - (match class_modifiers with - | [Cic_term (Cic.ASort (_, sort))] -> Obj_class (`Elim sort) - | _ -> - parse_error - "unexpected extra content for \"elim\" object class") - | ["value", "record"] -> - let fields = - List.map - (function - | Obj_field name -> - (match Str.split (Str.regexp " ") name with - | [name] -> name, false - | [name;"coercion"] -> name,true - | _ -> - parse_error - "wrong \"field\"'s name attribute") - | _ -> - parse_error - "unexpected extra content for \"record\" object class") - class_modifiers - in - Obj_class (`Record fields) - | ["value", "projection"] -> Obj_class `Projection - | _ -> attribute_error ()) - | tag -> - match find_helm_exception ctxt with - | Some (exn, arg) -> raise (Getter_failure (exn, arg)) - | None -> parse_error (sprintf "unknown element \"%s\"" tag) - -(** {2 Parser internals} *) - -let has_gz_suffix fname = - try - let idx = String.rindex fname '.' in - let suffix = String.sub fname idx (String.length fname - idx) in - suffix = ".gz" - with Not_found -> false - -let parse uri filename = - let ctxt = new_parser_context uri in - ctxt.filename <- filename; - let module P = XmlPushParser in - let callbacks = { - P.default_callbacks with - P.start_element = Some (start_element ctxt); - P.end_element = Some (end_element ctxt); - } in - let xml_parser = P.create_parser callbacks in - ctxt.xml_parser <- Some xml_parser; - try - (try - let xml_source = - if has_gz_suffix filename then `Gzip_file filename - else `File filename - in - P.parse xml_parser xml_source - with exn -> - ctxt.xml_parser <- None; - (* ZACK: the above "<- None" is vital for garbage collection. Without it - * we keep in memory a circular structure parser -> callbacks -> ctxt -> - * parser. I don't know if the ocaml garbage collector is supposed to - * collect such structures, but for sure the expat bindings will (orribly) - * leak when used in conjunction with such structures *) - raise exn); - ctxt.xml_parser <- None; (* ZACK: same comment as above *) -(* debug_print (lazy (string_of_stack stack));*) - (* assert (List.length ctxt.stack = 1) *) - List.hd ctxt.stack - with - | Failure "int_of_string" -> parse_error ctxt "integer number expected" - | Invalid_argument "bool_of_string" -> parse_error ctxt "boolean expected" - | P.Parse_error msg -> parse_error ctxt ("parse error: " ^ msg) - | Parser_failure _ - | Getter_failure _ as exn -> - raise exn - | exn -> - raise (Parser_failure ("uncaught exception: " ^ Printexc.to_string exn)) - -(** {2 API implementation} *) - -let annobj_of_xml uri filename filenamebody = - match filenamebody with - | None -> - (match parse uri filename with - | Cic_constant_type (id, name, params, typ, obj_attributes) -> - Cic.AConstant (id, None, name, None, typ, params, obj_attributes) - | Cic_obj obj -> obj - | _ -> raise (Parser_failure ("no object found in " ^ filename))) - | Some filenamebody -> - (match parse uri filename, parse uri filenamebody with - | Cic_constant_type (type_id, name, params, typ, obj_attributes), - Cic_constant_body (body_id, _, _, body, _) -> - Cic.AConstant (type_id, Some body_id, name, Some body, typ, params,obj_attributes) - | _ -> - raise (Parser_failure (sprintf "no constant found in %s, %s" - filename filenamebody))) - -let obj_of_xml uri filename filenamebody = - Deannotate.deannotate_obj (annobj_of_xml uri filename filenamebody) diff --git a/helm/ocaml/cic/cicParser.mli b/helm/ocaml/cic/cicParser.mli deleted file mode 100644 index 9472b4c54..000000000 --- a/helm/ocaml/cic/cicParser.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2000-2005, 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/. - *) - - (** raised for exception received by the getter (i.e. embedded in the source - * XML document). Arguments are values of "helm:exception" and - * "helm:exception_arg" attributes *) -exception Getter_failure of string * string - - (** generic parser failure *) -exception Parser_failure of string - - (* 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. - * Both files are assumed to be gzipped. *) -val annobj_of_xml: UriManager.uri -> string -> string option -> Cic.annobj - - (* 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. - * Both files are assumed to be gzipped. *) -val obj_of_xml : UriManager.uri -> string -> string option -> Cic.obj - diff --git a/helm/ocaml/cic/cicUniv.ml b/helm/ocaml/cic/cicUniv.ml deleted file mode 100644 index 8ae118c9b..000000000 --- a/helm/ocaml/cic/cicUniv.ml +++ /dev/null @@ -1,982 +0,0 @@ -(* 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 *) -(* *) -(* Enrico Tassi *) -(* 23/04/2004 *) -(* *) -(* This module implements the aciclic graph of universes. *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -(*****************************************************************************) -(** switch implementation **) -(*****************************************************************************) - -let fast_implementation = ref true ;; - -(*****************************************************************************) -(** open **) -(*****************************************************************************) - -open Printf - -(*****************************************************************************) -(** Types and default values **) -(*****************************************************************************) - -type universe = int * UriManager.uri option - -module UniverseType = struct - type t = universe - let compare = Pervasives.compare -end - -module SOF = Set.Make(UniverseType) - -type entry = { - eq_closure : SOF.t; - ge_closure : SOF.t; - gt_closure : SOF.t; - in_gegt_of : SOF.t; - one_s_eq : SOF.t; - one_s_ge : SOF.t; - one_s_gt : SOF.t; -} - -module MAL = Map.Make(UniverseType) - -type arc_type = GE | GT | EQ - -type bag = entry MAL.t - -let empty_entry = { - eq_closure=SOF.empty; - ge_closure=SOF.empty; - gt_closure=SOF.empty; - in_gegt_of=SOF.empty; - one_s_eq=SOF.empty; - one_s_ge=SOF.empty; - one_s_gt=SOF.empty; -} -let empty_bag = MAL.empty - -let are_set_eq s1 s2 = - SOF.equal s1 s2 - -let are_entry_eq v1 v2 = - (are_set_eq v1.gt_closure v2.gt_closure ) && - (are_set_eq v1.ge_closure v2.ge_closure ) && - (are_set_eq v1.eq_closure v2.eq_closure ) && - (*(are_set_eq v1.in_gegt_of v2.in_gegt_of ) &&*) - (are_set_eq v1.one_s_ge v2.one_s_ge ) && - (are_set_eq v1.one_s_gt v2.one_s_gt ) && - (are_set_eq v1.one_s_eq v2.one_s_eq ) - -let are_ugraph_eq = MAL.equal are_entry_eq - -(*****************************************************************************) -(** Pretty printings **) -(*****************************************************************************) - -let string_of_universe (i,u) = - match u with - Some u -> - "(" ^ ((string_of_int i) ^ "," ^ (UriManager.string_of_uri u) ^ ")") - | None -> "(" ^ (string_of_int i) ^ ",None)" - -let string_of_universe_set l = - SOF.fold (fun x s -> s ^ (string_of_universe x) ^ " ") l "" - -let string_of_node n = - "{"^ - "eq_c: " ^ (string_of_universe_set n.eq_closure) ^ "; " ^ - "ge_c: " ^ (string_of_universe_set n.ge_closure) ^ "; " ^ - "gt_c: " ^ (string_of_universe_set n.gt_closure) ^ "; " ^ - "i_gegt: " ^ (string_of_universe_set n.in_gegt_of) ^ "}\n" - -let string_of_arc (a,u,v) = - (string_of_universe u) ^ " " ^ a ^ " " ^ (string_of_universe v) - -let string_of_mal m = - let rc = ref "" in - MAL.iter (fun k v -> - rc := !rc ^ sprintf "%s --> %s" (string_of_universe k) - (string_of_node v)) m; - !rc - -let string_of_bag b = - string_of_mal b - -(*****************************************************************************) -(** Benchmarking **) -(*****************************************************************************) -let time_spent = ref 0.0;; -let partial = ref 0.0 ;; - -let reset_spent_time () = time_spent := 0.0;; -let get_spent_time () = !time_spent ;; -let begin_spending () = - (*assert (!partial = 0.0);*) - partial := Unix.gettimeofday () -;; - -let end_spending () = - assert (!partial > 0.0); - let interval = (Unix.gettimeofday ()) -. !partial in - partial := 0.0; - time_spent := !time_spent +. interval -;; - - -(*****************************************************************************) -(** Helpers **) -(*****************************************************************************) - -(* find the repr *) -let repr u m = - try - MAL.find u m - with - Not_found -> empty_entry - -(* FIXME: May be faster if we make it by hand *) -let merge_closures f nodes m = - SOF.fold (fun x i -> SOF.union (f (repr x m)) i ) nodes SOF.empty - - -(*****************************************************************************) -(** _fats implementation **) -(*****************************************************************************) - -let rec closure_of_fast ru m = - let eq_c = closure_eq_fast ru m in - let ge_c = closure_ge_fast ru m in - let gt_c = closure_gt_fast ru m in - { - eq_closure = eq_c; - ge_closure = ge_c; - gt_closure = gt_c; - in_gegt_of = ru.in_gegt_of; - one_s_eq = ru.one_s_eq; - one_s_ge = ru.one_s_ge; - one_s_gt = ru.one_s_gt - } - -and closure_eq_fast ru m = - let eq_c = - let j = ru.one_s_eq in - let _Uj = merge_closures (fun x -> x.eq_closure) j m in - let one_step_eq = ru.one_s_eq in - (SOF.union one_step_eq _Uj) - in - eq_c - -and closure_ge_fast ru m = - let ge_c = - let j = SOF.union ru.one_s_ge (SOF.union ru.one_s_gt ru.one_s_eq) in - let _Uj = merge_closures (fun x -> x.ge_closure) j m in - let _Ux = j in - (SOF.union _Uj _Ux) - in - ge_c - -and closure_gt_fast ru m = - let gt_c = - let j = ru.one_s_gt in - let k = ru.one_s_ge in - let l = ru.one_s_eq in - let _Uj = merge_closures (fun x -> x.ge_closure) j m in - let _Uk = merge_closures (fun x -> x.gt_closure) k m in - let _Ul = merge_closures (fun x -> x.gt_closure) l m in - let one_step_gt = ru.one_s_gt in - (SOF.union (SOF.union (SOF.union _Ul one_step_gt) _Uk) _Uj) - in - gt_c - -and print_rec_status u ru = - print_endline ("Aggiusto " ^ (string_of_universe u) ^ - "e ottengo questa chiusura\n " ^ (string_of_node ru)) - -and adjust_fast u m = - let ru = repr u m in - let gt_c = closure_gt_fast ru m in - let ge_c = closure_ge_fast ru m in - let eq_c = closure_eq_fast ru m in - let changed_eq = not (are_set_eq eq_c ru.eq_closure) in - let changed_gegt = - (not (are_set_eq gt_c ru.gt_closure)) || - (not (are_set_eq ge_c ru.ge_closure)) - in - if ((not changed_gegt) && (not changed_eq)) then - m - else - begin - let ru' = { - eq_closure = eq_c; - ge_closure = ge_c; - gt_closure = gt_c; - in_gegt_of = ru.in_gegt_of; - one_s_eq = ru.one_s_eq; - one_s_ge = ru.one_s_ge; - one_s_gt = ru.one_s_gt} - in - let m = MAL.add u ru' m in - let m = - SOF.fold (fun x m -> adjust_fast x m) - (SOF.union ru'.eq_closure ru'.in_gegt_of) m - (* TESI: - ru'.in_gegt_of m - *) - in - m (*adjust_fast u m*) - end - -and add_gt_arc_fast u v m = - let ru = repr u m in - let ru' = {ru with one_s_gt = SOF.add v ru.one_s_gt} in - let m' = MAL.add u ru' m in - let rv = repr v m' in - let rv' = {rv with in_gegt_of = SOF.add u rv.in_gegt_of} in - let m'' = MAL.add v rv' m' in - adjust_fast u m'' - -and add_ge_arc_fast u v m = - let ru = repr u m in - let ru' = { ru with one_s_ge = SOF.add v ru.one_s_ge} in - let m' = MAL.add u ru' m in - let rv = repr v m' in - let rv' = {rv with in_gegt_of = SOF.add u rv.in_gegt_of} in - let m'' = MAL.add v rv' m' in - adjust_fast u m'' - -and add_eq_arc_fast u v m = - let ru = repr u m in - let rv = repr v m in - let ru' = {ru with one_s_eq = SOF.add v ru.one_s_eq} in - (*TESI: let ru' = {ru' with in_gegt_of = SOF.add v ru.in_gegt_of} in *) - let m' = MAL.add u ru' m in - let rv' = {rv with one_s_eq = SOF.add u rv.one_s_eq} in - (*TESI: let rv' = {rv' with in_gegt_of = SOF.add u rv.in_gegt_of} in *) - let m'' = MAL.add v rv' m' in - adjust_fast v (*(adjust_fast u*) m'' (* ) *) -;; - - -(*****************************************************************************) -(** safe implementation **) -(*****************************************************************************) - -let closure_of u m = - let ru = repr u m in - let eq_c = - let j = ru.one_s_eq in - let _Uj = merge_closures (fun x -> x.eq_closure) j m in - let one_step_eq = ru.one_s_eq in - (SOF.union one_step_eq _Uj) - in - let ge_c = - let j = SOF.union ru.one_s_ge (SOF.union ru.one_s_gt ru.one_s_eq) in - let _Uj = merge_closures (fun x -> x.ge_closure) j m in - let _Ux = j in - (SOF.union _Uj _Ux) - in - let gt_c = - let j = ru.one_s_gt in - let k = ru.one_s_ge in - let l = ru.one_s_eq in - let _Uj = merge_closures (fun x -> x.ge_closure) j m in - let _Uk = merge_closures (fun x -> x.gt_closure) k m in - let _Ul = merge_closures (fun x -> x.gt_closure) l m in - let one_step_gt = ru.one_s_gt in - (SOF.union (SOF.union (SOF.union _Ul one_step_gt) _Uk) _Uj) - in - { - eq_closure = eq_c; - ge_closure = ge_c; - gt_closure = gt_c; - in_gegt_of = ru.in_gegt_of; - one_s_eq = ru.one_s_eq; - one_s_ge = ru.one_s_ge; - one_s_gt = ru.one_s_gt - } - -let rec simple_adjust m = - let m' = - MAL.mapi (fun x _ -> closure_of x m) m - in - if not (are_ugraph_eq m m') then( - simple_adjust m') - else - m' - -let add_eq_arc u v m = - let ru = repr u m in - let rv = repr v m in - let ru' = {ru with one_s_eq = SOF.add v ru.one_s_eq} in - let m' = MAL.add u ru' m in - let rv' = {rv with one_s_eq = SOF.add u rv.one_s_eq} in - let m'' = MAL.add v rv' m' in - simple_adjust m'' - -let add_ge_arc u v m = - let ru = repr u m in - let ru' = { ru with one_s_ge = SOF.add v ru.one_s_ge} in - let m' = MAL.add u ru' m in - simple_adjust m' - -let add_gt_arc u v m = - let ru = repr u m in - let ru' = {ru with one_s_gt = SOF.add v ru.one_s_gt} in - let m' = MAL.add u ru' m in - simple_adjust m' - - -(*****************************************************************************) -(** Outhern interface, that chooses between _fast and safe **) -(*****************************************************************************) - -(* - given the 2 nodes plus the current bag, adds the arc, recomputes the - closures and returns the new map -*) -let add_eq fast u v b = - if fast then - add_eq_arc_fast u v b - else - add_eq_arc u v b - -(* - given the 2 nodes plus the current bag, adds the arc, recomputes the - closures and returns the new map -*) -let add_ge fast u v b = - if fast then - add_ge_arc_fast u v b - else - add_ge_arc u v b -(* - given the 2 nodes plus the current bag, adds the arc, recomputes the - closures and returns the new map -*) -let add_gt fast u v b = - if fast then - add_gt_arc_fast u v b - else - add_gt_arc u v b - - -(*****************************************************************************) -(** Other real code **) -(*****************************************************************************) - -exception UniverseInconsistency of string - -let error arc node1 closure_type node2 closure = - let s = "\n ===== Universe Inconsistency detected =====\n\n" ^ - " Unable to add\n" ^ - "\t" ^ (string_of_arc arc) ^ "\n" ^ - " cause\n" ^ - "\t" ^ (string_of_universe node1) ^ "\n" ^ - " is in the " ^ closure_type ^ " closure\n" ^ - "\t{" ^ (string_of_universe_set closure) ^ "}\n" ^ - " of\n" ^ - "\t" ^ (string_of_universe node2) ^ "\n\n" ^ - " ===== Universe Inconsistency detected =====\n" in - prerr_endline s; - raise (UniverseInconsistency s) - - -let fill_empty_nodes_with_uri (g, already_contained) l uri = - let fill_empty_universe u = - match u with - (i,None) -> (i,Some uri) - | (i,Some _) as u -> u - in - let fill_empty_set s = - SOF.fold (fun e s -> SOF.add (fill_empty_universe e) s) s SOF.empty - in - let fill_empty_entry e = { - eq_closure = (fill_empty_set e.eq_closure) ; - ge_closure = (fill_empty_set e.ge_closure) ; - gt_closure = (fill_empty_set e.gt_closure) ; - in_gegt_of = (fill_empty_set e.in_gegt_of) ; - one_s_eq = (fill_empty_set e.one_s_eq) ; - one_s_ge = (fill_empty_set e.one_s_ge) ; - one_s_gt = (fill_empty_set e.one_s_gt) ; - } in - let m = g in - let m' = MAL.fold ( - fun k v m -> - MAL.add (fill_empty_universe k) (fill_empty_entry v) m) m MAL.empty - in - let l' = List.map fill_empty_universe l in - (m', already_contained),l' - - -(*****************************************************************************) -(** World interface **) -(*****************************************************************************) - -type universe_graph = bag * UriManager.UriSet.t -(* the graph , the cache of already merged ugraphs *) - -let empty_ugraph = empty_bag, UriManager.UriSet.empty - -let current_index_anon = ref (-1) -let current_index_named = ref (-1) - -let restart_numbering () = current_index_named := (-1) - -let fresh ?uri ?id () = - let i = - match uri,id with - | None,None -> - current_index_anon := !current_index_anon + 1; - !current_index_anon - | None, Some _ -> assert false - | Some _, None -> - current_index_named := !current_index_named + 1; - !current_index_named - | Some _, Some id -> id - in - (i,uri) - -let name_universe u uri = - match u with - | (i, None) -> (i, Some uri) - | _ -> u - -let print_ugraph (g, _) = - prerr_endline (string_of_bag g) - -let add_eq ?(fast=(!fast_implementation)) u v b = - (* should we check to no add twice the same?? *) - let m = b in - let ru = repr u m in - if SOF.mem v ru.gt_closure then - error ("EQ",u,v) v "GT" u ru.gt_closure - else - begin - let rv = repr v m in - if SOF.mem u rv.gt_closure then - error ("EQ",u,v) u "GT" v rv.gt_closure - else - add_eq fast u v b - end - -let add_ge ?(fast=(!fast_implementation)) u v b = - (* should we check to no add twice the same?? *) - let m = b in - let rv = repr v m in - if SOF.mem u rv.gt_closure then - error ("GE",u,v) u "GT" v rv.gt_closure - else - add_ge fast u v b - -let add_gt ?(fast=(!fast_implementation)) u v b = - (* should we check to no add twice the same?? *) - (* - FIXME : check the thesis... no need to check GT and EQ closure since the - GE is a superset of both - *) - let m = b in - let rv = repr v m in - - if u = v then - error ("GT",u,v) u "==" v SOF.empty - else - - (*if SOF.mem u rv.gt_closure then - error ("GT",u,v) u "GT" v rv.gt_closure - else - begin*) - if SOF.mem u rv.ge_closure then - error ("GT",u,v) u "GE" v rv.ge_closure - else -(* begin - if SOF.mem u rv.eq_closure then - error ("GT",u,v) u "EQ" v rv.eq_closure - else*) - add_gt fast u v b -(* end - end*) - -(*****************************************************************************) -(** START: Decomment this for performance comparisons **) -(*****************************************************************************) - -let add_eq ?(fast=(!fast_implementation)) u v (b,already_contained) = - (*prerr_endline "add_eq";*) - begin_spending (); - let rc = add_eq ~fast u v b in - end_spending (); - rc,already_contained - -let add_ge ?(fast=(!fast_implementation)) u v (b,already_contained) = -(* prerr_endline "add_ge"; *) - begin_spending (); - let rc = add_ge ~fast u v b in - end_spending (); - rc,already_contained - -let add_gt ?(fast=(!fast_implementation)) u v (b,already_contained) = -(* prerr_endline "add_gt"; *) - begin_spending (); - let rc = add_gt ~fast u v b in - end_spending (); - rc,already_contained - -let profiler_eq = HExtlib.profile "CicUniv.add_eq" -let profiler_ge = HExtlib.profile "CicUniv.add_ge" -let profiler_gt = HExtlib.profile "CicUniv.add_gt" -let add_gt ?fast u v b = - profiler_gt.HExtlib.profile (fun _ -> add_gt ?fast u v b) () -let add_ge ?fast u v b = - profiler_ge.HExtlib.profile (fun _ -> add_ge ?fast u v b) () -let add_eq ?fast u v b = - profiler_eq.HExtlib.profile (fun _ -> add_eq ?fast u v b) () - -(*****************************************************************************) -(** END: Decomment this for performance comparisons **) -(*****************************************************************************) - -let merge_ugraphs ~base_ugraph ~increment:(increment, uri_of_increment) = - let merge_brutal (u,_) v = - let m1 = u in - let m2 = v in - MAL.fold ( - fun k v x -> - (SOF.fold ( - fun u x -> - let m = add_gt k u x in m) - (SOF.union v.one_s_gt v.gt_closure) - (SOF.fold ( - fun u x -> - let m = add_ge k u x in m) - (SOF.union v.one_s_ge v.ge_closure) - (SOF.fold ( - fun u x -> - let m = add_eq k u x in m) - (SOF.union v.one_s_eq v.eq_closure) x))) - ) m1 m2 - in - let base, already_contained = base_ugraph in - if MAL.is_empty base then - increment - else if - MAL.is_empty (fst increment) || - UriManager.UriSet.mem uri_of_increment already_contained - then - base_ugraph - else - fst (merge_brutal increment base_ugraph), - UriManager.UriSet.add uri_of_increment already_contained - -let profiler_merge = HExtlib.profile "CicUniv.merge_graphs" -let merge_ugraphs ~base_ugraph ~increment = - profiler_merge.HExtlib.profile - (fun _ -> merge_ugraphs ~base_ugraph ~increment) () - -(*****************************************************************************) -(** Xml sesialization and parsing **) -(*****************************************************************************) - -let xml_of_universe name u = - match u with - | (i,Some u) -> - Xml.xml_empty name [ - None,"id",(string_of_int i) ; - None,"uri",(UriManager.string_of_uri u)] - | (_,None) -> - raise (Failure "we can serialize only universes with uri") - -let xml_of_set s = - let l = - List.map (xml_of_universe "node") (SOF.elements s) - in - List.fold_left (fun s x -> [< s ; x >] ) [<>] l - -let xml_of_entry_content e = - let stream_of_field f name = - let eq_c = xml_of_set f in - if eq_c != [<>] then - Xml.xml_nempty name [] eq_c - else - [<>] - in - [< - (stream_of_field e.eq_closure "eq_closure"); - (stream_of_field e.gt_closure "gt_closure"); - (stream_of_field e.ge_closure "ge_closure"); - (stream_of_field e.in_gegt_of "in_gegt_of"); - (stream_of_field e.one_s_eq "one_s_eq"); - (stream_of_field e.one_s_gt "one_s_gt"); - (stream_of_field e.one_s_ge "one_s_ge") - >] - -let xml_of_entry u e = - let (i,u') = u in - let u'' = - match u' with - Some x -> x - | None -> - raise (Failure "we can serialize only universes (entry) with uri") - in - let ent = Xml.xml_nempty "entry" [ - None,"id",(string_of_int i) ; - None,"uri",(UriManager.string_of_uri u'')] in - let content = xml_of_entry_content e in - ent content - -let write_xml_of_ugraph filename (m,_) l = - let tokens = - [< - Xml.xml_cdata "\n"; - Xml.xml_nempty "ugraph" [] - ([< (MAL.fold ( fun k v s -> [< s ; (xml_of_entry k v) >]) m [<>]) ; - (List.fold_left - (fun s u -> [< s ; xml_of_universe "owned_node" u >]) [<>] l) >])>] - in - Xml.pp ~gzip:true tokens (Some filename) - -let univno = fst - - -let rec clean_ugraph (m,already_contained) f = - let m' = - MAL.fold (fun k v x -> if (f k) then MAL.add k v x else x ) m MAL.empty in - let m'' = MAL.fold (fun k v x -> - let v' = { - eq_closure = SOF.filter f v.eq_closure; - ge_closure = SOF.filter f v.ge_closure; - gt_closure = SOF.filter f v.gt_closure; - in_gegt_of = SOF.filter f v.in_gegt_of; - one_s_eq = SOF.filter f v.one_s_eq; - one_s_ge = SOF.filter f v.one_s_ge; - one_s_gt = SOF.filter f v.one_s_gt - } in - MAL.add k v' x ) m' MAL.empty in - let e_l = - MAL.fold (fun k v l -> if v = empty_entry && not(f k) then - begin - k::l end else l) m'' [] - in - if e_l != [] then - clean_ugraph - (m'', already_contained) (fun u -> (f u) && not (List.mem u e_l)) - else - MAL.fold - (fun k v x -> if v <> empty_entry then MAL.add k v x else x) - m'' MAL.empty, - already_contained - -let clean_ugraph g l = - clean_ugraph g (fun u -> List.mem u l) - -let assigner_of = - function - "ge_closure" -> (fun e u->{e with ge_closure=SOF.add u e.ge_closure}) - | "gt_closure" -> (fun e u->{e with gt_closure=SOF.add u e.gt_closure}) - | "eq_closure" -> (fun e u->{e with eq_closure=SOF.add u e.eq_closure}) - | "in_gegt_of" -> (fun e u->{e with in_gegt_of =SOF.add u e.in_gegt_of}) - | "one_s_ge" -> (fun e u->{e with one_s_ge =SOF.add u e.one_s_ge}) - | "one_s_gt" -> (fun e u->{e with one_s_gt =SOF.add u e.one_s_gt}) - | "one_s_eq" -> (fun e u->{e with one_s_eq =SOF.add u e.one_s_eq}) - | s -> raise (Failure ("unsupported tag " ^ s)) -;; - -let cb_factory m l = - let module XPP = XmlPushParser in - let current_node = ref (0,None) in - let current_entry = ref empty_entry in - let current_assign = ref (assigner_of "in_gegt_of") in - { XPP.default_callbacks with - XPP.end_element = Some( fun name -> - match name with - | "entry" -> - m := MAL.add !current_node !current_entry !m; - current_entry := empty_entry - | _ -> () - ); - XPP.start_element = Some( fun name attlist -> - match name with - | "ugraph" -> () - | "entry" -> - let id = List.assoc "id" attlist in - let uri = List.assoc "uri" attlist in - current_node := (int_of_string id,Some (UriManager.uri_of_string uri)) - | "node" -> - let id = int_of_string (List.assoc "id" attlist) in - let uri = List.assoc "uri" attlist in - current_entry := !current_assign !current_entry - (id,Some (UriManager.uri_of_string uri)) - | "owned_node" -> - let id = int_of_string (List.assoc "id" attlist) in - let uri = List.assoc "uri" attlist in - l := (id,Some (UriManager.uri_of_string uri)) :: !l - | s -> current_assign := assigner_of s - ) - } -;; - -let ugraph_and_univlist_of_xml filename = - let module XPP = XmlPushParser in - let result_map = ref MAL.empty in - let result_list = ref [] in - let cb = cb_factory result_map result_list in - let xml_parser = XPP.create_parser cb in - let xml_source = `Gzip_file filename in - (try XPP.parse xml_parser xml_source - with (XPP.Parse_error err) as exn -> raise exn); - (!result_map,UriManager.UriSet.empty), !result_list - - -(*****************************************************************************) -(** the main, only for testing **) -(*****************************************************************************) - -(* - -type arc = Ge | Gt | Eq ;; - -let randomize_actionlist n m = - let ge_percent = 0.7 in - let gt_percent = 0.15 in - let random_step () = - let node1 = Random.int m in - let node2 = Random.int m in - let op = - let r = Random.float 1.0 in - if r < ge_percent then - Ge - else (if r < (ge_percent +. gt_percent) then - Gt - else - Eq) - in - op,node1,node2 - in - let rec aux n = - match n with - 0 -> [] - | n -> (random_step ())::(aux (n-1)) - in - aux n - -let print_action_list l = - let string_of_step (op,node1,node2) = - (match op with - Ge -> "Ge" - | Gt -> "Gt" - | Eq -> "Eq") ^ - "," ^ (string_of_int node1) ^ "," ^ (string_of_int node2) - in - let rec aux l = - match l with - [] -> "]" - | a::tl -> - ";" ^ (string_of_step a) ^ (aux tl) - in - let body = aux l in - let l_body = (String.length body) - 1 in - prerr_endline ("[" ^ (String.sub body 1 l_body)) - -let debug = false -let d_print_endline = if debug then print_endline else ignore -let d_print_ugraph = if debug then print_ugraph else ignore - -let _ = - (if Array.length Sys.argv < 2 then - prerr_endline ("Usage " ^ Sys.argv.(0) ^ " max_edges max_nodes")); - Random.self_init (); - let max_edges = int_of_string Sys.argv.(1) in - let max_nodes = int_of_string Sys.argv.(2) in - let action_listR = randomize_actionlist max_edges max_nodes in - - let action_list = [Ge,1,4;Ge,2,6;Ge,1,1;Eq,6,4;Gt,6,3] in - let action_list = action_listR in - - print_action_list action_list; - let prform_step ?(fast=false) (t,u,v) g = - let f,str = - match t with - Ge -> add_ge,">=" - | Gt -> add_gt,">" - | Eq -> add_eq,"=" - in - d_print_endline ( - "Aggiungo " ^ - (string_of_int u) ^ - " " ^ str ^ " " ^ - (string_of_int v)); - let g' = f ~fast (u,None) (v,None) g in - (*print_ugraph g' ;*) - g' - in - let fail = ref false in - let time1 = Unix.gettimeofday () in - let n_safe = ref 0 in - let g_safe = - try - d_print_endline "SAFE"; - List.fold_left ( - fun g e -> - n_safe := !n_safe + 1; - prform_step e g - ) empty_ugraph action_list - with - UniverseInconsistency s -> fail:=true;empty_bag - in - let time2 = Unix.gettimeofday () in - d_print_ugraph g_safe; - let time3 = Unix.gettimeofday () in - let n_test = ref 0 in - let g_test = - try - d_print_endline "FAST"; - List.fold_left ( - fun g e -> - n_test := !n_test + 1; - prform_step ~fast:true e g - ) empty_ugraph action_list - with - UniverseInconsistency s -> empty_bag - in - let time4 = Unix.gettimeofday () in - d_print_ugraph g_test; - if are_ugraph_eq g_safe g_test && !n_test = !n_safe then - begin - let num_eq = - List.fold_left ( - fun s (e,_,_) -> - if e = Eq then s+1 else s - ) 0 action_list - in - let num_gt = - List.fold_left ( - fun s (e,_,_) -> - if e = Gt then s+1 else s - ) 0 action_list - in - let num_ge = max_edges - num_gt - num_eq in - let time_fast = (time4 -. time3) in - let time_safe = (time2 -. time1) in - let gap = ((time_safe -. time_fast) *. 100.0) /. time_safe in - let fail = if !fail then 1 else 0 in - print_endline - (sprintf - "OK %d safe %1.4f fast %1.4f %% %1.2f #eq %d #gt %d #ge %d %d" - fail time_safe time_fast gap num_eq num_gt num_ge !n_safe); - exit 0 - end - else - begin - print_endline "FAIL"; - print_ugraph g_safe; - print_ugraph g_test; - exit 1 - end -;; - - *) - -let recons_univ u = - match u with - | i, None -> u - | i, Some uri -> - i, Some (UriManager.uri_of_string (UriManager.string_of_uri uri)) - -let recons_entry entry = - let recons_set set = - SOF.fold (fun univ set -> SOF.add (recons_univ univ) set) set SOF.empty - in - { - eq_closure = recons_set entry.eq_closure; - ge_closure = recons_set entry.ge_closure; - gt_closure = recons_set entry.gt_closure; - in_gegt_of = recons_set entry.in_gegt_of; - one_s_eq = recons_set entry.one_s_eq; - one_s_ge = recons_set entry.one_s_ge; - one_s_gt = recons_set entry.one_s_gt; - } - -let recons_graph (graph,uriset) = - MAL.fold - (fun universe entry map -> - MAL.add (recons_univ universe) (recons_entry entry) map) - graph - MAL.empty, - UriManager.UriSet.fold - (fun u acc -> - UriManager.UriSet.add - (UriManager.uri_of_string (UriManager.string_of_uri u)) acc) - uriset UriManager.UriSet.empty - -let assert_univ u = - match u with - | (_,None) -> raise (UniverseInconsistency "This universe graph has a hole") - | _ -> () - -let assert_univs_have_uri (graph,_) univlist = - let assert_set s = - SOF.iter (fun u -> assert_univ u) s - in - let assert_entry e = - assert_set e.eq_closure; - assert_set e.ge_closure; - assert_set e.gt_closure; - assert_set e.in_gegt_of; - assert_set e.one_s_eq; - assert_set e.one_s_ge; - assert_set e.one_s_gt; - in - MAL.iter (fun k v -> assert_univ k; assert_entry v)graph; - List.iter assert_univ univlist - -let eq u1 u2 = - match u1,u2 with - | (id1, Some uri1),(id2, Some uri2) -> - id1 = id2 && UriManager.eq uri1 uri2 - | (id1, None),(id2, None) -> id1 = id2 - | _ -> false - -let compare (id1, uri1) (id2, uri2) = - let cmp = id1 - id2 in - if cmp = 0 then - match uri1,uri2 with - | None, None -> 0 - | Some _, None -> 1 - | None, Some _ -> ~-1 - | Some uri1, Some uri2 -> UriManager.compare uri1 uri2 - else - cmp - -(* EOF *) diff --git a/helm/ocaml/cic/cicUniv.mli b/helm/ocaml/cic/cicUniv.mli deleted file mode 100644 index eb3c50866..000000000 --- a/helm/ocaml/cic/cicUniv.mli +++ /dev/null @@ -1,154 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - - -(* - The strings contains an unreadable message -*) -exception UniverseInconsistency of string - -(* - Cic.Type of universe -*) -type universe - -(* - Opaque data structure you will use to store constraints -*) -type universe_graph - -(* - returns a fresh universe -*) -val fresh: - ?uri:UriManager.uri -> - ?id:int -> - unit -> - universe - - (* names a universe if unnamed *) -val name_universe: universe -> UriManager.uri -> universe - -(* - really useful at the begin and in all the functions that don't care - of universes -*) -val empty_ugraph: universe_graph - -(* - These are the real functions to add eq/ge/gt constraints - to the passed graph, returning an updated graph or raising - UniverseInconsistency -*) -val add_eq: - ?fast:bool -> universe -> universe -> universe_graph -> universe_graph -val add_ge: - ?fast:bool -> universe -> universe -> universe_graph -> universe_graph -val add_gt: - ?fast:bool -> universe -> universe -> universe_graph -> universe_graph - -(* - debug function to print the graph to standard error -*) -val print_ugraph: - universe_graph -> unit - -(* - does what expected, but I don't remember why this was exported -*) -val string_of_universe: - universe -> string - -(* - given the list of visible universes (see universes_of_obj) returns a - cleaned graph (cleaned from the not visible nodes) -*) -val clean_ugraph: - universe_graph -> universe list -> universe_graph - -(* - Since fresh() can't add the right uri to each node, you - must fill empty nodes with the uri before you serialize the graph to xml - - these empty nodes are also filled in the universe list -*) -val fill_empty_nodes_with_uri: - universe_graph -> universe list -> UriManager.uri -> - universe_graph * universe list - -(* - makes a union. - TODO: - - remember already merged uri so that we completely skip already merged - graphs, this may include a dependecy graph (not merge a subpart of an - already merged graph) -*) -val merge_ugraphs: - base_ugraph:universe_graph -> - increment:(universe_graph * UriManager.uri) -> universe_graph - -(* - ugraph to xml file and viceversa -*) -val write_xml_of_ugraph: - string -> universe_graph -> universe list -> unit - -(* - given a filename parses the xml and returns the data structure -*) -val ugraph_and_univlist_of_xml: - string -> universe_graph * universe list -val restart_numbering: - unit -> unit - -(* - returns the universe number (used to save it do xml) -*) -val univno: universe -> int - - (** re-hash-cons URIs contained in the given universe so that phisicaly - * equality could be enforced. Mainly used by - * CicEnvironment.restore_from_channel *) -val recons_graph: universe_graph -> universe_graph - - (** re-hash-cons a single universe *) -val recons_univ: universe -> universe - - (** consistency chek that should be done before committin the graph to the - * cache *) -val assert_univs_have_uri: universe_graph -> universe list-> unit - - (** asserts the universe is named *) -val assert_univ: universe -> unit - -val compare: universe -> universe -> int -val eq: universe -> universe -> bool - -(* - Benchmarking stuff -*) -val get_spent_time: unit -> float -val reset_spent_time: unit -> unit - diff --git a/helm/ocaml/cic/cicUtil.ml b/helm/ocaml/cic/cicUtil.ml deleted file mode 100644 index 7c6e3eabe..000000000 --- a/helm/ocaml/cic/cicUtil.ml +++ /dev/null @@ -1,365 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -exception Meta_not_found of int -exception Subst_not_found of int - -let lookup_meta index metasenv = - try - List.find (fun (index', _, _) -> index = index') metasenv - with Not_found -> raise (Meta_not_found index) - -let lookup_subst n subst = - try - List.assoc n subst - with Not_found -> raise (Subst_not_found n) - -let exists_meta index = List.exists (fun (index', _, _) -> (index = index')) - -(* clean_up_meta take a substitution, a metasenv a meta_inex and a local -context l and clean up l with respect to the hidden hipothesis in the -canonical context *) - -let clean_up_local_context subst metasenv n l = - let cc = - (try - let (cc,_,_) = lookup_subst n subst in cc - with Subst_not_found _ -> - try - let (_,cc,_) = lookup_meta n metasenv in cc - with Meta_not_found _ -> assert false) in - (try - List.map2 - (fun t1 t2 -> - match t1,t2 with - None , _ -> None - | _ , t -> t) cc l - with - Invalid_argument _ -> assert false) - -let is_closed = - let module C = Cic in - let rec is_closed k = - function - C.Rel m when m > k -> false - | C.Rel m -> true - | C.Meta (_,l) -> - List.fold_left - (fun i t -> i && (match t with None -> true | Some t -> is_closed k t) - ) true l - | C.Sort _ -> true - | C.Implicit _ -> assert false - | C.Cast (te,ty) -> is_closed k te && is_closed k ty - | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest - | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest - | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest - | C.Appl l -> - List.fold_right (fun x i -> i && is_closed k x) l true - | 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 && is_closed k x) - exp_named_subst true - | C.MutCase (_,_,out,te,pl) -> - is_closed k out && is_closed k te && - List.fold_right (fun x i -> i && is_closed k x) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let k_plus_len = k + len in - List.fold_right - (fun (_,_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let k_plus_len = k + len in - List.fold_right - (fun (_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo - ) fl true -in - is_closed 0 -;; - -let rec is_meta_closed = - function - Cic.Rel _ -> true - | Cic.Meta _ -> false - | Cic.Sort _ -> true - | Cic.Implicit _ -> assert false - | Cic.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty - | Cic.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest - | Cic.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest - | Cic.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest - | Cic.Appl l -> - not (List.exists (fun x -> not (is_meta_closed x)) l) - | Cic.Var (_,exp_named_subst) - | Cic.Const (_,exp_named_subst) - | Cic.MutInd (_,_,exp_named_subst) - | Cic.MutConstruct (_,_,_,exp_named_subst) -> - not (List.exists (fun (_,x) -> not (is_meta_closed x)) exp_named_subst) - | Cic.MutCase (_,_,out,te,pl) -> - is_meta_closed out && is_meta_closed te && - not (List.exists (fun x -> not (is_meta_closed x)) pl) - | Cic.Fix (_,fl) -> - not (List.exists - (fun (_,_,ty,bo) -> - not (is_meta_closed ty) || not (is_meta_closed bo)) - fl) - | Cic.CoFix (_,fl) -> - not (List.exists - (fun (_,ty,bo) -> - not (is_meta_closed ty) || not (is_meta_closed bo)) - fl) -;; - -let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))" -let slash_RE = Str.regexp "/" - -let term_of_uri uri = - let s = UriManager.string_of_uri uri in - try - (if UriManager.uri_is_con uri then - Cic.Const (uri, []) - else if UriManager.uri_is_var uri then - Cic.Var (uri, []) - else if not (Str.string_match xpointer_RE s 0) then - raise (UriManager.IllFormedUri s) - else - let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in - let baseuri = UriManager.uri_of_string baseuri in - (match Str.split slash_RE xpointer with - | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, []) - | [_; tyno; consno] -> - Cic.MutConstruct - (baseuri, int_of_string tyno - 1, int_of_string consno, []) - | _ -> raise Exit)) - with - | Exit - | Failure _ - | Not_found -> raise (UriManager.IllFormedUri s) - -let uri_of_term = function - | Cic.Const (uri, []) - | Cic.Var (uri, []) -> uri - | Cic.MutInd (baseuri, tyno, []) -> - UriManager.uri_of_string - (sprintf "%s#xpointer(1/%d)" (UriManager.string_of_uri baseuri) (tyno+1)) - | Cic.MutConstruct (baseuri, tyno, consno, []) -> - UriManager.uri_of_string - (sprintf "%s#xpointer(1/%d/%d)" (UriManager.string_of_uri baseuri) - (tyno + 1) consno) - | _ -> raise (Invalid_argument "uri_of_term") - - -(* -let pack terms = - List.fold_right - (fun term acc -> Cic.Prod (Cic.Anonymous, term, acc)) - terms (Cic.Sort (Cic.Type (CicUniv.fresh ()))) - -let rec unpack = function - | Cic.Prod (Cic.Anonymous, term, Cic.Sort (Cic.Type _)) -> [term] - | Cic.Prod (Cic.Anonymous, term, tgt) -> term :: unpack tgt - | _ -> assert false -*) - -let rec strip_prods n = function - | t when n = 0 -> t - | Cic.Prod (_, _, tgt) when n > 0 -> strip_prods (n-1) tgt - | _ -> failwith "not enough prods" - -let params_of_obj = function - | Cic.Constant (_, _, _, params, _) - | Cic.Variable (_, _, _, params, _) - | Cic.CurrentProof (_, _, _, _, params, _) - | Cic.InductiveDefinition (_, params, _, _) -> - params - -let attributes_of_obj = function - | Cic.Constant (_, _, _, _, attributes) - | Cic.Variable (_, _, _, _, attributes) - | Cic.CurrentProof (_, _, _, _, _, attributes) - | Cic.InductiveDefinition (_, _, _, attributes) -> - attributes -let rec mk_rels howmany from = - match howmany with - | 0 -> [] - | _ -> (Cic.Rel (howmany + from)) :: (mk_rels (howmany-1) from) - -let id_of_annterm = - function - | Cic.ARel (id,_,_,_) - | Cic.AVar (id,_,_) - | Cic.AMeta (id,_,_) - | Cic.ASort (id,_) - | Cic.AImplicit (id,_) - | Cic.ACast (id,_,_) - | Cic.AProd (id,_,_,_) - | Cic.ALambda (id,_,_,_) - | Cic.ALetIn (id,_,_,_) - | Cic.AAppl (id,_) - | Cic.AConst (id,_,_) - | Cic.AMutInd (id,_,_,_) - | Cic.AMutConstruct (id,_,_,_,_) - | Cic.AMutCase (id,_,_,_,_,_) - | Cic.AFix (id,_,_) - | Cic.ACoFix (id,_,_) -> id - - -let rec rehash_term = - let module C = Cic in - let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in - function - | (C.Rel _) as t -> t - | C.Var (uri,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) ->(recons uri,rehash_term t)) - exp_named_subst - in - C.Var (uri',exp_named_subst') - | C.Meta (i,l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (rehash_term t) - ) l - in - C.Meta(i,l') - | C.Sort (C.Type u) -> - CicUniv.assert_univ u; - C.Sort (C.Type (CicUniv.recons_univ u)) - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (rehash_term te, rehash_term ty) - | C.Prod (n,s,t) -> C.Prod (n, rehash_term s, rehash_term t) - | C.Lambda (n,s,t) -> C.Lambda (n, rehash_term s, rehash_term t) - | C.LetIn (n,s,t) -> C.LetIn (n, rehash_term s, rehash_term t) - | C.Appl l -> C.Appl (List.map rehash_term l) - | C.Const (uri,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst - in - C.Const (uri',exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst - in - C.MutInd (uri',tyno,exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst - in - C.MutConstruct (uri',tyno,consno,exp_named_subst') - | C.MutCase (uri,i,outty,t,pl) -> - C.MutCase (recons uri, i, rehash_term outty, rehash_term t, - List.map rehash_term pl) - | C.Fix (i, fl) -> - let liftedfl = - List.map - (fun (name, i, ty, bo) -> - (name, i, rehash_term ty, rehash_term bo)) - fl - in - C.Fix (i, liftedfl) - | C.CoFix (i, fl) -> - let liftedfl = - List.map - (fun (name, ty, bo) -> (name, rehash_term ty, rehash_term bo)) - fl - in - C.CoFix (i, liftedfl) - -let rehash_obj = - let module C = Cic in - let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in - function - C.Constant (name,bo,ty,params,attrs) -> - let bo' = - match bo with - None -> None - | Some bo -> Some (rehash_term bo) - in - let ty' = rehash_term ty in - let params' = List.map recons params in - C.Constant (name, bo', ty', params',attrs) - | C.CurrentProof (name,conjs,bo,ty,params,attrs) -> - let conjs' = - List.map - (function (i,hyps,ty) -> - (i, - List.map (function - None -> None - | Some (name,C.Decl t) -> - Some (name,C.Decl (rehash_term t)) - | Some (name,C.Def (bo,ty)) -> - let ty' = - match ty with - None -> None - | Some ty'' -> Some (rehash_term ty'') - in - Some (name,C.Def (rehash_term bo, ty'))) hyps, - rehash_term ty)) - conjs - in - let bo' = rehash_term bo in - let ty' = rehash_term ty in - let params' = List.map recons params in - C.CurrentProof (name, conjs', bo', ty', params',attrs) - | C.Variable (name,bo,ty,params,attrs) -> - let bo' = - match bo with - None -> None - | Some bo -> Some (rehash_term bo) - in - let ty' = rehash_term ty in - let params' = List.map recons params in - C.Variable (name, bo', ty', params',attrs) - | C.InductiveDefinition (tl,params,paramsno,attrs) -> - let params' = List.map recons params in - let tl' = - List.map (function (name, inductive, ty, constructors) -> - name, - inductive, - rehash_term ty, - (List.map - (function (name, ty) -> name, rehash_term ty) - constructors)) - tl - in - C.InductiveDefinition (tl', params', paramsno, attrs) - diff --git a/helm/ocaml/cic/cicUtil.mli b/helm/ocaml/cic/cicUtil.mli deleted file mode 100644 index b6fd7459d..000000000 --- a/helm/ocaml/cic/cicUtil.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -exception Meta_not_found of int -exception Subst_not_found of int - -val lookup_meta: int -> Cic.metasenv -> Cic.conjecture -val lookup_subst: int -> Cic.substitution -> Cic.context * Cic.term * Cic.term -val exists_meta: int -> Cic.metasenv -> bool -val clean_up_local_context : - Cic.substitution -> Cic.metasenv -> int -> (Cic.term option) list - -> (Cic.term option) list - -val is_closed : Cic.term -> bool -val is_meta_closed : Cic.term -> bool - - (** @raise Failure "not enough prods" *) -val strip_prods: int -> Cic.term -> Cic.term - -(** conversions between terms which are fully representable as uris (Var, Const, - * Mutind, and MutConstruct) and corresponding tree representations *) -val term_of_uri: UriManager.uri -> Cic.term (** @raise UriManager.IllFormedUri *) -val uri_of_term: Cic.term -> UriManager.uri (** @raise Invalid_argument "uri_of_term" *) - -val id_of_annterm: Cic.annterm -> Cic.id - -(** {2 Cic selectors} *) - -val params_of_obj: Cic.obj -> UriManager.uri list -val attributes_of_obj: Cic.obj -> Cic.attribute list - -(** mk_rels [howmany] [from] - * creates a list of [howmany] rels starting from [from] in decreasing order *) -val mk_rels : int -> int -> Cic.term list - -(** {2 Uri hash consing} *) -val rehash_term: Cic.term -> Cic.term -val rehash_obj: Cic.obj -> Cic.obj - diff --git a/helm/ocaml/cic/deannotate.ml b/helm/ocaml/cic/deannotate.ml deleted file mode 100644 index f04f5aa10..000000000 --- a/helm/ocaml/cic/deannotate.ml +++ /dev/null @@ -1,126 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -(* 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,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 - (function - None -> None - | Some at -> Some (deannotate_term at) - ) l - in - C.Meta (n, l') - | C.ASort (_,s) -> C.Sort s - | C.AImplicit (_, annotation) -> C.Implicit annotation - | C.ACast (_,va,ty) -> C.Cast (deannotate_term va, deannotate_term ty) - | C.AProd (_,name,so,ta) -> - C.Prod (name, deannotate_term so, deannotate_term ta) - | C.ALambda (_,name,so,ta) -> - C.Lambda (name, deannotate_term so, deannotate_term ta) - | 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,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) = - (name, index, deannotate_term ty, deannotate_term bo) - -and deannotate_coinductiveFun (_,name,ty,bo) = - (name, deannotate_term ty, deannotate_term bo) -;; - -let deannotate_inductiveType (_, name, isinductive, arity, cons) = - (name, isinductive, deannotate_term arity, - List.map (fun (id,ty) -> (id,deannotate_term ty)) cons) -;; - -let deannotate_obj = - let module C = Cic in - function - C.AConstant (_, _, id, bo, ty, params, attrs) -> - C.Constant (id, - (match bo with None -> None | Some bo -> Some (deannotate_term bo)), - deannotate_term ty, params, attrs) - | C.AVariable (_, name, bo, ty, params, attrs) -> - C.Variable (name, - (match bo with None -> None | Some bo -> Some (deannotate_term bo)), - deannotate_term ty, params, attrs) - | C.ACurrentProof (_, _, name, conjs, bo, ty, params, attrs) -> - C.CurrentProof ( - name, - List.map - (function - (_,id,acontext,con) -> - let context = - List.map - (function - _,Some (n,(C.ADef at)) -> - Some (n,(C.Def ((deannotate_term at),None))) - | _,Some (n,(C.ADecl at)) -> - Some (n,(C.Decl (deannotate_term at))) - | _,None -> None - ) acontext - in - (id,context,deannotate_term con) - ) conjs, - deannotate_term bo,deannotate_term ty, params, attrs - ) - | C.AInductiveDefinition (_, tys, params, parno, attrs) -> - C.InductiveDefinition (List.map deannotate_inductiveType tys, - params, parno, attrs) -;; diff --git a/helm/ocaml/cic/deannotate.mli b/helm/ocaml/cic/deannotate.mli deleted file mode 100644 index 89b18d2d6..000000000 --- a/helm/ocaml/cic/deannotate.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* 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 *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 29/11/2000 *) -(* *) -(******************************************************************************) - -val deannotate_term : Cic.annterm -> Cic.term -val deannotate_obj : Cic.annobj -> Cic.obj diff --git a/helm/ocaml/cic/discrimination_tree.ml b/helm/ocaml/cic/discrimination_tree.ml deleted file mode 100644 index bab98921d..000000000 --- a/helm/ocaml/cic/discrimination_tree.ml +++ /dev/null @@ -1,343 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -module DiscriminationTreeIndexing = - functor (A:Set.S) -> - struct - - type path_string_elem = Cic.term;; - type path_string = path_string_elem list;; - - - (* needed by the retrieve_* functions, to know the arities of the "functions" *) - - let arities = Hashtbl.create 11;; - - - let rec path_string_of_term = function - | Cic.Meta _ -> [Cic.Implicit None] - | Cic.Appl ((hd::tl) as l) -> - if not (Hashtbl.mem arities hd) then - Hashtbl.add arities hd (List.length tl); - List.concat (List.map path_string_of_term l) - | term -> [term] - ;; - - - module OrderedPathStringElement = struct - type t = path_string_elem - - let compare = Pervasives.compare - end - - module PSMap = Map.Make(OrderedPathStringElement);; - - type key = PSMap.key - - module DiscriminationTree = Trie.Make(PSMap);; - - type t = A.t DiscriminationTree.t - let empty = DiscriminationTree.empty - -(* - module OrderedPosEquality = struct - type t = Utils.pos * Inference.equality - let compare = Pervasives.compare - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - let string_of_discrimination_tree tree = - let rec to_string level = function - | DiscriminationTree.Node (value, map) -> - let s = - match value with - | Some v -> - (String.make (2 * level) ' ') ^ - "{" ^ (String.concat "; " - (List.map - (fun (p, e) -> - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")") - (PosEqSet.elements v))) ^ "}" - | None -> "" - in - let rest = - String.concat "\n" - (PSMap.fold - (fun k v s -> - let ks = CicPp.ppterm k in - let rs = to_string (level+1) v in - ((String.make (2 * level) ' ') ^ ks ^ "\n" ^ rs)::s) - map []) - in - s ^ rest - in - to_string 0 tree - ;; -*) - - let index tree term info = - let ps = path_string_of_term term in - let ps_set = - try DiscriminationTree.find ps tree - with Not_found -> A.empty in - let tree = - DiscriminationTree.add ps (A.add info ps_set) tree in - tree - -(* - let index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let psl = path_string_of_term l - and psr = path_string_of_term r in - let index pos tree ps = - let ps_set = - try DiscriminationTree.find ps tree with Not_found -> PosEqSet.empty in - let tree = - DiscriminationTree.add ps (PosEqSet.add (pos, equality) ps_set) tree in - tree - in - match ordering with - | Utils.Gt -> index Utils.Left tree psl - | Utils.Lt -> index Utils.Right tree psr - | _ -> - let tree = index Utils.Left tree psl in - index Utils.Right tree psr - ;; -*) - - let remove_index tree term info = - let ps = path_string_of_term term in - try - let ps_set = - A.remove info (DiscriminationTree.find ps tree) in - if A.is_empty ps_set then - DiscriminationTree.remove ps tree - else - DiscriminationTree.add ps ps_set tree - with Not_found -> - tree - -(* -let remove_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let psl = path_string_of_term l - and psr = path_string_of_term r in - let remove_index pos tree ps = - try - let ps_set = - PosEqSet.remove (pos, equality) (DiscriminationTree.find ps tree) in - if PosEqSet.is_empty ps_set then - DiscriminationTree.remove ps tree - else - DiscriminationTree.add ps ps_set tree - with Not_found -> - tree - in - match ordering with - | Utils.Gt -> remove_index Utils.Left tree psl - | Utils.Lt -> remove_index Utils.Right tree psr - | _ -> - let tree = remove_index Utils.Left tree psl in - remove_index Utils.Right tree psr -;; -*) - - - let in_index tree term test = - let ps = path_string_of_term term in - try - let ps_set = DiscriminationTree.find ps tree in - A.exists test ps_set - with Not_found -> - false - -(* - let in_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let psl = path_string_of_term l - and psr = path_string_of_term r in - let meta_convertibility = Inference.meta_convertibility_eq equality in - let ok ps = - try - let set = DiscriminationTree.find ps tree in - PosEqSet.exists (fun (p, e) -> meta_convertibility e) set - with Not_found -> - false - in - (ok psl) || (ok psr) -;; -*) - - - let head_of_term = function - | Cic.Appl (hd::tl) -> hd - | term -> term - ;; - - - let rec subterm_at_pos pos term = - match pos with - | [] -> term - | index::pos -> - match term with - | Cic.Appl l -> - (try subterm_at_pos pos (List.nth l index) - with Failure _ -> raise Not_found) - | _ -> raise Not_found - ;; - - - let rec after_t pos term = - let pos' = - match pos with - | [] -> raise Not_found - | pos -> List.fold_right (fun i r -> if r = [] then [i+1] else i::r) pos [] - in - try - ignore(subterm_at_pos pos' term ); pos' - with Not_found -> - let pos, _ = - List.fold_right - (fun i (r, b) -> if b then (i::r, true) else (r, true)) pos ([], false) - in - after_t pos term - ;; - - - let next_t pos term = - let t = subterm_at_pos pos term in - try - let _ = subterm_at_pos [1] t in - pos @ [1] - with Not_found -> - match pos with - | [] -> [1] - | pos -> after_t pos term - ;; - - - let retrieve_generalizations tree term = - let rec retrieve tree term pos = - match tree with - | DiscriminationTree.Node (Some s, _) when pos = [] -> s - | DiscriminationTree.Node (_, map) -> - let res = - try - let hd_term = head_of_term (subterm_at_pos pos term) in - let n = PSMap.find hd_term map in - match n with - | DiscriminationTree.Node (Some s, _) -> s - | DiscriminationTree.Node (None, _) -> - let newpos = try next_t pos term with Not_found -> [] in - retrieve n term newpos - with Not_found -> - A.empty - in - try - let n = PSMap.find (Cic.Implicit None) map in - let newpos = try after_t pos term with Not_found -> [-1] in - if newpos = [-1] then - match n with - | DiscriminationTree.Node (Some s, _) -> A.union s res - | _ -> res - else - A.union res (retrieve n term newpos) - with Not_found -> - res - in - retrieve tree term [] - ;; - - - let jump_list = function - | DiscriminationTree.Node (value, map) -> - let rec get n tree = - match tree with - | DiscriminationTree.Node (v, m) -> - if n = 0 then - [tree] - else - PSMap.fold - (fun k v res -> - let a = try Hashtbl.find arities k with Not_found -> 0 in - (get (n-1 + a) v) @ res) m [] - in - PSMap.fold - (fun k v res -> - let arity = try Hashtbl.find arities k with Not_found -> 0 in - (get arity v) @ res) - map [] - ;; - - - let retrieve_unifiables tree term = - let rec retrieve tree term pos = - match tree with - | DiscriminationTree.Node (Some s, _) when pos = [] -> s - | DiscriminationTree.Node (_, map) -> - let subterm = - try Some (subterm_at_pos pos term) with Not_found -> None - in - match subterm with - | None -> A.empty - | Some (Cic.Meta _) -> - let newpos = try next_t pos term with Not_found -> [] in - let jl = jump_list tree in - List.fold_left - (fun r s -> A.union r s) - A.empty - (List.map (fun t -> retrieve t term newpos) jl) - | Some subterm -> - let res = - try - let hd_term = head_of_term subterm in - let n = PSMap.find hd_term map in - match n with - | DiscriminationTree.Node (Some s, _) -> s - | DiscriminationTree.Node (None, _) -> - retrieve n term (next_t pos term) - with Not_found -> - A.empty - in - try - let n = PSMap.find (Cic.Implicit None) map in - let newpos = try after_t pos term with Not_found -> [-1] in - if newpos = [-1] then - match n with - | DiscriminationTree.Node (Some s, _) -> A.union s res - | _ -> res - else - A.union res (retrieve n term newpos) - with Not_found -> - res - in - retrieve tree term [] - end -;; - diff --git a/helm/ocaml/cic/discrimination_tree.mli b/helm/ocaml/cic/discrimination_tree.mli deleted file mode 100644 index 61631f478..000000000 --- a/helm/ocaml/cic/discrimination_tree.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -module DiscriminationTreeIndexing : - functor (A : Set.S) -> - sig - - val arities : (Cic.term, int) Hashtbl.t - - type key = Cic.term - type t - - val empty : t - val index : t -> key -> A.elt -> t - val remove_index : t -> key -> A.elt -> t - val in_index : t -> key -> (A.elt -> bool) -> bool - val retrieve_generalizations : t -> key -> A.t - val retrieve_unifiables : t -> key -> A.t - end - - diff --git a/helm/ocaml/cic/helmLibraryObjects.ml b/helm/ocaml/cic/helmLibraryObjects.ml deleted file mode 100644 index 3038582ab..000000000 --- a/helm/ocaml/cic/helmLibraryObjects.ml +++ /dev/null @@ -1,230 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -(** {2 Auxiliary functions} *) - -let uri = UriManager.uri_of_string - -let const ?(subst = []) uri = Cic.Const (uri, subst) -let var ?(subst = []) uri = Cic.Var (uri, subst) -let mutconstruct ?(subst = []) uri typeno consno = - Cic.MutConstruct (uri, typeno, consno, subst) -let mutind ?(subst = []) uri typeno = Cic.MutInd (uri, typeno, subst) - -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) - -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))) - -(** {2 Helm's objects shorthands} *) - -module Logic = - struct - let eq_SURI = "cic:/Coq/Init/Logic/eq.ind" - let eq_URI = uri eq_SURI - let eq_XURI = eq_SURI ^ "#xpointer(1/1)" - let eq_ind_URI = uri "cic:/Coq/Init/Logic/eq_ind.con" - let eq_ind_r_URI = uri "cic:/Coq/Init/Logic/eq_ind_r.con" - let true_URI = uri "cic:/Coq/Init/Logic/True.ind" - let false_URI = uri "cic:/Coq/Init/Logic/False.ind" - let false_ind_URI = uri "cic:/Coq/Init/Logic/False_ind.con" - let ex_SURI = "cic:/Coq/Init/Logic/ex.ind" - let ex_URI = uri ex_SURI - let ex_XURI = ex_SURI ^ "#xpointer(1/1)" - let ex_ind_URI = uri "cic:/Coq/Init/Logic/ex_ind.con" - let and_SURI = "cic:/Coq/Init/Logic/and.ind" - let and_URI = uri and_SURI - let and_XURI = and_SURI ^ "#xpointer(1/1)" - let and_ind_URI = uri "cic:/Coq/Init/Logic/and_ind.con" - let or_SURI = "cic:/Coq/Init/Logic/or.ind" - let or_URI = uri or_SURI - let or_XURI = or_SURI ^ "#xpointer(1/1)" - let not_SURI = "cic:/Coq/Init/Logic/not.con" - let not_URI = uri not_SURI - let iff_SURI = "cic:/Coq/Init/Logic/iff.con" - let iff_URI = uri "cic:/Coq/Init/Logic/iff.con" - let sym_eq_URI = uri "cic:/Coq/Init/Logic/sym_eq.con" - let trans_eq_URI = uri "cic:/Coq/Init/Logic/trans_eq.con" - let absurd_URI = uri "cic:/Coq/Init/Logic/absurd.con" - end - -module Datatypes = - struct - let bool_URI = uri "cic:/Coq/Init/Datatypes/bool.ind" - let nat_URI = uri "cic:/Coq/Init/Datatypes/nat.ind" - - let trueb = mutconstruct bool_URI 0 1 - let falseb = mutconstruct bool_URI 0 2 - let zero = mutconstruct nat_URI 0 1 - let succ = mutconstruct nat_URI 0 2 - end - -module Reals = - struct - let r_URI = uri "cic:/Coq/Reals/Rdefinitions/R.con" - let rplus_SURI = "cic:/Coq/Reals/Rdefinitions/Rplus.con" - let rplus_URI = uri rplus_SURI - let rminus_SURI = "cic:/Coq/Reals/Rdefinitions/Rminus.con" - let rminus_URI = uri rminus_SURI - let rmult_SURI = "cic:/Coq/Reals/Rdefinitions/Rmult.con" - let rmult_URI = uri rmult_SURI - let rdiv_SURI = "cic:/Coq/Reals/Rdefinitions/Rdiv.con" - let rdiv_URI = uri rdiv_SURI - let ropp_SURI = "cic:/Coq/Reals/Rdefinitions/Ropp.con" - let ropp_URI = uri ropp_SURI - let rinv_SURI = "cic:/Coq/Reals/Rdefinitions/Rinv.con" - let rinv_URI = uri rinv_SURI - let r0_SURI = "cic:/Coq/Reals/Rdefinitions/R0.con" - let r0_URI = uri r0_SURI - let r1_SURI = "cic:/Coq/Reals/Rdefinitions/R1.con" - let r1_URI = uri r1_SURI - let rle_SURI = "cic:/Coq/Reals/Rdefinitions/Rle.con" - let rle_URI = uri rle_SURI - let rge_SURI = "cic:/Coq/Reals/Rdefinitions/Rge.con" - let rge_URI = uri rge_SURI - let rlt_SURI = "cic:/Coq/Reals/Rdefinitions/Rlt.con" - let rlt_URI = uri rlt_SURI - let rgt_SURI = "cic:/Coq/Reals/Rdefinitions/Rgt.con" - let rgt_URI = uri rgt_SURI - let rtheory_URI = uri "cic:/Coq/Reals/RIneq/RTheory.con" - let rinv_r1_URI = uri "cic:/Coq/Reals/RIneq/Rinv_1.con" - let pow_URI = uri "cic:/Coq/Reals/Rfunctions/pow.con" - - let r = const r_URI - let rplus = const rplus_URI - let rmult = const rmult_URI - let ropp = const ropp_URI - let r0 = const r0_URI - let r1 = const r1_URI - let rtheory = const rtheory_URI - end - -module Peano = - struct - let plus_SURI = "cic:/Coq/Init/Peano/plus.con" - let plus_URI = uri plus_SURI - let minus_SURI = "cic:/Coq/Init/Peano/minus.con" - let minus_URI = uri minus_SURI - let mult_SURI = "cic:/Coq/Init/Peano/mult.con" - let mult_URI = uri mult_SURI - let pred_URI = uri "cic:/Coq/Init/Peano/pred.con" - let le_SURI = "cic:/Coq/Init/Peano/le.ind" - let le_URI = uri le_SURI - let le_XURI = le_SURI ^ "#xpointer(1/1)" - let ge_SURI = "cic:/Coq/Init/Peano/ge.con" - let ge_URI = uri ge_SURI - let lt_SURI = "cic:/Coq/Init/Peano/lt.con" - let lt_URI = uri lt_SURI - let gt_SURI = "cic:/Coq/Init/Peano/gt.con" - let gt_URI = uri gt_SURI - - let plus = const plus_URI - let mult = const mult_URI - let pred = const pred_URI - end - -module BinPos = - struct - let positive_SURI = "cic:/Coq/NArith/BinPos/positive.ind" - let positive_URI = uri positive_SURI - let xI = mutconstruct positive_URI 0 1 - let xO = mutconstruct positive_URI 0 2 - let xH = mutconstruct positive_URI 0 3 - let pplus_SURI = "cic:/Coq/NArith/BinPos/Pplus.con" - let pplus_URI = uri pplus_SURI - let pplus = const pplus_URI - let pminus_SURI = "cic:/Coq/NArith/BinPos/Pminus.con" - let pminus_URI = uri pminus_SURI - let pminus = const pminus_URI - let pmult_SURI = "cic:/Coq/NArith/BinPos/Pmult.con" - let pmult_URI = uri pmult_SURI - let pmult = const pmult_URI - end - -module BinInt = - struct - let zmult_URI = uri "cic:/Coq/ZArith/BinInt/Zmult.con" - let zmult = const zmult_URI - let zplus_SURI = "cic:/Coq/ZArith/BinInt/Zplus.con" - let zplus_URI = uri zplus_SURI - let zplus = const zplus_URI - let zminus_SURI = "cic:/Coq/ZArith/BinInt/Zminus.con" - let zminus_URI = uri zminus_SURI - let zminus = const zminus_URI - let z_SURI = "cic:/Coq/ZArith/BinInt/Z.ind" - let z_URI = uri z_SURI - let z0 = mutconstruct z_URI 0 1 - let zpos = mutconstruct z_URI 0 2 - let zneg = mutconstruct z_URI 0 3 - let zopp_SURI = "cic:/Coq/ZArith/BinInt/Zopp.con" - let zopp_URI = uri zopp_SURI - let zopp = const zopp_URI - let zpower_URI = uri "cic:/Coq/ZArith/Zpower/Zpower.con" - end - -(** {2 Helpers for creating common terms} - * (e.g. numbers)} *) - -exception NegativeInteger - -let build_nat n = - if n < 0 then raise NegativeInteger; - let rec aux = function - | 0 -> Datatypes.zero - | n -> Cic.Appl [ Datatypes.succ; (aux (n - 1)) ] - in - aux n - -let build_real n = - if n < 0 then raise NegativeInteger; - let rec aux = function - | 0 -> Reals.r0 - | 1 -> Reals.r1 (* to avoid trailing "+ 0" *) - | n -> Cic.Appl [ Reals.rplus; Reals.r1; (aux (n - 1)) ] - in - aux n - -let build_bin_pos n = - if n < 1 then raise NegativeInteger; - let rec aux = function - | 1 -> BinPos.xH - | n when n mod 2 = 0 -> Cic.Appl [ BinPos.xO; aux (n / 2) ] - | n -> Cic.Appl [ BinPos.xI; aux (n / 2) ] - in - aux n - diff --git a/helm/ocaml/cic/helmLibraryObjects.mli b/helm/ocaml/cic/helmLibraryObjects.mli deleted file mode 100644 index 677879899..000000000 --- a/helm/ocaml/cic/helmLibraryObjects.mli +++ /dev/null @@ -1,182 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -module Logic : - sig - val absurd_URI : UriManager.uri - val and_ind_URI : UriManager.uri - val and_URI : UriManager.uri - val eq_ind_r_URI : UriManager.uri - val eq_ind_URI : UriManager.uri - val eq_URI : UriManager.uri - val ex_ind_URI : UriManager.uri - val ex_URI : UriManager.uri - val false_ind_URI : UriManager.uri - val false_URI : UriManager.uri - val iff_URI : UriManager.uri - val not_URI : UriManager.uri - val or_URI : UriManager.uri - val sym_eq_URI : UriManager.uri - val trans_eq_URI : UriManager.uri - val true_URI : UriManager.uri - - val and_SURI : string - val eq_SURI : string - val ex_SURI : string - val iff_SURI : string - val not_SURI : string - val or_SURI : string - - val and_XURI : string - val eq_XURI : string - val ex_XURI : string - val or_XURI : string - end - -module Datatypes : - sig - val bool_URI : UriManager.uri - val nat_URI : UriManager.uri - - val trueb : Cic.term - val falseb : Cic.term - val zero : Cic.term - val succ : Cic.term - end - -module Reals : - sig - val pow_URI : UriManager.uri - val r0_URI : UriManager.uri - val r1_URI : UriManager.uri - val rdiv_URI : UriManager.uri - val rge_URI : UriManager.uri - val rgt_URI : UriManager.uri - val rinv_r1_URI : UriManager.uri - val rinv_URI : UriManager.uri - val rle_URI : UriManager.uri - val rlt_URI : UriManager.uri - val rminus_URI : UriManager.uri - val rmult_URI : UriManager.uri - val ropp_URI : UriManager.uri - val rplus_URI : UriManager.uri - val rtheory_URI : UriManager.uri - val r_URI : UriManager.uri - - val r0_SURI : string - val r1_SURI : string - val rdiv_SURI : string - val rge_SURI : string - val rgt_SURI : string - val rinv_SURI : string - val rle_SURI : string - val rlt_SURI : string - val rminus_SURI : string - val rmult_SURI : string - val ropp_SURI : string - val rplus_SURI : string - - val r0 : Cic.term - val r1 : Cic.term - val r : Cic.term - val rmult : Cic.term - val ropp : Cic.term - val rplus : Cic.term - val rtheory : Cic.term - end - -module Peano : - sig - val ge_URI : UriManager.uri - val gt_URI : UriManager.uri - val le_URI : UriManager.uri - val lt_URI : UriManager.uri - val minus_URI : UriManager.uri - val mult_URI : UriManager.uri - val plus_URI : UriManager.uri - val pred_URI : UriManager.uri - - val ge_SURI : string - val gt_SURI : string - val le_SURI : string - val lt_SURI : string - val minus_SURI : string - val mult_SURI : string - val plus_SURI : string - - val le_XURI : string - - val mult : Cic.term - val plus : Cic.term - val pred : Cic.term - end - -module BinPos : - sig - val pminus_URI : UriManager.uri - val pmult_URI : UriManager.uri - val positive_URI : UriManager.uri - val pplus_URI : UriManager.uri - - val pminus_SURI : string - val pmult_SURI : string - val positive_SURI : string - val pplus_SURI : string - - val pminus : Cic.term - val pmult : Cic.term - val pplus : Cic.term - val xH : Cic.term - val xI : Cic.term - val xO : Cic.term - end - -module BinInt : - sig - val zminus_URI : UriManager.uri - val zmult_URI : UriManager.uri - val zopp_URI : UriManager.uri - val zplus_URI : UriManager.uri - val zpower_URI : UriManager.uri - val z_URI : UriManager.uri - - val zminus_SURI : string - val zopp_SURI : string - val zplus_SURI : string - val z_SURI : string - - val z0 : Cic.term - val zminus : Cic.term - val zmult : Cic.term - val zneg : Cic.term - val zopp : Cic.term - val zplus : Cic.term - val zpos : Cic.term - end - -val build_bin_pos : int -> Cic.term -val build_nat : int -> Cic.term -val build_real : int -> Cic.term - diff --git a/helm/ocaml/cic/libraryObjects.ml b/helm/ocaml/cic/libraryObjects.ml deleted file mode 100644 index adbc219cc..000000000 --- a/helm/ocaml/cic/libraryObjects.ml +++ /dev/null @@ -1,122 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -(**** TABLES ****) - -let default_eq_URIs = - [HelmLibraryObjects.Logic.eq_URI, - HelmLibraryObjects.Logic.sym_eq_URI, - HelmLibraryObjects.Logic.trans_eq_URI, - HelmLibraryObjects.Logic.eq_ind_URI, - HelmLibraryObjects.Logic.eq_ind_r_URI];; - -let default_true_URIs = [HelmLibraryObjects.Logic.true_URI] -let default_false_URIs = [HelmLibraryObjects.Logic.false_URI] -let default_absurd_URIs = [HelmLibraryObjects.Logic.absurd_URI] - -(* eq, sym_eq, trans_eq, eq_ind, eq_ind_R *) -let eq_URIs_ref = - ref [HelmLibraryObjects.Logic.eq_URI, - HelmLibraryObjects.Logic.sym_eq_URI, - HelmLibraryObjects.Logic.trans_eq_URI, - HelmLibraryObjects.Logic.eq_ind_URI, - HelmLibraryObjects.Logic.eq_ind_r_URI];; - -let true_URIs_ref = ref [HelmLibraryObjects.Logic.true_URI] -let false_URIs_ref = ref [HelmLibraryObjects.Logic.false_URI] -let absurd_URIs_ref = ref [HelmLibraryObjects.Logic.absurd_URI] - - -(**** SET_DEFAULT ****) - -exception NotRecognized;; - -(* insert an element in front of the list, removing from the list all the - previous elements with the same key associated *) -let insert_unique e extract l = - let uri = extract e in - let l' = - List.filter (fun x -> let uri' = extract x in not (UriManager.eq uri uri')) l - in - e :: l' - -let set_default what l = - match what,l with - "equality",[eq_URI;sym_eq_URI;trans_eq_URI;eq_ind_URI;eq_ind_r_URI] -> - eq_URIs_ref := - insert_unique (eq_URI,sym_eq_URI,trans_eq_URI,eq_ind_URI,eq_ind_r_URI) - (fun x,_,_,_,_ -> x) !eq_URIs_ref - | "true",[true_URI] -> - true_URIs_ref := insert_unique true_URI (fun x -> x) !true_URIs_ref - | "false",[false_URI] -> - false_URIs_ref := insert_unique false_URI (fun x -> x) !false_URIs_ref - | "absurd",[absurd_URI] -> - absurd_URIs_ref := insert_unique absurd_URI (fun x -> x) !absurd_URIs_ref - | _,_ -> raise NotRecognized - -let reset_defaults () = - eq_URIs_ref := default_eq_URIs; - true_URIs_ref := default_true_URIs; - false_URIs_ref := default_false_URIs; - absurd_URIs_ref := default_absurd_URIs - -(**** LOOKUP FUNCTIONS ****) - -let eq_URI () = let eq,_,_,_,_ = List.hd !eq_URIs_ref in eq - -let is_eq_URI uri = - List.exists (fun (eq,_,_,_,_) -> UriManager.eq eq uri) !eq_URIs_ref - -let is_eq_ind_URI uri = - List.exists (fun (_,_,_,eq_ind,_) -> UriManager.eq eq_ind uri) !eq_URIs_ref - -let is_eq_ind_r_URI uri = - List.exists (fun (_,_,_,_,eq_ind_r) -> UriManager.eq eq_ind_r uri) !eq_URIs_ref - -let sym_eq_URI ~eq:uri = - try - let _,x,_,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x - with Not_found -> raise NotRecognized - -let trans_eq_URI ~eq:uri = - try - let _,_,x,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x - with Not_found -> raise NotRecognized - -let eq_ind_URI ~eq:uri = - try - let _,_,_,x,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x - with Not_found -> raise NotRecognized - -let eq_ind_r_URI ~eq:uri = - try - let _,_,_,_,x = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x - with Not_found -> raise NotRecognized - -let true_URI () = List.hd !true_URIs_ref -let false_URI () = List.hd !false_URIs_ref -let absurd_URI () = List.hd !absurd_URIs_ref diff --git a/helm/ocaml/cic/libraryObjects.mli b/helm/ocaml/cic/libraryObjects.mli deleted file mode 100644 index eca5a0d90..000000000 --- a/helm/ocaml/cic/libraryObjects.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val set_default : string -> UriManager.uri list -> unit -val reset_defaults : unit -> unit - -val eq_URI : unit -> UriManager.uri - -val is_eq_URI : UriManager.uri -> bool -val is_eq_ind_URI : UriManager.uri -> bool -val is_eq_ind_r_URI : UriManager.uri -> bool - -exception NotRecognized;; - -val eq_ind_URI : eq:UriManager.uri -> UriManager.uri -val eq_ind_r_URI : eq:UriManager.uri -> UriManager.uri -val trans_eq_URI : eq:UriManager.uri -> UriManager.uri -val sym_eq_URI : eq:UriManager.uri -> UriManager.uri - - -val false_URI : unit -> UriManager.uri -val true_URI : unit -> UriManager.uri -val absurd_URI : unit -> UriManager.uri - diff --git a/helm/ocaml/cic/path_indexing.ml b/helm/ocaml/cic/path_indexing.ml deleted file mode 100644 index c0e4bb2be..000000000 --- a/helm/ocaml/cic/path_indexing.ml +++ /dev/null @@ -1,227 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -(* path indexing implementation *) - -(* position of the subterm, subterm (Appl are not stored...) *) - -module PathIndexing = - functor(A:Set.S) -> - struct - -type path_string_elem = Index of int | Term of Cic.term;; -type path_string = path_string_elem list;; - - -let rec path_strings_of_term index = - let module C = Cic in function - | C.Meta _ -> [ [Index index; Term (C.Implicit None)] ] - | C.Appl (hd::tl) -> - let p = if index > 0 then [Index index; Term hd] else [Term hd] in - let _, res = - List.fold_left - (fun (i, r) t -> - let rr = path_strings_of_term i t in - (i+1, r @ (List.map (fun ps -> p @ ps) rr))) - (1, []) tl - in - res - | term -> [ [Index index; Term term] ] -;; - -(* -let string_of_path_string ps = - String.concat "." - (List.map - (fun e -> - let s = - match e with - | Index i -> "Index " ^ (string_of_int i) - | Term t -> "Term " ^ (CicPp.ppterm t) - in - "(" ^ s ^ ")") - ps) -;; -*) - -module OrderedPathStringElement = struct - type t = path_string_elem - - let compare t1 t2 = - match t1, t2 with - | Index i, Index j -> Pervasives.compare i j - | Term t1, Term t2 -> if t1 = t2 then 0 else Pervasives.compare t1 t2 - | Index _, Term _ -> -1 - | Term _, Index _ -> 1 -end - -module PSMap = Map.Make(OrderedPathStringElement);; - -module PSTrie = Trie.Make(PSMap);; - -type t = A.t PSTrie.t -type key = Cic.term -let empty = PSTrie.empty -let arities = Hashtbl.create 0 - -let index trie term info = - let ps = path_strings_of_term 0 term in - List.fold_left - (fun trie ps -> - let ps_set = try PSTrie.find ps trie with Not_found -> A.empty in - let trie = PSTrie.add ps (A.add info ps_set) trie in - trie) trie ps - -let remove_index trie term info= - let ps = path_strings_of_term 0 term in - List.fold_left - (fun trie ps -> - try - let ps_set = A.remove info (PSTrie.find ps trie) in - if A.is_empty ps_set then - PSTrie.remove ps trie - else - PSTrie.add ps ps_set trie - with Not_found -> trie) trie ps -;; - -let in_index trie term test = - let ps = path_strings_of_term 0 term in - let ok ps = - try - let set = PSTrie.find ps trie in - A.exists test set - with Not_found -> - false - in - List.exists ok ps -;; - - -let head_of_term = function - | Cic.Appl (hd::tl) -> hd - | term -> term -;; - - -let subterm_at_pos index term = - if index = 0 then - term - else - match term with - | Cic.Appl l -> - (try List.nth l index with Failure _ -> raise Not_found) - | _ -> raise Not_found -;; - - -let rec retrieve_generalizations trie term = - match trie with - | PSTrie.Node (value, map) -> - let res = - match term with - | Cic.Meta _ -> A.empty - | term -> - let hd_term = head_of_term term in - try - let n = PSMap.find (Term hd_term) map in - match n with - | PSTrie.Node (Some s, _) -> s - | PSTrie.Node (None, m) -> - let l = - PSMap.fold - (fun k v res -> - match k with - | Index i -> - let t = subterm_at_pos i term in - let s = retrieve_generalizations v t in - s::res - | _ -> res) - m [] - in - match l with - | hd::tl -> - List.fold_left (fun r s -> A.inter r s) hd tl - | _ -> A.empty - with Not_found -> - A.empty - in - try - let n = PSMap.find (Term (Cic.Implicit None)) map in - match n with - | PSTrie.Node (Some s, _) -> A.union res s - | _ -> res - with Not_found -> - res -;; - - -let rec retrieve_unifiables trie term = - match trie with - | PSTrie.Node (value, map) -> - let res = - match term with - | Cic.Meta _ -> - PSTrie.fold - (fun ps v res -> A.union res v) - (PSTrie.Node (None, map)) - A.empty - | _ -> - let hd_term = head_of_term term in - try - let n = PSMap.find (Term hd_term) map in - match n with - | PSTrie.Node (Some v, _) -> v - | PSTrie.Node (None, m) -> - let l = - PSMap.fold - (fun k v res -> - match k with - | Index i -> - let t = subterm_at_pos i term in - let s = retrieve_unifiables v t in - s::res - | _ -> res) - m [] - in - match l with - | hd::tl -> - List.fold_left (fun r s -> A.inter r s) hd tl - | _ -> A.empty - with Not_found -> - A.empty - in - try - let n = PSMap.find (Term (Cic.Implicit None)) map in - match n with - | PSTrie.Node (Some s, _) -> A.union res s - | _ -> res - with Not_found -> - res -;; - -end diff --git a/helm/ocaml/cic/path_indexing.mli b/helm/ocaml/cic/path_indexing.mli deleted file mode 100644 index 899901618..000000000 --- a/helm/ocaml/cic/path_indexing.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -module PathIndexing : - functor (A : Set.S) -> - sig - val arities : (Cic.term, int) Hashtbl.t - - type key = Cic.term - type t - - val empty : t - val index : t -> key -> A.elt -> t - val remove_index : t -> key -> A.elt -> t - val in_index : t -> key -> (A.elt -> bool) -> bool - val retrieve_generalizations : t -> key -> A.t - val retrieve_unifiables : t -> key -> A.t - end - - diff --git a/helm/ocaml/cic/test.ml b/helm/ocaml/cic/test.ml deleted file mode 100644 index e15468f99..000000000 --- a/helm/ocaml/cic/test.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let _ = - Helm_registry.set "getter.mode" "remote"; - Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/" - -let body_RE = Str.regexp "^.*\\.body$" -let con_RE = Str.regexp "^.*\\.con$" - -let unlink f = - if Sys.file_exists f then - Unix.unlink f - -let rec parse uri tmpfile1 tmpfile2 = -(*prerr_endline (sprintf "%s %s" tmpfile1 (match tmpfile2 with None -> "None" | Some f -> "Some " ^ f));*) - (try - let uri' = UriManager.uri_of_string uri in - let time_new0 = Unix.gettimeofday () in -(* let obj_new = CicPushParser.CicParser.annobj_of_xml tmpfile1 tmpfile2 in*) - let obj_new = CicParser.annobj_of_xml uri' tmpfile1 tmpfile2 in - let time_new1 = Unix.gettimeofday () in - - let time_old0 = Unix.gettimeofday () in - ignore (Unix.system (sprintf "gunzip -c %s > test.tmp && mv test.tmp %s" - tmpfile1 tmpfile1)); - (match tmpfile2 with - | Some tmpfile2 -> - ignore (Unix.system (sprintf "gunzip -c %s > test.tmp && mv test.tmp %s" - tmpfile2 tmpfile2)); - | None -> ()); - let obj_old = CicPxpParser.CicParser.annobj_of_xml uri' tmpfile1 tmpfile2 in - let time_old1 = Unix.gettimeofday () in - - let time_old = time_old1 -. time_old0 in - let time_new = time_new1 -. time_new0 in - let are_equal = (obj_old = obj_new) in - printf "%s\t%b\t%f\t%f\t%f\n" - uri are_equal time_old time_new (time_new /. time_old *. 100.); - flush stdout; - with - | CicParser.Getter_failure ("key_not_found", uri) - when Str.string_match body_RE uri 0 -> - parse uri tmpfile1 None - | CicParser.Parser_failure msg -> - printf "%s FAILED (%s)\n" uri msg; flush stdout) - -let _ = - try - while true do - let uri = input_line stdin in - let tmpfile1 = Http_getter.getxml uri in - let tmpfile2 = - if Str.string_match con_RE uri 0 then begin - Some (Http_getter.getxml (uri ^ ".body")) - end else - None - in - parse uri tmpfile1 tmpfile2 - done - with End_of_file -> () - diff --git a/helm/ocaml/cic/unshare.ml b/helm/ocaml/cic/unshare.ml deleted file mode 100644 index e198bcd49..000000000 --- a/helm/ocaml/cic/unshare.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let rec unshare = - let module C = Cic in - function - C.Rel m -> C.Rel m - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,unshare t)) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (i,l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (unshare t) - ) l - in - C.Meta(i,l') - | C.Sort s -> C.Sort s - | C.Implicit info -> C.Implicit info - | C.Cast (te,ty) -> C.Cast (unshare te, unshare ty) - | C.Prod (n,s,t) -> C.Prod (n, unshare s, unshare t) - | C.Lambda (n,s,t) -> C.Lambda (n, unshare s, unshare t) - | C.LetIn (n,s,t) -> C.LetIn (n, unshare s, unshare t) - | C.Appl l -> C.Appl (List.map unshare l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,unshare 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,unshare 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,unshare t)) exp_named_subst - in - C.MutConstruct (uri,tyno,consno,exp_named_subst') - | C.MutCase (sp,i,outty,t,pl) -> - C.MutCase (sp, i, unshare outty, unshare t, - List.map unshare pl) - | C.Fix (i, fl) -> - let liftedfl = - List.map - (fun (name, i, ty, bo) -> (name, i, unshare ty, unshare bo)) - fl - in - C.Fix (i, liftedfl) - | C.CoFix (i, fl) -> - let liftedfl = - List.map - (fun (name, ty, bo) -> (name, unshare ty, unshare bo)) - fl - in - C.CoFix (i, liftedfl) diff --git a/helm/ocaml/cic/unshare.mli b/helm/ocaml/cic/unshare.mli deleted file mode 100644 index 5582abcbf..000000000 --- a/helm/ocaml/cic/unshare.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* 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 unshare : Cic.term -> Cic.term diff --git a/helm/ocaml/cic_acic/.depend b/helm/ocaml/cic_acic/.depend deleted file mode 100644 index 3fc1e0dce..000000000 --- a/helm/ocaml/cic_acic/.depend +++ /dev/null @@ -1,9 +0,0 @@ -cic2Xml.cmi: cic2acic.cmi -eta_fixing.cmo: eta_fixing.cmi -eta_fixing.cmx: eta_fixing.cmi -doubleTypeInference.cmo: doubleTypeInference.cmi -doubleTypeInference.cmx: doubleTypeInference.cmi -cic2acic.cmo: eta_fixing.cmi doubleTypeInference.cmi cic2acic.cmi -cic2acic.cmx: eta_fixing.cmx doubleTypeInference.cmx cic2acic.cmi -cic2Xml.cmo: cic2acic.cmi cic2Xml.cmi -cic2Xml.cmx: cic2acic.cmx cic2Xml.cmi diff --git a/helm/ocaml/cic_acic/Makefile b/helm/ocaml/cic_acic/Makefile deleted file mode 100644 index 2669afb11..000000000 --- a/helm/ocaml/cic_acic/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -PACKAGE = cic_acic -PREDICATES = - -INTERFACE_FILES = \ - eta_fixing.mli \ - doubleTypeInference.mli \ - cic2acic.mli \ - cic2Xml.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/cic_acic/cic2Xml.ml b/helm/ocaml/cic_acic/cic2Xml.ml deleted file mode 100644 index 7e97dea6f..000000000 --- a/helm/ocaml/cic_acic/cic2Xml.ml +++ /dev/null @@ -1,483 +0,0 @@ -(* Copyright (C) 2000-2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -(*CSC codice cut & paste da cicPp e xmlcommand *) - -exception NotImplemented;; - -let dtdname ~ask_dtd_to_the_getter dtd = - if ask_dtd_to_the_getter then - Helm_registry.get "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 ?ids_to_inner_sorts = - let find_sort name id = - match ids_to_inner_sorts with - None -> [] - | Some ids_to_inner_sorts -> - [None,name,Cic2acic.string_of_sort (Hashtbl.find ids_to_inner_sorts id)] - in - let rec aux = - let module C = Cic in - let module X = Xml in - let module U = UriManager in - function - C.ARel (id,idref,n,b) -> - let sort = find_sort "sort" id in - X.xml_empty "REL" - (sort @ - [None,"value",(string_of_int n) ; None,"binder",b ; None,"id",id ; - None,"idref",idref]) - | C.AVar (id,uri,exp_named_subst) -> - let sort = find_sort "sort" id in - aux_subst uri - (X.xml_empty "VAR" - (sort @ [None,"uri",U.string_of_uri uri;None,"id",id])) - exp_named_subst - | C.AMeta (id,n,l) -> - let sort = find_sort "sort" id in - X.xml_nempty "META" - (sort @ [None,"no",(string_of_int n) ; None,"id",id]) - (List.fold_left - (fun i t -> - match t with - Some t' -> - [< i ; X.xml_nempty "substitution" [] (aux t') >] - | None -> - [< i ; X.xml_empty "substitution" [] >] - ) [< >] l) - | C.ASort (id,s) -> - let string_of_sort s = - Cic2acic.string_of_sort (Cic2acic.sort_of_sort s) - in - X.xml_empty "SORT" [None,"value",(string_of_sort s) ; None,"id",id] - | C.AImplicit _ -> raise NotImplemented - | 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 = find_sort "type" last_id in - X.xml_nempty "PROD" sort - [< List.fold_left - (fun i (id,binder,s) -> - let sort = find_sort "type" (Cic2acic.source_id_of_id id) in - let attrs = - sort @ ((None,"id",id):: - match binder with - C.Anonymous -> [] - | C.Name b -> [None,"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 = find_sort "sort" id in - X.xml_nempty "CAST" (sort @ [None,"id",id]) - [< X.xml_nempty "term" [] (aux v) ; - X.xml_nempty "type" [] (aux 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 = find_sort "sort" last_id in - X.xml_nempty "LAMBDA" sort - [< List.fold_left - (fun i (id,binder,s) -> - let sort = find_sort "type" (Cic2acic.source_id_of_id id) in - let attrs = - sort @ ((None,"id",id):: - match binder with - C.Anonymous -> [] - | C.Name b -> [None,"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 (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 = find_sort "sort" last_id in - X.xml_nempty "LETIN" sort - [< List.fold_left - (fun i (id,binder,s) -> - let sort = find_sort "sort" id in - let attrs = - sort @ ((None,"id",id):: - match binder with - C.Anonymous -> [] - | C.Name b -> [None,"binder",b]) - in - [< i ; X.xml_nempty "def" attrs (aux s) >] - ) [< >] letins ; - X.xml_nempty "target" [] (aux t) - >] - | C.AAppl (id,li) -> - let sort = find_sort "sort" id in - X.xml_nempty "APPLY" (sort @ [None,"id",id]) - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]) - >] - | C.AConst (id,uri,exp_named_subst) -> - let sort = find_sort "sort" id in - aux_subst uri - (X.xml_empty "CONST" - (sort @ [None,"uri",(U.string_of_uri uri) ; None,"id",id]) - ) exp_named_subst - | C.AMutInd (id,uri,i,exp_named_subst) -> - aux_subst uri - (X.xml_empty "MUTIND" - [None, "uri", (U.string_of_uri uri) ; - None, "noType", (string_of_int i) ; - None, "id", id] - ) exp_named_subst - | C.AMutConstruct (id,uri,i,j,exp_named_subst) -> - let sort = find_sort "sort" id in - aux_subst uri - (X.xml_empty "MUTCONSTRUCT" - (sort @ - [None,"uri", (U.string_of_uri uri) ; - None,"noType",(string_of_int i) ; - None,"noConstr",(string_of_int j) ; - None,"id",id]) - ) exp_named_subst - | C.AMutCase (id,uri,typeno,ty,te,patterns) -> - let sort = find_sort "sort" id in - X.xml_nempty "MUTCASE" - (sort @ - [None,"uriType",(U.string_of_uri uri) ; - None,"noType", (string_of_int typeno) ; - None,"id", id]) - [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; - X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; - List.fold_right - (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>]) - patterns [<>] - >] - | C.AFix (id, no, funs) -> - let sort = find_sort "sort" id in - X.xml_nempty "FIX" - (sort @ [None,"noFun", (string_of_int no) ; None,"id",id]) - [< List.fold_right - (fun (id,fi,ai,ti,bi) i -> - [< X.xml_nempty "FixFunction" - [None,"id",id ; None,"name", fi ; - None,"recIndex", (string_of_int ai)] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] ; - i - >] - ) funs [<>] - >] - | C.ACoFix (id,no,funs) -> - let sort = find_sort "sort" id in - X.xml_nempty "COFIX" - (sort @ [None,"noFun", (string_of_int no) ; None,"id",id]) - [< List.fold_right - (fun (id,fi,ti,bi) i -> - [< X.xml_nempty "CofixFunction" [None,"id",id ; None,"name", fi] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] ; - i - >] - ) funs [<>] - >] - 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 -> [None,"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" [None,"relUri", relUri] (aux arg) >] - ) [<>] subst - >] - in - aux -;; - -let xml_of_attrs attributes = - let class_of = function - | `Coercion -> Xml.xml_empty "class" [None,"value","coercion"] - | `Elim s -> - Xml.xml_nempty "class" [None,"value","elim"] - [< Xml.xml_empty - "SORT" [None,"value", - (Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)) ; - None,"id","elimination_sort"] >] - | `Record field_names -> - Xml.xml_nempty "class" [None,"value","record"] - (List.fold_right - (fun (name,coercion) res -> - [< Xml.xml_empty "field" - [None,"name",if coercion then name ^ " coercion" else name]; - res >] - ) field_names [<>]) - | `Projection -> Xml.xml_empty "class" [None,"value","projection"] - in - let flavour_of = function - | `Definition -> Xml.xml_empty "flavour" [None, "value", "definition"] - | `Fact -> Xml.xml_empty "flavour" [None, "value", "fact"] - | `Lemma -> Xml.xml_empty "flavour" [None, "value", "lemma"] - | `Remark -> Xml.xml_empty "flavour" [None, "value", "remark"] - | `Theorem -> Xml.xml_empty "flavour" [None, "value", "theorem"] - | `Variant -> Xml.xml_empty "flavour" [None, "value", "variant"] - in - let xml_attr_of = function - | `Generated -> Xml.xml_empty "generated" [] - | `Class c -> class_of c - | `Flavour f -> flavour_of f - in - let xml_attrs = - List.fold_right - (fun attr res -> [< xml_attr_of attr ; res >]) attributes [<>] - in - Xml.xml_nempty "attributes" [] xml_attrs - -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,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs obj_attrs 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" - [None,"of",UriManager.string_of_uri uri ; None,"id", id] - [< xml_attrs; - List.fold_left - (fun i (cid,n,canonical_context,t) -> - [< i ; - X.xml_nempty "Conjecture" - [None,"id",cid ; None,"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' -> - [None,"id",hid;None,"name",n'] - | C.Anonymous -> [None,"id",hid]) - (print_term ?ids_to_inner_sorts t) - | Some (n,C.ADef t) -> - X.xml_nempty "Def" - (match n with - C.Name n' -> - [None,"id",hid;None,"name",n'] - | C.Anonymous -> [None,"id",hid]) - (print_term ?ids_to_inner_sorts t) - | None -> X.xml_empty "Hidden" [None,"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" - [None,"name",n ; None,"params",params' ; None,"id", id] - (print_term ?ids_to_inner_sorts ty) - in - let xmlbo = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - xml_for_current_proof_body - >] in - let xmlty = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - xml_for_current_proof_type - >] - in - xmlty, Some xmlbo - | C.AConstant (id,idbody,n,bo,ty,params,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs obj_attrs in - let xmlbo = - match bo with - None -> None - | Some bo -> - Some - [< X.xml_cdata - "\n" ; - X.xml_cdata - ("\n") ; - X.xml_nempty "ConstantBody" - [None,"for",UriManager.string_of_uri uri ; - None,"params",params' ; None,"id", id] - [< print_term ?ids_to_inner_sorts bo >] - >] - in - let xmlty = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - X.xml_nempty "ConstantType" - [None,"name",n ; None,"params",params' ; None,"id", id] - [< xml_attrs; print_term ?ids_to_inner_sorts ty >] - >] - in - xmlty, xmlbo - | C.AVariable (id,n,bo,ty,params,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs obj_attrs 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 "\n" ; - X.xml_cdata ("\n"); - X.xml_nempty "Variable" - [None,"name",n ; None,"params",params' ; None,"id", id] - [< xml_attrs; xmlbo; - X.xml_nempty "type" [] (print_term ?ids_to_inner_sorts ty) - >] - >] - in - aobj, None - | C.AInductiveDefinition (id,tys,params,nparams,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs obj_attrs in - [< X.xml_cdata "\n" ; - X.xml_cdata - ("\n") ; - X.xml_nempty "InductiveDefinition" - [None,"noParams",string_of_int nparams ; - None,"id",id ; - None,"params",params'] - [< xml_attrs; - (List.fold_left - (fun i (id,typename,finite,arity,cons) -> - [< i ; - X.xml_nempty "InductiveType" - [None,"id",id ; None,"name",typename ; - None,"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" - [None,"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 - ~ask_dtd_to_the_getter -= - let module C2A = Cic2acic in - let module X = Xml in - let dtdname = dtdname ~ask_dtd_to_the_getter "cictypes.dtd" in - [< X.xml_cdata "\n" ; - X.xml_cdata - ("\n") ; - X.xml_nempty "InnerTypes" [None,"of",UriManager.string_of_uri curi] - (Hashtbl.fold - (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> - [< x ; - X.xml_nempty "TYPE" [None,"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 [<>] - ) - >] -;; diff --git a/helm/ocaml/cic_acic/cic2Xml.mli b/helm/ocaml/cic_acic/cic2Xml.mli deleted file mode 100644 index 22c5669df..000000000 --- a/helm/ocaml/cic_acic/cic2Xml.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* 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 NotImplemented - -val print_term : - ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t -> - Cic.annterm -> - Xml.token Stream.t - -val print_object : - UriManager.uri -> - ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.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, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types: (string, Cic2acic.anntypes) Hashtbl.t -> - ask_dtd_to_the_getter:bool -> - Xml.token Stream.t - diff --git a/helm/ocaml/cic_acic/cic2acic.ml b/helm/ocaml/cic_acic/cic2acic.ml deleted file mode 100644 index 8540e0e64..000000000 --- a/helm/ocaml/cic_acic/cic2acic.ml +++ /dev/null @@ -1,739 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ] - -let string_of_sort = function - | `Prop -> "Prop" - | `Set -> "Set" - | `Type u -> "Type:" ^ string_of_int (CicUniv.univno u) - | `CProp -> "CProp" - -let sort_of_sort = function - | Cic.Prop -> `Prop - | Cic.Set -> `Set - | Cic.Type u -> `Type u - | Cic.CProp -> `CProp - -(* let hashtbl_add_time = ref 0.0;; *) - -let xxx_add h k v = -(* let t1 = Sys.time () in *) - Hashtbl.add h k v ; -(* let t2 = Sys.time () in - hashtbl_add_time := !hashtbl_add_time +. t2 -. t1 *) -;; - -(* let number_new_type_of_aux' = ref 0;; -let type_of_aux'_add_time = ref 0.0;; *) - -let xxx_type_of_aux' m c t = -(* let t1 = Sys.time () in *) - let res,_ = - try - CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph - with - | CicTypeChecker.AssertFailure _ - | CicTypeChecker.TypeCheckerFailure _ -> - Cic.Sort Cic.Prop, CicUniv.empty_ugraph - in -(* let t2 = Sys.time () in - type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ; *) - res -;; - -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 = gen_id seed in - xxx_add ids_to_father_ids res father ; - xxx_add ids_to_terms res t ; - res -;; - -let source_id_of_id id = "#source#" ^ id;; - -exception NotEnoughElements;; - -(*CSC: cut&paste da cicPp.ml *) -(* get_nth l n returns the nth element of the list l if it exists or *) -(* raises NotEnoughElements if l has less than n elements *) -let rec get_nth l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth tail (n-1) - | (_,_) -> raise NotEnoughElements -;; - -let acic_of_cic_context' ~computeinnertypes:global_computeinnertypes - seed ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - metasenv context idrefs t expectedty -= - let module D = DoubleTypeInference in - let module C = Cic in - let fresh_id' = fresh_id seed ids_to_terms ids_to_father_ids in -(* let time1 = Sys.time () in *) - let terms_to_types = -(* - let time0 = Sys.time () in - let prova = CicTypeChecker.type_of_aux' metasenv context t in - let time1 = Sys.time () in - prerr_endline ("*** Fine type_inference:" ^ (string_of_float (time1 -. time0))); - let res = D.double_type_of metasenv context t expectedty in - let time2 = Sys.time () in - prerr_endline ("*** Fine double_type_inference:" ^ (string_of_float (time2 -. time1))); - res -*) - if global_computeinnertypes then - D.double_type_of metasenv context t expectedty - else - Cic.CicHash.create 1 (* empty table *) - in -(* - let time2 = Sys.time () in - prerr_endline - ("++++++++++++ Tempi della double_type_of: "^ string_of_float (time2 -. time1)) ; -*) - 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 - (* First of all we compute the inner type and the inner sort *) - (* of the term. They may be useful in what follows. *) - (*CSC: This is a very inefficient way of computing inner types *) - (*CSC: and inner sorts: very deep terms have their types/sorts *) - (*CSC: computed again and again. *) - let sort_of t = - match CicReduction.whd context t with - C.Sort C.Prop -> `Prop - | C.Sort C.Set -> `Set - | C.Sort (C.Type u) -> `Type u - | C.Meta _ -> `Type (CicUniv.fresh()) - | C.Sort C.CProp -> `CProp - | t -> - prerr_endline ("Cic2acic.sort_of applied to: " ^ CicPp.ppterm t) ; - assert false - in - let ainnertypes,innertype,innersort,expected_available = -(*CSC: Here we need the algorithm for Coscoy's double type-inference *) -(*CSC: (expected type + inferred type). Just for now we use the usual *) -(*CSC: type-inference, but the result is very poor. As a very weak *) -(*CSC: patch, I apply whd to the computed type. Full beta *) -(*CSC: reduction would be a much better option. *) -(*CSC: solo per testare i tempi *) -(*XXXXXXX *) - try -(* *) - let {D.synthesized = synthesized; D.expected = expected} = - if computeinnertypes then - Cic.CicHash.find terms_to_types tt - else - (* We are already in an inner-type and Coscoy's double *) - (* type inference algorithm has not been applied. *) - { D.synthesized = -(***CSC: patch per provare i tempi - CicReduction.whd context (xxx_type_of_aux' metasenv context tt) ; *) - if global_computeinnertypes then - Cic.Sort (Cic.Type (CicUniv.fresh())) - else - CicReduction.whd context (xxx_type_of_aux' metasenv context tt); - D.expected = None} - in -(* incr number_new_type_of_aux' ; *) - let innersort = (*XXXXX *) xxx_type_of_aux' metasenv context synthesized (* Cic.Sort Cic.Prop *) in - let ainnertypes,expected_available = - if computeinnertypes then - let annexpected,expected_available = - match expected with - None -> None,false - | Some expectedty' -> - Some - (aux false (Some fresh_id'') context idrefs expectedty'), - true - in - Some - {annsynthesized = - aux false (Some fresh_id'') context idrefs synthesized ; - annexpected = annexpected - }, expected_available - else - None,false - in - ainnertypes,synthesized, sort_of innersort, expected_available -(*XXXXXXXX *) - with - Not_found -> (* l'inner-type non e' nella tabella ==> sort <> Prop *) - (* CSC: Type or Set? I can not tell *) - let u = CicUniv.fresh() in - None,Cic.Sort (Cic.Type u),`Type u,false - (* TASSI non dovrebbe fare danni *) -(* *) - in - let add_inner_type id = - match ainnertypes with - None -> () - | Some ainnertypes -> xxx_add ids_to_inner_types id ainnertypes - in - match tt with - C.Rel n -> - let id = - match get_nth context n with - (Some (C.Name s,_)) -> s - | _ -> "__" ^ string_of_int n - in - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - C.ARel (fresh_id'', List.nth idrefs (n-1), n, id) - | C.Var (uri,exp_named_subst) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - 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,_) = CicUtil.lookup_meta n metasenv in - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - C.AMeta (fresh_id'', n, - (List.map2 - (fun ct t -> - match (ct, t) with - | None, _ -> None - | _, 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) - | C.Implicit annotation -> C.AImplicit (fresh_id'', annotation) - | C.Cast (v,t) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.ACast (fresh_id'', aux' context idrefs v, aux' context idrefs t) - | C.Prod (n,s,t) -> - xxx_add ids_to_inner_sorts fresh_id'' - (sort_of innertype) ; - let sourcetype = xxx_type_of_aux' metasenv context s in - xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'') - (sort_of sourcetype) ; - let n' = - match n with - C.Anonymous -> n - | C.Name n' -> - if DoubleTypeInference.does_not_occur 1 t then - C.Anonymous - else - C.Name n' - in - 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) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - let sourcetype = xxx_type_of_aux' metasenv context s in - xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'') - (sort_of 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) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.ALetIn - (fresh_id'', n, aux' context idrefs s, - aux' ((Some (n, C.Def(s,None)))::context) (fresh_id''::idrefs) t) - | C.Appl l -> - xxx_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 idrefs) l) - | C.Const (uri,exp_named_subst) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - 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) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - 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) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - 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 - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.AFix (fresh_id'', funno, - 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 - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.ACoFix (fresh_id'', funno, - List.map2 - (fun id (name, ty, bo) -> - (id, name, aux' context idrefs ty, - aux' (tys@context) new_idrefs bo) - ) fresh_idrefs funs - ) - in -(* - let timea = Sys.time () in - let res = aux true None context idrefs t in - let timeb = Sys.time () in - prerr_endline - ("+++++++++++++ Tempi della aux dentro alla acic_of_cic: "^ string_of_float (timeb -. timea)) ; - res -*) - aux global_computeinnertypes None context idrefs t -;; - -let acic_of_cic_context ~computeinnertypes 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' ~computeinnertypes seed ids_to_terms ids_to_father_ids ids_to_inner_sorts - ids_to_inner_types metasenv context idrefs t, - ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types -;; - -let aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed - metasenv (metano,context,goal) -= - let computeinnertypes = false in - let acic_of_cic_context = - acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts - ids_to_inner_types metasenv in - let _, acontext,final_idrefs = - (List.fold_right - (fun binding (context, acontext,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,_)) -> - let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in - Hashtbl.replace ids_to_father_ids (CicUtil.id_of_annterm acic) - (Some hid); - (binding::context), - ((hid,Some (n,Cic.ADef acic))::acontext),(hid::idrefs) - | Some (n,Cic.Decl t) -> - let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in - Hashtbl.replace ids_to_father_ids (CicUtil.id_of_annterm acic) - (Some hid); - (binding::context), - ((hid,Some (n,Cic.ADecl acic))::acontext),(hid::idrefs) - | None -> - (* Invariant: "" is never looked up *) - (None::context),((hid,None)::acontext),""::idrefs - ) context ([],[],[]) - ) - in - let agoal = acic_of_cic_context ~computeinnertypes context final_idrefs goal None in - (metano,acontext,agoal) -;; - -let asequent_of_sequent (metasenv:Cic.metasenv) (sequent:Cic.conjecture) = - 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 ids_to_hypotheses = Hashtbl.create 23 in - let hypotheses_seed = ref 0 in - let seed = ref 1 in (* 'i0' is used for the whole sequent *) - let unsh_sequent = - let i,canonical_context,term = sequent in - let canonical_context' = - List.fold_right - (fun d canonical_context' -> - let d = - match d with - None -> None - | Some (n, Cic.Decl t)-> - Some (n, Cic.Decl (Unshare.unshare t)) - | Some (n, Cic.Def (t,None)) -> - Some (n, Cic.Def ((Unshare.unshare t),None)) - | Some (n,Cic.Def (bo,Some ty)) -> - Some (n, Cic.Def (Unshare.unshare bo,Some (Unshare.unshare ty))) - in - d::canonical_context' - ) canonical_context [] - in - let term' = Unshare.unshare term in - (i,canonical_context',term') - in - let (metano,acontext,agoal) = - aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed - metasenv unsh_sequent in - (unsh_sequent, - (("i0",metano,acontext,agoal), - ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses)) -;; - -let acic_object_of_cic_object ?(eta_fix=true) obj = - let module C = Cic in - let module E = Eta_fixing in - 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 ids_to_conjectures = Hashtbl.create 11 in - let ids_to_hypotheses = Hashtbl.create 127 in - let hypotheses_seed = ref 0 in - let conjectures_seed = ref 0 in - let seed = ref 0 in - 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 aconjecture_of_conjecture' = aconjecture_of_conjecture seed - ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - ids_to_hypotheses hypotheses_seed in - let eta_fix metasenv context t = - let t = if eta_fix then E.eta_fix metasenv context t else t in - Unshare.unshare t in - let aobj = - match obj with - C.Constant (id,Some bo,ty,params,attrs) -> - let bo' = eta_fix [] [] bo in - let ty' = eta_fix [] [] ty in - let abo = acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty') in - let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in - C.AConstant - ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs) - | C.Constant (id,None,ty,params,attrs) -> - let ty' = eta_fix [] [] ty in - let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in - C.AConstant - ("mettereaposto",None,id,None,aty,params,attrs) - | C.Variable (id,bo,ty,params,attrs) -> - let ty' = eta_fix [] [] ty in - let abo = - match bo with - None -> None - | Some bo -> - let bo' = eta_fix [] [] bo in - Some (acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty')) - in - let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in - C.AVariable - ("mettereaposto",id,abo,aty,params,attrs) - | C.CurrentProof (id,conjectures,bo,ty,params,attrs) -> - let conjectures' = - List.map - (function (i,canonical_context,term) -> - let canonical_context' = - List.fold_right - (fun d canonical_context' -> - let d = - match d with - None -> None - | Some (n, C.Decl t)-> - Some (n, C.Decl (eta_fix conjectures canonical_context' t)) - | Some (n, C.Def (t,None)) -> - Some (n, - C.Def ((eta_fix conjectures canonical_context' t),None)) - | Some (_,C.Def (_,Some _)) -> assert false - in - d::canonical_context' - ) canonical_context [] - in - let term' = eta_fix conjectures canonical_context' term in - (i,canonical_context',term') - ) conjectures - in - let aconjectures = - List.map - (function (i,canonical_context,term) as conjecture -> - let cid = "c" ^ string_of_int !conjectures_seed in - xxx_add ids_to_conjectures cid conjecture ; - incr conjectures_seed ; - let (i,acanonical_context,aterm) - = aconjecture_of_conjecture' conjectures conjecture in - (cid,i,acanonical_context,aterm)) - conjectures' in -(* let time1 = Sys.time () in *) - let bo' = eta_fix conjectures' [] bo in - let ty' = eta_fix conjectures' [] ty in -(* - let time2 = Sys.time () in - prerr_endline - ("++++++++++ Tempi della eta_fix: "^ string_of_float (time2 -. time1)) ; - hashtbl_add_time := 0.0 ; - type_of_aux'_add_time := 0.0 ; - DoubleTypeInference.syntactic_equality_add_time := 0.0 ; -*) - let abo = - acic_term_of_cic_term_context' ~computeinnertypes:true conjectures' [] [] bo' (Some ty') in - let aty = acic_term_of_cic_term_context' ~computeinnertypes:false conjectures' [] [] ty' None in -(* - let time3 = Sys.time () in - prerr_endline - ("++++++++++++ Tempi della hashtbl_add_time: " ^ string_of_float !hashtbl_add_time) ; - prerr_endline - ("++++++++++++ Tempi della type_of_aux'_add_time(" ^ string_of_int !number_new_type_of_aux' ^ "): " ^ string_of_float !type_of_aux'_add_time) ; - prerr_endline - ("++++++++++++ Tempi della type_of_aux'_add_time nella double_type_inference(" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_double_work ^ ";" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_prop ^ "/" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux' ^ "): " ^ string_of_float !DoubleTypeInference.type_of_aux'_add_time) ; - prerr_endline - ("++++++++++++ Tempi della syntactic_equality_add_time: " ^ string_of_float !DoubleTypeInference.syntactic_equality_add_time) ; - prerr_endline - ("++++++++++ Tempi della acic_of_cic: " ^ string_of_float (time3 -. time2)) ; - prerr_endline - ("++++++++++ Numero di iterazioni della acic_of_cic: " ^ string_of_int !seed) ; -*) - C.ACurrentProof - ("mettereaposto","mettereaposto2",id,aconjectures,abo,aty,params,attrs) - | C.InductiveDefinition (tys,params,paramsno,attrs) -> - let tys = - List.map - (fun (name,i,arity,cl) -> - (name,i,Unshare.unshare arity, - List.map (fun (name,ty) -> name,Unshare.unshare ty) cl)) tys in - let context = - List.map - (fun (name,_,arity,_) -> - Some (C.Name name, C.Decl (Unshare.unshare 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' ~computeinnertypes:false [] context idrefs ty None) - ) cons - in - (id,name,inductive, - acic_term_of_cic_term' ~computeinnertypes:false ty None,acons) - ) (List.rev idrefs) tys - in - C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs) - in - aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types, - ids_to_conjectures,ids_to_hypotheses -;; - -let plain_acic_term_of_cic_term = - let module C = Cic in - let mk_fresh_id = - let id = ref 0 in - function () -> incr id; "i" ^ string_of_int !id in - let rec aux context t = - let fresh_id = mk_fresh_id () in - match t with - C.Rel n -> - let idref,id = - match get_nth context n with - idref,(Some (C.Name s,_)) -> idref,s - | idref,_ -> idref,"__" ^ string_of_int n - in - C.ARel (fresh_id, idref, n, id) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context t)) exp_named_subst - in - C.AVar (fresh_id,uri,exp_named_subst') - | C.Implicit _ - | C.Meta _ -> assert false - | C.Sort s -> C.ASort (fresh_id, s) - | C.Cast (v,t) -> - C.ACast (fresh_id, aux context v, aux context t) - | C.Prod (n,s,t) -> - C.AProd - (fresh_id, n, aux context s, - aux ((fresh_id, Some (n, C.Decl s))::context) t) - | C.Lambda (n,s,t) -> - C.ALambda - (fresh_id,n, aux context s, - aux ((fresh_id, Some (n, C.Decl s))::context) t) - | C.LetIn (n,s,t) -> - C.ALetIn - (fresh_id, n, aux context s, - aux ((fresh_id, Some (n, C.Def(s,None)))::context) t) - | C.Appl l -> - C.AAppl (fresh_id, List.map (aux context) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context 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 t)) exp_named_subst - in - C.AMutInd (fresh_id, uri, tyno, exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context t)) exp_named_subst - in - C.AMutConstruct (fresh_id, uri, tyno, consno, exp_named_subst') - | C.MutCase (uri, tyno, outty, term, patterns) -> - C.AMutCase (fresh_id, uri, tyno, aux context outty, - aux context term, List.map (aux context) patterns) - | C.Fix (funno, funs) -> - let tys = - List.map - (fun (name,_,ty,_) -> mk_fresh_id (), Some (C.Name name, C.Decl ty)) funs - in - C.AFix (fresh_id, funno, - List.map2 - (fun (id,_) (name, indidx, ty, bo) -> - (id, name, indidx, aux context ty, aux (tys@context) bo) - ) tys funs - ) - | C.CoFix (funno, funs) -> - let tys = - List.map (fun (name,ty,_) -> - mk_fresh_id (),Some (C.Name name, C.Decl ty)) funs - in - C.ACoFix (fresh_id, funno, - List.map2 - (fun (id,_) (name, ty, bo) -> - (id, name, aux context ty, aux (tys@context) bo) - ) tys funs - ) - in - aux -;; - -let plain_acic_object_of_cic_object obj = - let module C = Cic in - let mk_fresh_id = - let id = ref 0 in - function () -> incr id; "it" ^ string_of_int !id - in - match obj with - C.Constant (id,Some bo,ty,params,attrs) -> - let abo = plain_acic_term_of_cic_term [] bo in - let aty = plain_acic_term_of_cic_term [] ty in - C.AConstant - ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs) - | C.Constant (id,None,ty,params,attrs) -> - let aty = plain_acic_term_of_cic_term [] ty in - C.AConstant - ("mettereaposto",None,id,None,aty,params,attrs) - | C.Variable (id,bo,ty,params,attrs) -> - let abo = - match bo with - None -> None - | Some bo -> Some (plain_acic_term_of_cic_term [] bo) - in - let aty = plain_acic_term_of_cic_term [] ty in - C.AVariable - ("mettereaposto",id,abo,aty,params,attrs) - | C.CurrentProof _ -> assert false - | C.InductiveDefinition (tys,params,paramsno,attrs) -> - let context = - List.map - (fun (name,_,arity,_) -> - mk_fresh_id (), Some (C.Name name, C.Decl arity)) tys in - let atys = - List.map2 - (fun (id,_) (name,inductive,ty,cons) -> - let acons = - List.map - (function (name,ty) -> - (name, - plain_acic_term_of_cic_term context ty) - ) cons - in - (id,name,inductive,plain_acic_term_of_cic_term [] ty,acons) - ) context tys - in - C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs) -;; diff --git a/helm/ocaml/cic_acic/cic2acic.mli b/helm/ocaml/cic_acic/cic2acic.mli deleted file mode 100644 index e6379283d..000000000 --- a/helm/ocaml/cic_acic/cic2acic.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* 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 NotEnoughElements - -val source_id_of_id : string -> string - -type anntypes = - {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option} -;; - -type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ] - -val string_of_sort: sort_kind -> string -(*val sort_of_string: string -> sort_kind*) -val sort_of_sort: Cic.sort -> sort_kind - -val acic_object_of_cic_object : - ?eta_fix: bool -> (* perform eta_fixing; default: true*) - Cic.obj -> (* object *) - Cic.annobj * (* annotated object *) - (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *) - (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *) - (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, anntypes) Hashtbl.t * (* ids_to_inner_types *) - (Cic.id, Cic.conjecture) Hashtbl.t * (* ids_to_conjectures *) - (Cic.id, Cic.hypothesis) Hashtbl.t (* ids_to_hypotheses *) - -val asequent_of_sequent : - Cic.metasenv -> (* metasenv *) - Cic.conjecture -> (* sequent *) - Cic.conjecture * (* unshared sequent *) - (Cic.annconjecture * (* annotated sequent *) - (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *) - (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *) - (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, Cic.hypothesis) Hashtbl.t) (* ids_to_hypotheses *) - -val plain_acic_object_of_cic_object : Cic.obj -> Cic.annobj diff --git a/helm/ocaml/cic_acic/doubleTypeInference.ml b/helm/ocaml/cic_acic/doubleTypeInference.ml deleted file mode 100644 index 30a8f5c29..000000000 --- a/helm/ocaml/cic_acic/doubleTypeInference.ml +++ /dev/null @@ -1,734 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -exception Impossible of int;; -exception NotWellTyped of string;; -exception WrongUriToConstant of string;; -exception WrongUriToVariable of string;; -exception WrongUriToMutualInductiveDefinitions of string;; -exception ListTooShort;; -exception RelToHiddenHypothesis;; - -let syntactic_equality_add_time = ref 0.0;; -let type_of_aux'_add_time = ref 0.0;; -let number_new_type_of_aux'_double_work = ref 0;; -let number_new_type_of_aux' = ref 0;; -let number_new_type_of_aux'_prop = ref 0;; - -let double_work = ref 0;; - -let xxx_type_of_aux' m c t = - let t1 = Sys.time () in - let res,_ = CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph in - let t2 = Sys.time () in - type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ; - res -;; - -type types = {synthesized : Cic.term ; expected : Cic.term option};; - -(* does_not_occur n te *) -(* returns [true] if [Rel n] does not occur in [te] *) -let rec does_not_occur n = - let module C = Cic in - function - C.Rel m when m = n -> false - | C.Rel _ - | C.Meta _ - | C.Sort _ - | C.Implicit _ -> true - | C.Cast (te,ty) -> - does_not_occur n te && does_not_occur n ty - | C.Prod (name,so,dest) -> - does_not_occur n so && - does_not_occur (n + 1) dest - | C.Lambda (name,so,dest) -> - does_not_occur n so && - does_not_occur (n + 1) dest - | C.LetIn (name,so,dest) -> - does_not_occur n so && - does_not_occur (n + 1) dest - | C.Appl l -> - List.fold_right (fun x i -> i && does_not_occur n x) l true - | 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 n x) - exp_named_subst true - | C.MutCase (_,_,out,te,pl) -> - does_not_occur n out && does_not_occur n te && - List.fold_right (fun x i -> i && does_not_occur n x) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur n ty && - does_not_occur n_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur n ty && - does_not_occur n_plus_len bo - ) fl true -;; - -let rec beta_reduce = - let module S = CicSubstitution in - let module C = Cic in - function - C.Rel _ as t -> t - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (i,t) -> i, beta_reduce t) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (n,l) -> - C.Meta (n, - List.map - (function None -> None | Some t -> Some (beta_reduce t)) l - ) - | C.Sort _ as t -> t - | C.Implicit _ -> assert false - | C.Cast (te,ty) -> - C.Cast (beta_reduce te, beta_reduce ty) - | C.Prod (n,s,t) -> - C.Prod (n, beta_reduce s, beta_reduce t) - | C.Lambda (n,s,t) -> - C.Lambda (n, beta_reduce s, beta_reduce t) - | C.LetIn (n,s,t) -> - C.LetIn (n, beta_reduce s, beta_reduce t) - | C.Appl ((C.Lambda (name,s,t))::he::tl) -> - let he' = S.subst he t in - if tl = [] then - beta_reduce he' - else - (match he' with - C.Appl l -> beta_reduce (C.Appl (l@tl)) - | _ -> beta_reduce (C.Appl (he'::tl))) - | C.Appl l -> - C.Appl (List.map beta_reduce l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (i,t) -> i, 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, 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, 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,beta_reduce outt,beta_reduce t, - List.map beta_reduce pl) - | C.Fix (i,fl) -> - let fl' = - List.map - (function (name,i,ty,bo) -> - name,i,beta_reduce ty,beta_reduce bo - ) fl - in - C.Fix (i,fl') - | C.CoFix (i,fl) -> - let fl' = - List.map - (function (name,ty,bo) -> - name,beta_reduce ty,beta_reduce bo - ) fl - in - C.CoFix (i,fl') -;; - -(* syntactic_equality up to the *) -(* distinction between fake dependent products *) -(* and non-dependent products, alfa-conversion *) -(*CSC: must alfa-conversion be considered or not? *) -let syntactic_equality t t' = - let module C = Cic in - let rec syntactic_equality t t' = - if t = t' then true - else - match t, t' with - 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' - | C.Prod (_,s,t), C.Prod (_,s',t') -> - syntactic_equality s s' && - syntactic_equality t t' - | C.Lambda (_,s,t), C.Lambda (_,s',t') -> - syntactic_equality s s' && - syntactic_equality t t' - | C.LetIn (_,s,t), C.LetIn(_,s',t') -> - syntactic_equality s s' && - 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,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' && - List.fold_left2 - (fun b t1 t2 -> b && syntactic_equality t1 t2) true pl pl' - | C.Fix (i,fl), C.Fix (i',fl') -> - i = i' && - List.fold_left2 - (fun b (_,i,ty,bo) (_,i',ty',bo') -> - b && i = i' && - syntactic_equality ty ty' && - syntactic_equality bo bo') true fl fl' - | C.CoFix (i,fl), C.CoFix (i',fl') -> - i = i' && - List.fold_left2 - (fun b (_,ty,bo) (_,ty',bo') -> - b && - syntactic_equality ty ty' && - syntactic_equality bo bo') true fl fl' - | _, _ -> 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' - with - _ -> false -;; - -let xxx_syntactic_equality t t' = - let t1 = Sys.time () in - let res = syntactic_equality t t' in - let t2 = Sys.time () in - syntactic_equality_add_time := !syntactic_equality_add_time +. t2 -. t1 ; - res -;; - - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> raise ListTooShort -;; - -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 CicUniv.empty_ugraph uri with - CicEnvironment.CheckedObj (cobj,_) -> cobj - | CicEnvironment.UncheckedObj uobj -> - raise (NotWellTyped "Reference to an unchecked constant") - in - match cobj with - C.Constant (_,_,ty,_,_) -> ty - | C.CurrentProof (_,_,_,ty,_,_) -> ty - | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) -;; - -let type_of_variable uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - match CicEnvironment.is_type_checked CicUniv.empty_ugraph 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 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 CicUniv.empty_ugraph uri with - CicEnvironment.CheckedObj (cobj,_) -> cobj - | CicEnvironment.UncheckedObj uobj -> - raise (NotWellTyped "Reference to an unchecked inductive type") - in - match cobj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,arity,_) = List.nth dl i in - arity - | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) -;; - -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 CicUniv.empty_ugraph uri with - CicEnvironment.CheckedObj (cobj,_) -> cobj - | CicEnvironment.UncheckedObj uobj -> - raise (NotWellTyped "Reference to an unchecked constructor") - in - match cobj 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 *) -let rec type_of_aux' subterms_to_types metasenv context t expectedty = - (* Coscoy's double type-inference algorithm *) - (* It computes the inner-types of every subterm of [t], *) - (* even when they are not needed to compute the types *) - (* of other terms. *) - let rec type_of_aux context t expectedty = - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module U = UriManager in - let synthesized = - match t with - C.Rel n -> - (try - match List.nth context (n - 1) with - Some (_,C.Decl t) -> S.lift n t - | Some (_,C.Def (_,Some ty)) -> S.lift n ty - | Some (_,C.Def (bo,None)) -> - type_of_aux context (S.lift n bo) expectedty - | None -> raise RelToHiddenHypothesis - with - _ -> raise (NotWellTyped "Not a close term") - ) - | 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,_) = CicUtil.lookup_meta n metasenv in - let lifted_canonical_context = - let rec aux i = - function - [] -> [] - | (Some (n,C.Decl t))::tl -> - (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl) - | (Some (n,C.Def (t,None)))::tl -> - (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None))):: - (aux (i+1) tl) - | None::tl -> None::(aux (i+1) tl) - | (Some (_,C.Def (_,Some _)))::_ -> assert false - in - aux 1 canonical_context - in - let _ = - List.iter2 - (fun t ct -> - match t,ct with - _,None -> () - | Some t,Some (_,C.Def (ct,_)) -> - let expected_type = - R.whd context - (xxx_type_of_aux' metasenv context ct) - in - (* Maybe I am a bit too paranoid, because *) - (* if the term is well-typed than t and ct *) - (* are convertible. Nevertheless, I compute *) - (* the expected type. *) - ignore (type_of_aux context t (Some expected_type)) - | Some t,Some (_,C.Decl ct) -> - ignore (type_of_aux context t (Some ct)) - | _,_ -> assert false (* the term is not well typed!!! *) - ) l lifted_canonical_context - in - let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in - (* Checks suppressed *) - CicSubstitution.subst_meta l ty - | C.Sort (C.Type t) -> (* TASSI: CONSTRAINT *) - C.Sort (C.Type (CicUniv.fresh())) - | C.Sort _ -> C.Sort (C.Type (CicUniv.fresh())) (* TASSI: CONSTRAINT *) - | C.Implicit _ -> raise (Impossible 21) - | C.Cast (te,ty) -> - (* Let's visit all the subterms that will not be visited later *) - let _ = type_of_aux context te (Some (beta_reduce ty)) in - let _ = type_of_aux context ty None in - (* Checks suppressed *) - ty - | C.Prod (name,s,t) -> - let sort1 = type_of_aux context s None - and sort2 = type_of_aux ((Some (name,(C.Decl s)))::context) t None in - sort_of_prod context (name,s) (sort1,sort2) - | C.Lambda (n,s,t) -> - (* Let's visit all the subterms that will not be visited later *) - let _ = type_of_aux context s None in - let expected_target_type = - match expectedty with - None -> None - | Some expectedty' -> - let ty = - match R.whd context expectedty' with - C.Prod (_,_,expected_target_type) -> - beta_reduce expected_target_type - | _ -> assert false - in - Some ty - in - let type2 = - type_of_aux ((Some (n,(C.Decl s)))::context) t expected_target_type - in - (* Checks suppressed *) - C.Prod (n,s,type2) - | C.LetIn (n,s,t) -> -(*CSC: What are the right expected types for the source and *) -(*CSC: target of a LetIn? None used. *) - (* Let's visit all the subterms that will not be visited later *) - let ty = type_of_aux context s None in - let t_typ = - (* Checks suppressed *) - type_of_aux ((Some (n,(C.Def (s,Some ty))))::context) t None - in (* CicSubstitution.subst s t_typ *) - if does_not_occur 1 t_typ then - (* since [Rel 1] does not occur in typ, substituting any term *) - (* in place of [Rel 1] is equivalent to delifting once *) - CicSubstitution.subst (C.Implicit None) t_typ - else - C.LetIn (n,s,t_typ) - | C.Appl (he::tl) when List.length tl > 0 -> - (* - let expected_hetype = - (* Inefficient, the head is computed twice. But I know *) - (* of no other solution. *) - (beta_reduce - (R.whd context (xxx_type_of_aux' metasenv context he))) - in - let hetype = type_of_aux context he (Some expected_hetype) in - let tlbody_and_type = - let rec aux = - function - _,[] -> [] - | C.Prod (n,s,t),he::tl -> - (he, type_of_aux context he (Some (beta_reduce s))):: - (aux (R.whd context (S.subst he t), tl)) - | _ -> assert false - in - aux (expected_hetype, tl) *) - let hetype = R.whd context (type_of_aux context he None) in - let tlbody_and_type = - let rec aux = - function - _,[] -> [] - | C.Prod (n,s,t),he::tl -> - (he, type_of_aux context he (Some (beta_reduce s))):: - (aux (R.whd context (S.subst he t), tl)) - | _ -> assert false - in - aux (hetype, tl) - in - eat_prods context hetype tlbody_and_type - | C.Appl _ -> raise (NotWellTyped "Appl: no arguments") - | 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 = - match CicReduction.whd context t with - C.Sort _ -> (true, 0) - | C.Prod (name, s, t) -> - let (b, n) = guess_args ((Some (name,(C.Decl s)))::context) t in - if n = 0 then - (* last prod before sort *) - match CicReduction.whd context s with - C.MutInd (uri',i',_) when U.eq uri' uri && i' = i -> - (false, 1) - | 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") - in - let (b, k) = guess_args context outsort in - if not b then (b, k - 1) else (b, k) - in - let (parameters, arguments,exp_named_subst) = - let type_of_term = - xxx_type_of_aux' metasenv context term - in - match - R.whd context (type_of_aux context term - (Some (beta_reduce type_of_term))) - with - (*CSC manca il caso dei CAST *) - C.MutInd (uri',i',exp_named_subst) -> - (* Checks suppressed *) - [],[],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) = - let obj,_ = - try - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (tl,_,parsno,_) -> - let (_,_,_,cl) = List.nth tl i in (cl,parsno) - | _ -> - raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - in - let _ = - List.fold_left - (fun j (p,(_,c)) -> - let cons = - if parameters = [] then - (C.MutConstruct (uri,i,j,exp_named_subst)) - else - (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters)) - in - let expectedtype = - type_of_branch context parsno need_dummy outtype cons - (xxx_type_of_aux' metasenv context cons) - in - ignore (type_of_aux context p - (Some (beta_reduce expectedtype))) ; - j+1 - ) 1 (List.combine pl cl) - in - if not need_dummy then - C.Appl ((outtype::arguments)@[term]) - else if arguments = [] then - outtype - else - C.Appl (outtype::arguments) - | C.Fix (i,fl) -> - (* Let's visit all the subterms that will not be visited later *) - let context' = - List.rev - (List.map - (fun (n,_,ty,_) -> - let _ = type_of_aux context ty None in - (Some (C.Name n,(C.Decl ty))) - ) fl - ) @ - context - in - let _ = - List.iter - (fun (_,_,ty,bo) -> - let expectedty = - beta_reduce (CicSubstitution.lift (List.length fl) ty) - in - ignore (type_of_aux context' bo (Some expectedty)) - ) fl - in - (* Checks suppressed *) - let (_,_,ty,_) = List.nth fl i in - ty - | C.CoFix (i,fl) -> - (* Let's visit all the subterms that will not be visited later *) - let context' = - List.rev - (List.map - (fun (n,ty,_) -> - let _ = type_of_aux context ty None in - (Some (C.Name n,(C.Decl ty))) - ) fl - ) @ - context - in - let _ = - List.iter - (fun (_,ty,bo) -> - let expectedty = - beta_reduce (CicSubstitution.lift (List.length fl) ty) - in - ignore (type_of_aux context' bo (Some expectedty)) - ) fl - in - (* Checks suppressed *) - let (_,ty,_) = List.nth fl i in - ty - in - let synthesized' = beta_reduce synthesized in - let types,res = - match expectedty with - None -> - (* No expected type *) - {synthesized = synthesized' ; expected = None}, synthesized - | Some ty when xxx_syntactic_equality synthesized' ty -> - (* The expected type is synthactically equal to *) - (* the synthesized type. Let's forget it. *) - {synthesized = synthesized' ; expected = None}, synthesized - | Some expectedty' -> - {synthesized = synthesized' ; expected = Some expectedty'}, - expectedty' - in - assert (not (Cic.CicHash.mem subterms_to_types t)); - Cic.CicHash.add subterms_to_types t types ; - res - - and visit_exp_named_subst context uri exp_named_subst = - let uris_and_types = - let obj,_ = - try - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - with Not_found -> assert false - in - let params = CicUtil.params_of_obj obj in - List.map - (function uri -> - let obj,_ = - try - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - with Not_found -> assert false - in - match obj 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 - let t2' = CicReduction.whd ((Some (name,C.Decl s))::context) t2 in - match (t1', t2') with - (C.Sort _, C.Sort s2) - when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) -> - (* different from Coq manual!!! *) - C.Sort s2 - | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> - C.Sort (C.Type (CicUniv.fresh())) - | (C.Sort _,C.Sort (C.Type t1)) -> - (* TASSI: CONSRTAINTS: the same in cictypechecker,cicrefine *) - C.Sort (C.Type t1) (* c'e' bisogno di un fresh? *) - | (C.Meta _, C.Sort _) -> t2' - | (C.Meta _, (C.Meta (_,_) as t)) - | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t -> - t2' - | (_,_) -> - raise - (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 *) - (*CSC: cucinati *) - function - [] -> hetype - | (hete, hety)::tl -> - (match (CicReduction.whd context hetype) with - Cic.Prod (n,s,t) -> - (* Checks suppressed *) - eat_prods context (CicSubstitution.subst hete t) tl - | _ -> raise (NotWellTyped "Appl: wrong Prod-type") - ) - -and type_of_branch context argsno need_dummy outtype term constype = - let module C = Cic in - let module R = CicReduction in - match R.whd context constype with - C.MutInd (_,_,_) -> - if need_dummy then - outtype - else - C.Appl [outtype ; term] - | C.Appl (C.MutInd (_,_,_)::tl) -> - let (_,arguments) = split tl argsno - in - if need_dummy && arguments = [] then - outtype - else - C.Appl (outtype::arguments@(if need_dummy then [] else [term])) - | C.Prod (name,so,de) -> - let term' = - match CicSubstitution.lift 1 term with - C.Appl l -> C.Appl (l@[C.Rel 1]) - | t -> C.Appl [t ; C.Rel 1] - in - 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) - - in - type_of_aux context t expectedty -;; - -let double_type_of metasenv context t expectedty = - let subterms_to_types = Cic.CicHash.create 503 in - ignore (type_of_aux' subterms_to_types metasenv context t expectedty) ; - subterms_to_types -;; diff --git a/helm/ocaml/cic_acic/doubleTypeInference.mli b/helm/ocaml/cic_acic/doubleTypeInference.mli deleted file mode 100644 index 892e09f8a..000000000 --- a/helm/ocaml/cic_acic/doubleTypeInference.mli +++ /dev/null @@ -1,25 +0,0 @@ -exception Impossible of int -exception NotWellTyped of string -exception WrongUriToConstant of string -exception WrongUriToVariable of string -exception WrongUriToMutualInductiveDefinitions of string -exception ListTooShort -exception RelToHiddenHypothesis - -val syntactic_equality_add_time: float ref -val type_of_aux'_add_time: float ref -val number_new_type_of_aux'_double_work: int ref -val number_new_type_of_aux': int ref -val number_new_type_of_aux'_prop: int ref - -type types = {synthesized : Cic.term ; expected : Cic.term option};; - -val double_type_of : - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term option -> - types Cic.CicHash.t - -(** Auxiliary functions **) - -(* does_not_occur n te *) -(* returns [true] if [Rel n] does not occur in [te] *) -val does_not_occur : int -> Cic.term -> bool diff --git a/helm/ocaml/cic_acic/eta_fixing.ml b/helm/ocaml/cic_acic/eta_fixing.ml deleted file mode 100644 index 22d26e1bd..000000000 --- a/helm/ocaml/cic_acic/eta_fixing.ml +++ /dev/null @@ -1,313 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -exception ReferenceToNonVariable;; - -let prerr_endline _ = ();; - -(* -let rec fix_lambdas_wrt_type ty te = - let module C = Cic in - let module S = CicSubstitution in -(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - match ty with - C.Prod (_,_,ty') -> - (match CicReduction.whd [] te with - C.Lambda (n,s,te') -> - C.Lambda (n,s,fix_lambdas_wrt_type ty' te') - | t -> - let rec get_sources = - function - C.Prod (_,s,ty) -> s::(get_sources ty) - | _ -> [] in - let sources = get_sources ty in - let no_sources = List.length sources in - let rec mk_rels n shift = - if n = 0 then [] - else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in - let t' = S.lift no_sources t in - let t2 = - match t' with - C.Appl l -> - C.LetIn - (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1))) - | _ -> - C.Appl (t'::(mk_rels no_sources 0)) in - List.fold_right - (fun source t -> C.Lambda (C.Name "y",source,t)) - sources t2) - | _ -> te -;; *) - -let rec fix_lambdas_wrt_type ty te = - let module C = Cic in - let module S = CicSubstitution in -(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - match ty,te with - C.Prod (_,_,ty'), C.Lambda (n,s,te') -> - C.Lambda (n,s,fix_lambdas_wrt_type ty' te') - | C.Prod (_,s,ty'), t -> - let rec get_sources = - function - C.Prod (_,s,ty) -> s::(get_sources ty) - | _ -> [] in - let sources = get_sources ty in - let no_sources = List.length sources in - let rec mk_rels n shift = - if n = 0 then [] - else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in - let t' = S.lift no_sources t in - let t2 = - match t' with - C.Appl l -> - C.LetIn (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1))) - | _ -> C.Appl (t'::(mk_rels no_sources 0)) in - List.fold_right - (fun source t -> C.Lambda (C.Name "y",CicReduction.whd [] source,t)) sources t2 - | _, _ -> te -;; - -(* -let rec fix_lambdas_wrt_type ty te = - let module C = Cic in - let module S = CicSubstitution in -(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - match ty,te with - C.Prod (_,_,ty'), C.Lambda (n,s,te') -> - C.Lambda (n,s,fix_lambdas_wrt_type ty' te') - | C.Prod (_,s,ty'), ((C.Appl (C.Const _ ::_)) as t) -> - (* const have a fixed arity *) - (* prerr_endline ("******** fl - eta expansion 0: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - let t' = S.lift 1 t in - C.Lambda (C.Name "x",s, - C.LetIn - (C.Name "H", fix_lambdas_wrt_type ty' t', - C.Appl [C.Rel 1;C.Rel 2])) - | C.Prod (_,s,ty'), C.Appl l -> - (* prerr_endline ("******** fl - eta expansion 1: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - let l' = List.map (S.lift 1) l in - C.Lambda (C.Name "x",s, - fix_lambdas_wrt_type ty' (C.Appl (l'@[C.Rel 1]))) - | C.Prod (_,s,ty'), _ -> - (* prerr_endline ("******** fl - eta expansion 2: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - flush stderr ; - let te' = S.lift 1 te in - C.Lambda (C.Name "x",s, - fix_lambdas_wrt_type ty' (C.Appl [te';C.Rel 1])) - | _, _ -> te -;;*) - -let fix_according_to_type ty hd tl = - let module C = Cic in - let module S = CicSubstitution in - let rec count_prods = - function - C.Prod (_,_,t) -> 1 + (count_prods t) - | _ -> 0 in - let expected_arity = count_prods ty in - let rec aux n ty tl res = - if n = 0 then - (match tl with - [] -> - (match res with - [] -> assert false - | [res] -> res - | _ -> C.Appl res) - | _ -> - match res with - [] -> assert false - | [a] -> C.Appl (a::tl) - | _ -> - (* prerr_endline ("******* too many args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *) - C.LetIn - (C.Name "H", - C.Appl res, C.Appl (C.Rel 1::(List.map (S.lift 1) tl)))) - else - let name,source,target = - (match ty with - C.Prod (C.Name _ as n,s,t) -> n,s,t - | C.Prod (C.Anonymous, s,t) -> C.Name "z",s,t - | _ -> (* prods number may only increase for substitution *) - assert false) in - match tl with - [] -> - (* prerr_endline ("******* too few args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *) - let res' = List.map (S.lift 1) res in - C.Lambda - (name, source, aux (n-1) target [] (res'@[C.Rel 1])) - | hd::tl' -> - let hd' = fix_lambdas_wrt_type source hd in - (* (prerr_endline ("++++++prima :" ^(CicPp.ppterm hd)); - prerr_endline ("++++++dopo :" ^(CicPp.ppterm hd'))); *) - aux (n-1) (S.subst hd' target) tl' (res@[hd']) in - aux expected_arity ty tl [hd] -;; - -let eta_fix metasenv context t = - let rec eta_fix' context t = - (* prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t); - flush stderr ; *) - let module C = Cic in - let module S = CicSubstitution in - match t with - C.Rel n -> C.Rel n - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.Var (uri,exp_named_subst') - | C.Meta (n,l) -> - let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in - let l' = - List.map2 - (fun ct t -> - match (ct, t) with - None, _ -> None - | _, Some t -> Some (eta_fix' context t) - | Some _, None -> assert false (* due to typing rules *)) - canonical_context l - in - C.Meta (n,l') - | C.Sort s -> C.Sort s - | C.Implicit _ as t -> t - | C.Cast (v,t) -> C.Cast (eta_fix' context v, eta_fix' context t) - | C.Prod (n,s,t) -> - C.Prod - (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t) - | C.Lambda (n,s,t) -> - C.Lambda - (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t) - | C.LetIn (n,s,t) -> - C.LetIn - (n,eta_fix' context s,eta_fix' ((Some (n,(C.Def (s,None))))::context) t) - | C.Appl l -> - let l' = List.map (eta_fix' context) l - in - (match l' with - [] -> assert false - | he::tl -> - let ty,_ = - CicTypeChecker.type_of_aux' metasenv context he - CicUniv.empty_ugraph - in - fix_according_to_type ty he tl -(* - C.Const(uri,exp_named_subst)::l'' -> - let constant_type = - (match CicEnvironment.get_obj uri with - C.Constant (_,_,ty,_) -> ty - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof (_,_,_,_,params) -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) in - fix_according_to_type - constant_type (C.Const(uri,exp_named_subst)) l'' - | _ -> C.Appl l' *)) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.MutInd (uri, tyno, exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.MutConstruct (uri, tyno, consno, exp_named_subst') - | C.MutCase (uri, tyno, outty, term, patterns) -> - let outty' = eta_fix' context outty in - let term' = eta_fix' context term in - let patterns' = List.map (eta_fix' context) patterns in - let inductive_types,noparams = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match o with - Cic.Constant _ -> assert false - | Cic.Variable _ -> assert false - | Cic.CurrentProof _ -> assert false - | Cic.InductiveDefinition (l,_,n,_) -> l,n - ) in - let (_,_,_,constructors) = List.nth inductive_types tyno in - let constructor_types = - let rec clean_up t = - function - [] -> t - | a::tl -> - (match t with - Cic.Prod (_,_,t') -> clean_up (S.subst a t') tl - | _ -> assert false) in - if noparams = 0 then - List.map (fun (_,t) -> t) constructors - else - let term_type,_ = - CicTypeChecker.type_of_aux' metasenv context term - CicUniv.empty_ugraph - in - (match term_type with - C.Appl (hd::params) -> - let rec first_n n l = - if n = 0 then [] - else - (match l with - a::tl -> a::(first_n (n-1) tl) - | _ -> assert false) in - List.map - (fun (_,t) -> - clean_up t (first_n noparams params)) constructors - | _ -> prerr_endline ("QUA"); assert false) in - let patterns2 = - List.map2 fix_lambdas_wrt_type - constructor_types patterns' in - C.MutCase (uri, tyno, outty',term',patterns2) - | C.Fix (funno, funs) -> - let fun_types = - List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in - C.Fix (funno, - List.map - (fun (name, no, ty, bo) -> - (name, no, eta_fix' context ty, eta_fix' (fun_types@context) bo)) - funs) - | C.CoFix (funno, funs) -> - let fun_types = - List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in - C.CoFix (funno, - List.map - (fun (name, ty, bo) -> - (name, eta_fix' context ty, eta_fix' (fun_types@context) bo)) funs) - and fix_exp_named_subst context exp_named_subst = - List.rev - (List.fold_left - (fun newsubst (uri,t) -> - let t' = eta_fix' context t in - let ty = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - Cic.Variable (_,_,ty,_,_) -> - CicSubstitution.subst_vars newsubst ty - | _ -> raise ReferenceToNonVariable - in - let t'' = fix_according_to_type ty t' [] in - (uri,t'')::newsubst - ) [] exp_named_subst) - in - eta_fix' context t -;; diff --git a/helm/ocaml/cic_acic/eta_fixing.mli b/helm/ocaml/cic_acic/eta_fixing.mli deleted file mode 100644 index c6c68119d..000000000 --- a/helm/ocaml/cic_acic/eta_fixing.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* 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 eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term - - diff --git a/helm/ocaml/cic_disambiguation/.depend b/helm/ocaml/cic_disambiguation/.depend deleted file mode 100644 index ca4124461..000000000 --- a/helm/ocaml/cic_disambiguation/.depend +++ /dev/null @@ -1,12 +0,0 @@ -disambiguateChoices.cmi: disambiguateTypes.cmi -disambiguate.cmi: disambiguateTypes.cmi -disambiguateTypes.cmo: disambiguateTypes.cmi -disambiguateTypes.cmx: disambiguateTypes.cmi -disambiguateChoices.cmo: disambiguateTypes.cmi disambiguateChoices.cmi -disambiguateChoices.cmx: disambiguateTypes.cmx disambiguateChoices.cmi -disambiguate.cmo: disambiguateTypes.cmi disambiguateChoices.cmi \ - disambiguate.cmi -disambiguate.cmx: disambiguateTypes.cmx disambiguateChoices.cmx \ - disambiguate.cmi -number_notation.cmo: disambiguateTypes.cmi disambiguateChoices.cmi -number_notation.cmx: disambiguateTypes.cmx disambiguateChoices.cmx diff --git a/helm/ocaml/cic_disambiguation/Makefile b/helm/ocaml/cic_disambiguation/Makefile deleted file mode 100644 index cd03e8281..000000000 --- a/helm/ocaml/cic_disambiguation/Makefile +++ /dev/null @@ -1,32 +0,0 @@ - -PACKAGE = cic_disambiguation -NOTATIONS = number -INTERFACE_FILES = \ - disambiguateTypes.mli \ - disambiguateChoices.mli \ - disambiguate.mli -IMPLEMENTATION_FILES = \ - $(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \ - $(patsubst %,%_notation.ml,$(NOTATIONS)) - -all: - -clean: -distclean: - rm -f macro_table.dump - -include ../../Makefile.defs -include ../Makefile.common - -OCAMLARCHIVEOPTIONS += -linkall - -disambiguateTypes.cmi: disambiguateTypes.mli - @echo " OCAMLC -rectypes $<" - @$(OCAMLC) -c -rectypes $< -disambiguateTypes.cmo: disambiguateTypes.ml disambiguateTypes.cmi - @echo " OCAMLC -rectypes $<" - @$(OCAMLC) -c -rectypes $< -disambiguateTypes.cmx: disambiguateTypes.ml disambiguateTypes.cmi - @echo " OCAMLOPT -rectypes $<" - @$(OCAMLOPT) -c -rectypes $< - diff --git a/helm/ocaml/cic_disambiguation/disambiguate.ml b/helm/ocaml/cic_disambiguation/disambiguate.ml deleted file mode 100644 index 667c50770..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguate.ml +++ /dev/null @@ -1,1009 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open DisambiguateTypes -open UriManager - -(* the integer is an offset to be added to each location *) -exception NoWellTypedInterpretation of - int * (Token.flocation option * string Lazy.t) list -exception PathNotWellFormed - - (** raised when an environment is not enough informative to decide *) -exception Try_again of string Lazy.t - -type aliases = bool * DisambiguateTypes.environment - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) else () - -(* - (** print benchmark information *) -let benchmark = true -let max_refinements = ref 0 (* benchmarking is not thread safe *) -let actual_refinements = ref 0 -let domain_size = ref 0 -let choices_avg = ref 0. -*) - -let descr_of_domain_item = function - | Id s -> s - | Symbol (s, _) -> s - | Num i -> string_of_int i - -type 'a test_result = - | Ok of 'a * Cic.metasenv - | Ko of Token.flocation option * string Lazy.t - | Uncertain of Token.flocation option * string Lazy.t - -let refine_term metasenv context uri term ugraph ~localization_tbl = -(* if benchmark then incr actual_refinements; *) - assert (uri=None); - debug_print (lazy (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppterm term))); - try - let term', _, metasenv',ugraph1 = - CicRefine.type_of_aux' metasenv context term ugraph ~localization_tbl in - (Ok (term', metasenv')),ugraph1 - with - exn -> - let rec process_exn loc = - function - HExtlib.Localized (loc,exn) -> process_exn (Some loc) exn - | CicRefine.Uncertain msg -> - debug_print (lazy ("UNCERTAIN!!! [" ^ (Lazy.force msg) ^ "] " ^ CicPp.ppterm term)) ; - Uncertain (loc,msg),ugraph - | CicRefine.RefineFailure msg -> - debug_print (lazy (sprintf "PRUNED!!!\nterm%s\nmessage:%s" - (CicPp.ppterm term) (Lazy.force msg))); - Ko (loc,msg),ugraph - | exn -> raise exn - in - process_exn None exn - -let refine_obj metasenv context uri obj ugraph ~localization_tbl = - assert (context = []); - debug_print (lazy (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppobj obj))) ; - try - let obj', metasenv,ugraph = - CicRefine.typecheck metasenv uri obj ~localization_tbl - in - (Ok (obj', metasenv)),ugraph - with - exn -> - let rec process_exn loc = - function - HExtlib.Localized (loc,exn) -> process_exn (Some loc) exn - | CicRefine.Uncertain msg -> - debug_print (lazy ("UNCERTAIN!!! [" ^ (Lazy.force msg) ^ "] " ^ CicPp.ppobj obj)) ; - Uncertain (loc,msg),ugraph - | CicRefine.RefineFailure msg -> - debug_print (lazy (sprintf "PRUNED!!!\nterm%s\nmessage:%s" - (CicPp.ppobj obj) (Lazy.force msg))) ; - Ko (loc,msg),ugraph - | exn -> raise exn - in - process_exn None exn - -let resolve (env: codomain_item Environment.t) (item: domain_item) ?(num = "") ?(args = []) () = - try - snd (Environment.find item env) env num args - with Not_found -> - failwith ("Domain item not found: " ^ - (DisambiguateTypes.string_of_domain_item item)) - - (* TODO move it to Cic *) -let find_in_context name context = - let rec aux acc = function - | [] -> raise Not_found - | Cic.Name hd :: tl when hd = name -> acc - | _ :: tl -> aux (acc + 1) tl - in - aux 1 context - -let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast - ~localization_tbl -= - assert (uri = None); - let rec aux ~localize loc (context: Cic.name list) = function - | CicNotationPt.AttributedTerm (`Loc loc, term) -> - let res = aux ~localize loc context term in - if localize then Cic.CicHash.add localization_tbl res loc; - res - | CicNotationPt.AttributedTerm (_, term) -> aux ~localize loc context term - | CicNotationPt.Appl (CicNotationPt.Symbol (symb, i) :: args) -> - let cic_args = List.map (aux ~localize loc context) args in - resolve env (Symbol (symb, i)) ~args:cic_args () - | CicNotationPt.Appl terms -> - Cic.Appl (List.map (aux ~localize loc context) terms) - | CicNotationPt.Binder (binder_kind, (var, typ), body) -> - let cic_type = aux_option ~localize loc context (Some `Type) typ in - let cic_name = CicNotationUtil.cic_name_of_name var in - let cic_body = aux ~localize loc (cic_name :: context) body in - (match binder_kind with - | `Lambda -> Cic.Lambda (cic_name, cic_type, cic_body) - | `Pi - | `Forall -> Cic.Prod (cic_name, cic_type, cic_body) - | `Exists -> - resolve env (Symbol ("exists", 0)) - ~args:[ cic_type; Cic.Lambda (cic_name, cic_type, cic_body) ] ()) - | CicNotationPt.Case (term, indty_ident, outtype, branches) -> - let cic_term = aux ~localize loc context term in - let cic_outtype = aux_option ~localize loc context None outtype in - let do_branch ((head, _, args), term) = - let rec do_branch' context = function - | [] -> aux ~localize loc context term - | (name, typ) :: tl -> - let cic_name = CicNotationUtil.cic_name_of_name name in - let cic_body = do_branch' (cic_name :: context) tl in - let typ = - match typ with - | None -> Cic.Implicit (Some `Type) - | Some typ -> aux ~localize loc context typ - in - Cic.Lambda (cic_name, typ, cic_body) - in - do_branch' context args - in - let (indtype_uri, indtype_no) = - match indty_ident with - | Some (indty_ident, _) -> - (match resolve env (Id indty_ident) () with - | Cic.MutInd (uri, tyno, _) -> (uri, tyno) - | Cic.Implicit _ -> - raise (Try_again (lazy "The type of the term to be matched - is still unknown")) - | _ -> - raise (Invalid_choice (lazy "The type of the term to be matched is not (co)inductive!"))) - | None -> - let fst_constructor = - match branches with - | ((head, _, _), _) :: _ -> head - | [] -> raise (Invalid_choice (lazy "The type of the term to be matched is an inductive type without constructors that cannot be determined")) - in - (match resolve env (Id fst_constructor) () with - | Cic.MutConstruct (indtype_uri, indtype_no, _, _) -> - (indtype_uri, indtype_no) - | Cic.Implicit _ -> - raise (Try_again (lazy "The type of the term to be matched - is still unknown")) - | _ -> - raise (Invalid_choice (lazy "The type of the term to be matched is not (co)inductive!"))) - in - Cic.MutCase (indtype_uri, indtype_no, cic_outtype, cic_term, - (List.map do_branch branches)) - | CicNotationPt.Cast (t1, t2) -> - let cic_t1 = aux ~localize loc context t1 in - let cic_t2 = aux ~localize loc context t2 in - Cic.Cast (cic_t1, cic_t2) - | CicNotationPt.LetIn ((name, typ), def, body) -> - let cic_def = aux ~localize loc context def in - let cic_name = CicNotationUtil.cic_name_of_name name in - let cic_def = - match typ with - | None -> cic_def - | Some t -> Cic.Cast (cic_def, aux ~localize loc context t) - in - let cic_body = aux ~localize loc (cic_name :: context) body in - Cic.LetIn (cic_name, cic_def, cic_body) - | CicNotationPt.LetRec (kind, defs, body) -> - let context' = - List.fold_left - (fun acc ((name, _), _, _) -> - CicNotationUtil.cic_name_of_name name :: acc) - context defs - in - let cic_body = - let unlocalized_body = aux ~localize:false loc context' body in - match unlocalized_body with - Cic.Rel 1 -> `AvoidLetInNoAppl - | Cic.Appl (Cic.Rel 1::l) -> - (try - let l' = - List.map - (function t -> - let t',subst,metasenv = - CicMetaSubst.delift_rels [] [] 1 t - in - assert (subst=[]); - assert (metasenv=[]); - t') l - in - (* We can avoid the LetIn. But maybe we need to recompute l' - so that it is localized *) - if localize then - match body with - CicNotationPt.AttributedTerm (_,CicNotationPt.Appl(_::l)) -> - let l' = List.map (aux ~localize loc context) l in - `AvoidLetIn l' - | _ -> assert false - else - `AvoidLetIn l' - with - CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> - if localize then - `AddLetIn (aux ~localize loc context' body) - else - `AddLetIn unlocalized_body) - | _ -> - if localize then - `AddLetIn (aux ~localize loc context' body) - else - `AddLetIn unlocalized_body - in - let inductiveFuns = - List.map - (fun ((name, typ), body, decr_idx) -> - let cic_body = aux ~localize loc context' body in - let cic_type = - aux_option ~localize loc context (Some `Type) typ in - let name = - match CicNotationUtil.cic_name_of_name name with - | Cic.Anonymous -> - CicNotationPt.fail loc - "Recursive functions cannot be anonymous" - | Cic.Name name -> name - in - (name, decr_idx, cic_type, cic_body)) - defs - in - let counter = ref ~-1 in - let build_term funs = - (* this is the body of the fold_right function below. Rationale: Fix - * and CoFix cases differs only in an additional index in the - * inductiveFun list, see Cic.term *) - match kind with - | `Inductive -> - (fun (var, _, _, _) cic -> - incr counter; - let fix = Cic.Fix (!counter,funs) in - match cic with - `Recipe (`AddLetIn cic) -> - `Term (Cic.LetIn (Cic.Name var, fix, cic)) - | `Recipe (`AvoidLetIn l) -> `Term (Cic.Appl (fix::l)) - | `Recipe `AvoidLetInNoAppl -> `Term fix - | `Term t -> `Term (Cic.LetIn (Cic.Name var, fix, t))) - | `CoInductive -> - let funs = - List.map (fun (name, _, typ, body) -> (name, typ, body)) funs - in - (fun (var, _, _, _) cic -> - incr counter; - let cofix = Cic.CoFix (!counter,funs) in - match cic with - `Recipe (`AddLetIn cic) -> - `Term (Cic.LetIn (Cic.Name var, cofix, cic)) - | `Recipe (`AvoidLetIn l) -> `Term (Cic.Appl (cofix::l)) - | `Recipe `AvoidLetInNoAppl -> `Term cofix - | `Term t -> `Term (Cic.LetIn (Cic.Name var, cofix, t))) - in - (match - List.fold_right (build_term inductiveFuns) inductiveFuns - (`Recipe cic_body) - with - `Recipe _ -> assert false - | `Term t -> t) - | CicNotationPt.Ident _ - | CicNotationPt.Uri _ when is_path -> raise PathNotWellFormed - | CicNotationPt.Ident (name, subst) - | CicNotationPt.Uri (name, subst) as ast -> - let is_uri = function CicNotationPt.Uri _ -> true | _ -> false in - (try - if is_uri ast then raise Not_found;(* don't search the env for URIs *) - let index = find_in_context name context in - if subst <> None then - CicNotationPt.fail loc "Explicit substitutions not allowed here"; - Cic.Rel index - with Not_found -> - let cic = - if is_uri ast then (* we have the URI, build the term out of it *) - try - CicUtil.term_of_uri (UriManager.uri_of_string name) - with UriManager.IllFormedUri _ -> - CicNotationPt.fail loc "Ill formed URI" - else - resolve env (Id name) () - in - let mk_subst uris = - let ids_to_uris = - List.map (fun uri -> UriManager.name_of_uri uri, uri) uris - in - (match subst with - | Some subst -> - List.map - (fun (s, term) -> - (try - List.assoc s ids_to_uris, aux ~localize loc context term - with Not_found -> - raise (Invalid_choice (lazy "The provided explicit named substitution is trying to instantiate a named variable the object is not abstracted on")))) - subst - | None -> List.map (fun uri -> uri, Cic.Implicit None) uris) - in - (try - match cic with - | Cic.Const (uri, []) -> - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - let uris = CicUtil.params_of_obj o in - Cic.Const (uri, mk_subst uris) - | Cic.Var (uri, []) -> - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - let uris = CicUtil.params_of_obj o in - Cic.Var (uri, mk_subst uris) - | Cic.MutInd (uri, i, []) -> - (try - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - let uris = CicUtil.params_of_obj o in - Cic.MutInd (uri, i, mk_subst uris) - with - CicEnvironment.Object_not_found _ -> - (* if we are here it is probably the case that during the - definition of a mutual inductive type we have met an - occurrence of the type in one of its constructors. - However, the inductive type is not yet in the environment - *) - (*here the explicit_named_substituion is assumed to be of length 0 *) - Cic.MutInd (uri,i,[])) - | Cic.MutConstruct (uri, i, j, []) -> - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - let uris = CicUtil.params_of_obj o in - Cic.MutConstruct (uri, i, j, mk_subst uris) - | Cic.Meta _ | Cic.Implicit _ as t -> -(* - debug_print (lazy (sprintf - "Warning: %s must be instantiated with _[%s] but we do not enforce it" - (CicPp.ppterm t) - (String.concat "; " - (List.map - (fun (s, term) -> s ^ " := " ^ CicNotationPtPp.pp_term term) - subst)))); -*) - t - | _ -> - raise (Invalid_choice (lazy "??? Can this happen?")) - with - CicEnvironment.CircularDependency _ -> - raise (Invalid_choice (lazy "Circular dependency in the environment")))) - | CicNotationPt.Implicit -> Cic.Implicit None - | CicNotationPt.UserInput -> Cic.Implicit (Some `Hole) - | CicNotationPt.Num (num, i) -> resolve env (Num i) ~num () - | CicNotationPt.Meta (index, subst) -> - let cic_subst = - List.map - (function - None -> None - | Some term -> Some (aux ~localize loc context term)) - subst - in - Cic.Meta (index, cic_subst) - | CicNotationPt.Sort `Prop -> Cic.Sort Cic.Prop - | CicNotationPt.Sort `Set -> Cic.Sort Cic.Set - | CicNotationPt.Sort (`Type u) -> Cic.Sort (Cic.Type u) - | CicNotationPt.Sort `CProp -> Cic.Sort Cic.CProp - | CicNotationPt.Symbol (symbol, instance) -> - resolve env (Symbol (symbol, instance)) () - | _ -> assert false (* god bless Bologna *) - and aux_option ~localize loc (context: Cic.name list) annotation = function - | None -> Cic.Implicit annotation - | Some term -> aux ~localize loc context term - in - aux ~localize:true HExtlib.dummy_floc context ast - -let interpretate_path ~context path = - let localization_tbl = Cic.CicHash.create 23 in - (* here we are throwing away useful localization informations!!! *) - fst ( - interpretate_term ~context ~env:Environment.empty ~uri:None ~is_path:true - path ~localization_tbl, localization_tbl) - -let interpretate_obj ~context ~env ~uri ~is_path obj ~localization_tbl = - assert (context = []); - assert (is_path = false); - let interpretate_term = interpretate_term ~localization_tbl in - match obj with - | CicNotationPt.Inductive (params,tyl) -> - let uri = match uri with Some uri -> uri | None -> assert false in - let context,params = - let context,res = - List.fold_left - (fun (context,res) (name,t) -> - Cic.Name name :: context, - (name, interpretate_term context env None false t)::res - ) ([],[]) params - in - context,List.rev res in - let add_params = - List.fold_right - (fun (name,ty) t -> Cic.Prod (Cic.Name name,ty,t)) params in - let name_to_uris = - snd ( - List.fold_left - (*here the explicit_named_substituion is assumed to be of length 0 *) - (fun (i,res) (name,_,_,_) -> - i + 1,(name,name,Cic.MutInd (uri,i,[]))::res - ) (0,[]) tyl) in - let con_env = DisambiguateTypes.env_of_list name_to_uris env in - let tyl = - List.map - (fun (name,b,ty,cl) -> - let ty' = add_params (interpretate_term context env None false ty) in - let cl' = - List.map - (fun (name,ty) -> - let ty' = - add_params (interpretate_term context con_env None false ty) - in - name,ty' - ) cl - in - name,b,ty',cl' - ) tyl - in - Cic.InductiveDefinition (tyl,[],List.length params,[]) - | CicNotationPt.Record (params,name,ty,fields) -> - let uri = match uri with Some uri -> uri | None -> assert false in - let context,params = - let context,res = - List.fold_left - (fun (context,res) (name,t) -> - (Cic.Name name :: context), - (name, interpretate_term context env None false t)::res - ) ([],[]) params - in - context,List.rev res in - let add_params = - List.fold_right - (fun (name,ty) t -> Cic.Prod (Cic.Name name,ty,t)) params in - let ty' = add_params (interpretate_term context env None false ty) in - let fields' = - snd ( - List.fold_left - (fun (context,res) (name,ty,_coercion) -> - let context' = Cic.Name name :: context in - context',(name,interpretate_term context env None false ty)::res - ) (context,[]) fields) in - let concl = - (*here the explicit_named_substituion is assumed to be of length 0 *) - let mutind = Cic.MutInd (uri,0,[]) in - if params = [] then mutind - else - Cic.Appl - (mutind::CicUtil.mk_rels (List.length params) (List.length fields)) in - let con = - List.fold_left - (fun t (name,ty) -> Cic.Prod (Cic.Name name,ty,t)) - concl fields' in - let con' = add_params con in - let tyl = [name,true,ty',["mk_" ^ name,con']] in - let field_names = List.map (fun (x,_,y) -> x,y) fields in - Cic.InductiveDefinition - (tyl,[],List.length params,[`Class (`Record field_names)]) - | CicNotationPt.Theorem (flavour, name, ty, bo) -> - let attrs = [`Flavour flavour] in - let ty' = interpretate_term [] env None false ty in - (match bo with - None -> - Cic.CurrentProof (name,[],Cic.Implicit None,ty',[],attrs) - | Some bo -> - let bo' = Some (interpretate_term [] env None false bo) in - Cic.Constant (name,bo',ty',[],attrs)) - - - (* e.g. [5;1;1;1;2;3;4;1;2] -> [2;1;4;3;5] *) -let rev_uniq = - let module SortedItem = - struct - type t = DisambiguateTypes.domain_item - let compare = Pervasives.compare - end - in - let module Set = Set.Make (SortedItem) in - fun l -> - let rev_l = List.rev l in - let (_, uniq_rev_l) = - List.fold_left - (fun (members, rev_l) elt -> - if Set.mem elt members then - (members, rev_l) - else - Set.add elt members, elt :: rev_l) - (Set.empty, []) rev_l - in - List.rev uniq_rev_l - -(* "aux" keeps domain in reverse order and doesn't care about duplicates. - * Domain item more in deep in the list will be processed first. - *) -let rec domain_rev_of_term ?(loc = HExtlib.dummy_floc) context = function - | CicNotationPt.AttributedTerm (`Loc loc, term) -> - domain_rev_of_term ~loc context term - | CicNotationPt.AttributedTerm (_, term) -> - domain_rev_of_term ~loc context term - | CicNotationPt.Appl terms -> - List.fold_left - (fun dom term -> domain_rev_of_term ~loc context term @ dom) [] terms - | CicNotationPt.Binder (kind, (var, typ), body) -> - let kind_dom = - match kind with - | `Exists -> [ Symbol ("exists", 0) ] - | _ -> [] - in - let type_dom = domain_rev_of_term_option loc context typ in - let body_dom = - domain_rev_of_term ~loc - (CicNotationUtil.cic_name_of_name var :: context) body - in - body_dom @ type_dom @ kind_dom - | CicNotationPt.Case (term, indty_ident, outtype, branches) -> - let term_dom = domain_rev_of_term ~loc context term in - let outtype_dom = domain_rev_of_term_option loc context outtype in - let get_first_constructor = function - | [] -> [] - | ((head, _, _), _) :: _ -> [ Id head ] - in - let do_branch ((head, _, args), term) = - let (term_context, args_domain) = - List.fold_left - (fun (cont, dom) (name, typ) -> - (CicNotationUtil.cic_name_of_name name :: cont, - (match typ with - | None -> dom - | Some typ -> domain_rev_of_term ~loc cont typ @ dom))) - (context, []) args - in - args_domain @ domain_rev_of_term ~loc term_context term - in - let branches_dom = - List.fold_left (fun dom branch -> do_branch branch @ dom) [] branches - in - branches_dom @ outtype_dom @ term_dom @ - (match indty_ident with - | None -> get_first_constructor branches - | Some (ident, _) -> [ Id ident ]) - | CicNotationPt.Cast (term, ty) -> - let term_dom = domain_rev_of_term ~loc context term in - let ty_dom = domain_rev_of_term ~loc context ty in - ty_dom @ term_dom - | CicNotationPt.LetIn ((var, typ), body, where) -> - let body_dom = domain_rev_of_term ~loc context body in - let type_dom = domain_rev_of_term_option loc context typ in - let where_dom = - domain_rev_of_term ~loc - (CicNotationUtil.cic_name_of_name var :: context) where - in - where_dom @ type_dom @ body_dom - | CicNotationPt.LetRec (kind, defs, where) -> - let context' = - List.fold_left - (fun acc ((var, typ), _, _) -> - CicNotationUtil.cic_name_of_name var :: acc) - context defs - in - let where_dom = domain_rev_of_term ~loc context' where in - let defs_dom = - List.fold_left - (fun dom ((_, typ), body, _) -> - domain_rev_of_term ~loc context' body @ - domain_rev_of_term_option loc context typ) - [] defs - in - where_dom @ defs_dom - | CicNotationPt.Ident (name, subst) -> - (try - (* the next line can raise Not_found *) - ignore(find_in_context name context); - if subst <> None then - CicNotationPt.fail loc "Explicit substitutions not allowed here" - else - [] - with Not_found -> - (match subst with - | None -> [Id name] - | Some subst -> - List.fold_left - (fun dom (_, term) -> - let dom' = domain_rev_of_term ~loc context term in - dom' @ dom) - [Id name] subst)) - | CicNotationPt.Uri _ -> [] - | CicNotationPt.Implicit -> [] - | CicNotationPt.Num (num, i) -> [ Num i ] - | CicNotationPt.Meta (index, local_context) -> - List.fold_left - (fun dom term -> domain_rev_of_term_option loc context term @ dom) [] - local_context - | CicNotationPt.Sort _ -> [] - | CicNotationPt.Symbol (symbol, instance) -> [ Symbol (symbol, instance) ] - | CicNotationPt.UserInput - | CicNotationPt.Literal _ - | CicNotationPt.Layout _ - | CicNotationPt.Magic _ - | CicNotationPt.Variable _ -> assert false - -and domain_rev_of_term_option loc context = function - | None -> [] - | Some t -> domain_rev_of_term ~loc context t - -let domain_of_term ~context ast = rev_uniq (domain_rev_of_term context ast) - -let domain_of_obj ~context ast = - assert (context = []); - let domain_rev = - match ast with - | CicNotationPt.Theorem (_,_,ty,bo) -> - (match bo with - None -> [] - | Some bo -> domain_rev_of_term [] bo) @ - domain_of_term [] ty - | CicNotationPt.Inductive (params,tyl) -> - let dom = - List.flatten ( - List.rev_map - (fun (_,_,ty,cl) -> - List.flatten ( - List.rev_map - (fun (_,ty) -> domain_rev_of_term [] ty) cl) @ - domain_rev_of_term [] ty) tyl) in - let dom = - List.fold_left - (fun dom (_,ty) -> - domain_rev_of_term [] ty @ dom - ) dom params - in - List.filter - (fun name -> - not ( List.exists (fun (name',_) -> name = Id name') params - || List.exists (fun (name',_,_,_) -> name = Id name') tyl) - ) dom - | CicNotationPt.Record (params,_,ty,fields) -> - let dom = - List.flatten - (List.rev_map (fun (_,ty,_) -> domain_rev_of_term [] ty) fields) in - let dom = - List.fold_left - (fun dom (_,ty) -> - domain_rev_of_term [] ty @ dom - ) (dom @ domain_rev_of_term [] ty) params - in - List.filter - (fun name-> - not ( List.exists (fun (name',_) -> name = Id name') params - || List.exists (fun (name',_,_) -> name = Id name') fields) - ) dom - in - rev_uniq domain_rev - - (* dom1 \ dom2 *) -let domain_diff dom1 dom2 = -(* let domain_diff = Domain.diff *) - let is_in_dom2 = - List.fold_left (fun pred elt -> (fun elt' -> elt' = elt || pred elt')) - (fun _ -> false) dom2 - in - List.filter (fun elt -> not (is_in_dom2 elt)) dom1 - -module type Disambiguator = -sig - val disambiguate_term : - ?fresh_instances:bool -> - dbd:HMysql.dbd -> - context:Cic.context -> - metasenv:Cic.metasenv -> - ?initial_ugraph:CicUniv.universe_graph -> - aliases:DisambiguateTypes.environment ->(* previous interpretation status *) - universe:DisambiguateTypes.multiple_environment option -> - CicNotationPt.term -> - ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * - Cic.metasenv * (* new metasenv *) - Cic.term* - CicUniv.universe_graph) list * (* disambiguated term *) - bool - - val disambiguate_obj : - ?fresh_instances:bool -> - dbd:HMysql.dbd -> - aliases:DisambiguateTypes.environment ->(* previous interpretation status *) - universe:DisambiguateTypes.multiple_environment option -> - uri:UriManager.uri option -> (* required only for inductive types *) - CicNotationPt.obj -> - ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * - Cic.metasenv * (* new metasenv *) - Cic.obj * - CicUniv.universe_graph) list * (* disambiguated obj *) - bool -end - -module Make (C: Callbacks) = - struct - let choices_of_id dbd id = - let uris = Whelp.locate ~dbd id in - let uris = - match uris with - | [] -> - [(C.input_or_locate_uri - ~title:("URI matching \"" ^ id ^ "\" unknown.") ~id ())] - | [uri] -> [uri] - | _ -> - C.interactive_user_uri_choice ~selection_mode:`MULTIPLE - ~ok:"Try selected." ~enable_button_for_non_vars:true - ~title:"Ambiguous input." ~id - ~msg: ("Ambiguous input \"" ^ id ^ - "\". Please, choose one or more interpretations:") - uris - in - List.map - (fun uri -> - (UriManager.string_of_uri uri, - let term = - try - CicUtil.term_of_uri uri - with exn -> - debug_print (lazy (UriManager.string_of_uri uri)); - debug_print (lazy (Printexc.to_string exn)); - assert false - in - fun _ _ _ -> term)) - uris - -let refine_profiler = HExtlib.profile "disambiguate_thing.refine_thing" - - let disambiguate_thing ~dbd ~context ~metasenv - ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases ~universe - ~uri ~pp_thing ~domain_of_thing ~interpretate_thing ~refine_thing thing - = - debug_print (lazy "DISAMBIGUATE INPUT"); - let disambiguate_context = (* cic context -> disambiguate context *) - List.map - (function None -> Cic.Anonymous | Some (name, _) -> name) - context - in - debug_print (lazy ("TERM IS: " ^ (pp_thing thing))); - let thing_dom = domain_of_thing ~context:disambiguate_context thing in - debug_print (lazy (sprintf "DISAMBIGUATION DOMAIN: %s" - (string_of_domain thing_dom))); -(* - debug_print (lazy (sprintf "DISAMBIGUATION ENVIRONMENT: %s" - (DisambiguatePp.pp_environment aliases))); - debug_print (lazy (sprintf "DISAMBIGUATION UNIVERSE: %s" - (match universe with None -> "None" | Some _ -> "Some _"))); -*) - let current_dom = - Environment.fold (fun item _ dom -> item :: dom) aliases [] - in - let todo_dom = domain_diff thing_dom current_dom in - (* (2) lookup function for any item (Id/Symbol/Num) *) - let lookup_choices = - fun item -> - let choices = - let lookup_in_library () = - match item with - | Id id -> choices_of_id dbd id - | Symbol (symb, _) -> - List.map DisambiguateChoices.mk_choice - (TermAcicContent.lookup_interpretations symb) - | Num instance -> - DisambiguateChoices.lookup_num_choices () - in - match universe with - | None -> lookup_in_library () - | Some e -> - (try - let item = - match item with - | Symbol (symb, _) -> Symbol (symb, 0) - | item -> item - in - Environment.find item e - with Not_found -> []) - in - choices - in -(* - (* *) - let _ = - if benchmark then begin - let per_item_choices = - List.map - (fun dom_item -> - try - let len = List.length (lookup_choices dom_item) in - debug_print (lazy (sprintf "BENCHMARK %s: %d" - (string_of_domain_item dom_item) len)); - len - with No_choices _ -> 0) - thing_dom - in - max_refinements := List.fold_left ( * ) 1 per_item_choices; - actual_refinements := 0; - domain_size := List.length thing_dom; - choices_avg := - (float_of_int !max_refinements) ** (1. /. float_of_int !domain_size) - end - in - (* *) -*) - - (* (3) test an interpretation filling with meta uninterpreted identifiers - *) - let test_env aliases todo_dom ugraph = - let filled_env = - List.fold_left - (fun env item -> - Environment.add item - ("Implicit", - (match item with - | Id _ | Num _ -> (fun _ _ _ -> Cic.Implicit (Some `Closed)) - | Symbol _ -> (fun _ _ _ -> Cic.Implicit None))) env) - aliases todo_dom - in - try - let localization_tbl = Cic.CicHash.create 503 in - let cic_thing = - interpretate_thing ~context:disambiguate_context ~env:filled_env - ~uri ~is_path:false thing ~localization_tbl - in -let foo () = - let k,ugraph1 = - refine_thing metasenv context uri cic_thing ugraph ~localization_tbl - in - (k , ugraph1 ) -in refine_profiler.HExtlib.profile foo () - with - | Try_again msg -> Uncertain (None,msg), ugraph - | Invalid_choice msg -> Ko (None,msg), ugraph - in - (* (4) build all possible interpretations *) - let (@@) (l1,l2) (l1',l2') = l1@l1', l2@l2' in - let rec aux aliases diff lookup_in_todo_dom todo_dom base_univ = - match todo_dom with - | [] -> - assert (lookup_in_todo_dom = None); - (match test_env aliases [] base_univ with - | Ok (thing, metasenv),new_univ -> - [ aliases, diff, metasenv, thing, new_univ ], [] - | Ko (loc,msg),_ | Uncertain (loc,msg),_ -> [],[loc,msg]) - | item :: remaining_dom -> - debug_print (lazy (sprintf "CHOOSED ITEM: %s" - (string_of_domain_item item))); - let choices = - match lookup_in_todo_dom with - None -> lookup_choices item - | Some choices -> choices in - match choices with - [] -> - [], [None,lazy ("No choices for " ^ string_of_domain_item item)] - | [codomain_item] -> - (* just one choice. We perform a one-step look-up and - if the next set of choices is also a singleton we - skip this refinement step *) - debug_print(lazy (sprintf "%s CHOSEN" (fst codomain_item))); - let new_env = Environment.add item codomain_item aliases in - let new_diff = (item,codomain_item)::diff in - let lookup_in_todo_dom,next_choice_is_single = - match remaining_dom with - [] -> None,false - | he::_ -> - let choices = lookup_choices he in - Some choices,List.length choices = 1 - in - if next_choice_is_single then - aux new_env new_diff lookup_in_todo_dom remaining_dom - base_univ - else - (match test_env new_env remaining_dom base_univ with - | Ok (thing, metasenv),new_univ -> - (match remaining_dom with - | [] -> - [ new_env, new_diff, metasenv, thing, new_univ ], [] - | _ -> - aux new_env new_diff lookup_in_todo_dom - remaining_dom new_univ) - | Uncertain (loc,msg),new_univ -> - (match remaining_dom with - | [] -> [], [loc,msg] - | _ -> - aux new_env new_diff lookup_in_todo_dom - remaining_dom new_univ) - | Ko (loc,msg),_ -> [], [loc,msg]) - | _::_ -> - let rec filter univ = function - | [] -> [],[] - | codomain_item :: tl -> - debug_print(lazy (sprintf "%s CHOSEN" (fst codomain_item))); - let new_env = Environment.add item codomain_item aliases in - let new_diff = (item,codomain_item)::diff in - (match test_env new_env remaining_dom univ with - | Ok (thing, metasenv),new_univ -> - (match remaining_dom with - | [] -> [ new_env, new_diff, metasenv, thing, new_univ ], [] - | _ -> aux new_env new_diff None remaining_dom new_univ - ) @@ - filter univ tl - | Uncertain (loc,msg),new_univ -> - (match remaining_dom with - | [] -> [],[loc,msg] - | _ -> aux new_env new_diff None remaining_dom new_univ - ) @@ - filter univ tl - | Ko (loc,msg),_ -> ([],[loc,msg]) @@ filter univ tl) - in - filter base_univ choices - in - let base_univ = initial_ugraph in - try - let res = - match aux aliases [] None todo_dom base_univ with - | [],errors -> raise (NoWellTypedInterpretation (0,errors)) - | [_,diff,metasenv,t,ugraph],_ -> - debug_print (lazy "SINGLE INTERPRETATION"); - [diff,metasenv,t,ugraph], false - | l,_ -> - debug_print (lazy (sprintf "MANY INTERPRETATIONS (%d)" (List.length l))); - let choices = - List.map - (fun (env, _, _, _, _) -> - List.map - (fun domain_item -> - let description = - fst (Environment.find domain_item env) - in - (descr_of_domain_item domain_item, description)) - thing_dom) - l - in - let choosed = C.interactive_interpretation_choice choices in - (List.map (fun n->let _,d,m,t,u= List.nth l n in d,m,t,u) choosed), - true - in - res - with - CicEnvironment.CircularDependency s -> - failwith "Disambiguate: circular dependency" - - let disambiguate_term ?(fresh_instances=false) ~dbd ~context ~metasenv - ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases ~universe term - = - let term = - if fresh_instances then CicNotationUtil.freshen_term term else term - in - disambiguate_thing ~dbd ~context ~metasenv ~initial_ugraph ~aliases - ~universe ~uri:None ~pp_thing:CicNotationPp.pp_term - ~domain_of_thing:domain_of_term ~interpretate_thing:interpretate_term - ~refine_thing:refine_term term - - let disambiguate_obj ?(fresh_instances=false) ~dbd ~aliases ~universe ~uri - obj - = - let obj = - if fresh_instances then CicNotationUtil.freshen_obj obj else obj - in - disambiguate_thing ~dbd ~context:[] ~metasenv:[] ~aliases ~universe ~uri - ~pp_thing:CicNotationPp.pp_obj ~domain_of_thing:domain_of_obj - ~interpretate_thing:interpretate_obj ~refine_thing:refine_obj - obj - end - diff --git a/helm/ocaml/cic_disambiguation/disambiguate.mli b/helm/ocaml/cic_disambiguation/disambiguate.mli deleted file mode 100644 index a2cc0d0e7..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguate.mli +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(** {2 Disambiguation interface} *) - -(* the integer is an offset to be added to each location *) -exception NoWellTypedInterpretation of - int * (Token.flocation option * string Lazy.t) list -exception PathNotWellFormed - -val interpretate_path : - context:Cic.name list -> CicNotationPt.term -> - Cic.term - -module type Disambiguator = -sig - (** @param fresh_instances when set to true fresh instances will be generated - * for each number _and_ symbol in the disambiguation domain. Instances of the - * input AST will be ignored. Defaults to false. *) - val disambiguate_term : - ?fresh_instances:bool -> - dbd:HMysql.dbd -> - context:Cic.context -> - metasenv:Cic.metasenv -> - ?initial_ugraph:CicUniv.universe_graph -> - aliases:DisambiguateTypes.environment ->(* previous interpretation status *) - universe:DisambiguateTypes.multiple_environment option -> - CicNotationPt.term -> - ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * - Cic.metasenv * (* new metasenv *) - Cic.term * - CicUniv.universe_graph) list * (* disambiguated term *) - bool (* has interactive_interpretation_choice been invoked? *) - - (** @param fresh_instances as per disambiguate_term *) - val disambiguate_obj : - ?fresh_instances:bool -> - dbd:HMysql.dbd -> - aliases:DisambiguateTypes.environment ->(* previous interpretation status *) - universe:DisambiguateTypes.multiple_environment option -> - uri:UriManager.uri option -> (* required only for inductive types *) - CicNotationPt.obj -> - ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * - Cic.metasenv * (* new metasenv *) - Cic.obj * - CicUniv.universe_graph) list * (* disambiguated obj *) - bool (* has interactive_interpretation_choice been invoked? *) -end - -module Make (C : DisambiguateTypes.Callbacks) : Disambiguator - diff --git a/helm/ocaml/cic_disambiguation/disambiguateChoices.ml b/helm/ocaml/cic_disambiguation/disambiguateChoices.ml deleted file mode 100644 index bdbc93179..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguateChoices.ml +++ /dev/null @@ -1,69 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open DisambiguateTypes - -exception Choice_not_found of string Lazy.t - -let num_choices = ref [] - -let add_num_choice choice = num_choices := choice :: !num_choices - -let has_description dsc = (fun x -> fst x = dsc) - -let lookup_num_choices () = !num_choices - -let lookup_num_by_dsc dsc = - try - List.find (has_description dsc) !num_choices - with Not_found -> raise (Choice_not_found (lazy ("Num with dsc " ^ dsc))) - -let mk_choice (dsc, args, appl_pattern) = - dsc, - (fun env _ cic_args -> - let env' = - let names = - List.map (function CicNotationPt.IdentArg (_, name) -> name) args - in - try - List.combine names cic_args - with Invalid_argument _ -> - raise (Invalid_choice (lazy "The notation expects a different number of arguments")) - in - TermAcicContent.instantiate_appl_pattern env' appl_pattern) - -let lookup_symbol_by_dsc symbol dsc = - try - mk_choice - (List.find - (fun (dsc', _, _) -> dsc = dsc') - (TermAcicContent.lookup_interpretations symbol)) - with TermAcicContent.Interpretation_not_found | Not_found -> - raise (Choice_not_found (lazy (sprintf "Symbol %s, dsc %s" symbol dsc))) - diff --git a/helm/ocaml/cic_disambiguation/disambiguateChoices.mli b/helm/ocaml/cic_disambiguation/disambiguateChoices.mli deleted file mode 100644 index 0ad498106..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguateChoices.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -open DisambiguateTypes - -(** {2 Choice registration low-level interface} *) - - (** raised by lookup_XXXX below *) -exception Choice_not_found of string Lazy.t - - (** register a new number choice *) -val add_num_choice: codomain_item -> unit - -(** {2 Choices lookup} - * for user defined aliases *) - -val lookup_num_choices: unit -> codomain_item list - - (** @param dsc description (1st component of codomain_item) *) -val lookup_num_by_dsc: string -> codomain_item - - (** @param symbol symbol as per AST - * @param dsc description (1st component of codomain_item) - *) -val lookup_symbol_by_dsc: string -> string -> codomain_item - -val mk_choice: - string * CicNotationPt.argument_pattern list * - CicNotationPt.cic_appl_pattern -> - codomain_item - diff --git a/helm/ocaml/cic_disambiguation/disambiguateTypes.ml b/helm/ocaml/cic_disambiguation/disambiguateTypes.ml deleted file mode 100644 index 4a2e43a20..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguateTypes.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -(* -type term = CicNotationPt.term -type tactic = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactic -type tactical = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactical -type script_entry = - | Command of tactical - | Comment of CicNotationPt.location * string -type script = CicNotationPt.location * script_entry list -*) - -type domain_item = - | Id of string (* literal *) - | Symbol of string * int (* literal, instance num *) - | Num of int (* instance num *) - -exception Invalid_choice of string Lazy.t - -module OrderedDomain = - struct - type t = domain_item - let compare = Pervasives.compare - end - -(* module Domain = Set.Make (OrderedDomain) *) -module Environment = -struct - module Environment' = Map.Make (OrderedDomain) - - include Environment' - - let cons k v env = - try - let current = find k env in - let dsc, _ = v in - add k (v :: (List.filter (fun (dsc', _) -> dsc' <> dsc) current)) env - with Not_found -> - add k [v] env - - let hd list_env = - try - map List.hd list_env - with Failure _ -> assert false - - let fold_flatten f env base = - fold - (fun k l acc -> List.fold_right (fun v acc -> f k v acc) l acc) - env base - -end - -type codomain_item = - string * (* description *) - (environment -> string -> Cic.term list -> Cic.term) - (* environment, literal number, arguments as needed *) - -and environment = codomain_item Environment.t - -type multiple_environment = codomain_item list Environment.t - - -(** adds a (name,uri) list l to a disambiguation environment e **) -let multiple_env_of_list l e = - List.fold_left - (fun e (name,descr,t) -> Environment.cons (Id name) (descr,fun _ _ _ -> t) e) - e l - -let env_of_list l e = - List.fold_left - (fun e (name,descr,t) -> Environment.add (Id name) (descr,fun _ _ _ -> t) e) - e l - -module type Callbacks = - sig - val interactive_user_uri_choice: - selection_mode:[`SINGLE | `MULTIPLE] -> - ?ok:string -> - ?enable_button_for_non_vars:bool -> - title:string -> msg:string -> id:string -> UriManager.uri list -> - UriManager.uri list - val interactive_interpretation_choice: - (string * string) list list -> int list - val input_or_locate_uri: - title:string -> ?id:string -> unit -> UriManager.uri - end - -let string_of_domain_item = function - | Id s -> Printf.sprintf "ID(%s)" s - | Symbol (s, i) -> Printf.sprintf "SYMBOL(%s,%d)" s i - | Num i -> Printf.sprintf "NUM(instance %d)" i - -let string_of_domain dom = - String.concat "; " (List.map string_of_domain_item dom) diff --git a/helm/ocaml/cic_disambiguation/disambiguateTypes.mli b/helm/ocaml/cic_disambiguation/disambiguateTypes.mli deleted file mode 100644 index 4f4b3c3ec..000000000 --- a/helm/ocaml/cic_disambiguation/disambiguateTypes.mli +++ /dev/null @@ -1,96 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -type domain_item = - | Id of string (* literal *) - | Symbol of string * int (* literal, instance num *) - | Num of int (* instance num *) - -(* module Domain: Set.S with type elt = domain_item *) -module Environment: -sig - include Map.S with type key = domain_item - val cons: domain_item -> ('a * 'b) -> ('a * 'b) list t -> ('a * 'b) list t - val hd: 'a list t -> 'a t - - (** last alias cons-ed will be processed first *) - val fold_flatten: (domain_item -> 'a -> 'b -> 'b) -> 'a list t -> 'b -> 'b -end - - (** to be raised when a choice is invalid due to some given parameter (e.g. - * wrong number of Cic.term arguments received) *) -exception Invalid_choice of string Lazy.t - -type codomain_item = - string * (* description *) - (environment -> string -> Cic.term list -> Cic.term) - (* environment, literal number, arguments as needed *) - -and environment = codomain_item Environment.t - -type multiple_environment = codomain_item list Environment.t - -(* a simple case of extension of a disambiguation environment *) -val env_of_list: - (string * string * Cic.term) list -> environment -> environment - -val multiple_env_of_list: - (string * string * Cic.term) list -> multiple_environment -> - multiple_environment - -module type Callbacks = - sig - - val interactive_user_uri_choice : - selection_mode:[`SINGLE | `MULTIPLE] -> - ?ok:string -> - ?enable_button_for_non_vars:bool -> - title:string -> msg:string -> id:string -> UriManager.uri list -> - UriManager.uri list - - val interactive_interpretation_choice : - (string * string) list list -> int list - - (** @param title gtk window title for user prompting - * @param id unbound identifier which originated this callback invocation *) - val input_or_locate_uri: - title:string -> ?id:string -> unit -> UriManager.uri - end - -val string_of_domain_item: domain_item -> string -val string_of_domain: domain_item list -> string - -(** {3 type shortands} *) - -(* -type term = CicNotationPt.term -type tactic = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactic -type tactical = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactical - -type script_entry = - | Command of tactical - | Comment of CicNotationPt.location * string -type script = CicNotationPt.location * script_entry list -*) diff --git a/helm/ocaml/cic_disambiguation/doc/precedence.txt b/helm/ocaml/cic_disambiguation/doc/precedence.txt deleted file mode 100644 index 09efea853..000000000 --- a/helm/ocaml/cic_disambiguation/doc/precedence.txt +++ /dev/null @@ -1,32 +0,0 @@ - -Input Should be parsed as Derived constraint - on precedence --------------------------------------------------------------------------------- -\lambda x.x y \lambda x.(x y) lambda > apply -S x = y (= (S x) y) apply > infix operators -\forall x.x=x (\forall x.(= x x)) infix operators > binders -\lambda x.x \to x \lambda. (x \to x) \to > \lambda --------------------------------------------------------------------------------- - -Precedence total order: - - apply > infix operators > to > binders - -where binders are all binders except lambda (i.e. \forall, \pi, \exists) - -to test: - -./test_parser term << EOT - \lambda x.x y - S x = y - \forall x.x=x - \lambda x.x \to x -EOT - -should respond with: - - \lambda x.(x y) - (eq (S x) y) - \forall x.(eq x x) - \lambda x.(x \to x) - diff --git a/helm/ocaml/cic_disambiguation/number_notation.ml b/helm/ocaml/cic_disambiguation/number_notation.ml deleted file mode 100644 index 2b3ce2d60..000000000 --- a/helm/ocaml/cic_disambiguation/number_notation.ml +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let _ = - DisambiguateChoices.add_num_choice - ("natural number", - (fun _ num _ -> HelmLibraryObjects.build_nat (int_of_string num))); - DisambiguateChoices.add_num_choice - ("real number", - (fun _ num _ -> HelmLibraryObjects.build_real (int_of_string num))); - DisambiguateChoices.add_num_choice - ("binary positive number", - (fun _ num _ -> - let num = int_of_string num in - if num = 0 then - raise (DisambiguateTypes.Invalid_choice (lazy "0 is not a valid positive number")) - else - HelmLibraryObjects.build_bin_pos num)); - DisambiguateChoices.add_num_choice - ("binary integer number", - (fun _ num _ -> - let num = int_of_string num in - if num = 0 then - HelmLibraryObjects.BinInt.z0 - else if num > 0 then - Cic.Appl [ - HelmLibraryObjects.BinInt.zpos; - HelmLibraryObjects.build_bin_pos num ] - else - assert false)) - diff --git a/helm/ocaml/cic_disambiguation/tests/aliases.txt b/helm/ocaml/cic_disambiguation/tests/aliases.txt deleted file mode 100644 index 12b09fff1..000000000 --- a/helm/ocaml/cic_disambiguation/tests/aliases.txt +++ /dev/null @@ -1,6 +0,0 @@ -alias id foo = cic:/a.con -alias id bar = cic:/b.con -alias symbol "plus" (instance 0) = "real plus" -alias symbol "plus" (instance 1) = "natural plus" -alias num (instance 0) = "real number" -alias num (instance 1) = "natural number" diff --git a/helm/ocaml/cic_disambiguation/tests/eq.txt b/helm/ocaml/cic_disambiguation/tests/eq.txt deleted file mode 100644 index 6a826fc71..000000000 --- a/helm/ocaml/cic_disambiguation/tests/eq.txt +++ /dev/null @@ -1 +0,0 @@ -\forall n. \forall m. n + m = n diff --git a/helm/ocaml/cic_disambiguation/tests/match.txt b/helm/ocaml/cic_disambiguation/tests/match.txt deleted file mode 100644 index 87bb0159b..000000000 --- a/helm/ocaml/cic_disambiguation/tests/match.txt +++ /dev/null @@ -1,49 +0,0 @@ -[\lambda x:nat. - [\lambda y:nat. Set] - match x:nat with [ O \Rightarrow nat | (S x) \Rightarrow bool ]] -match (S O):nat with -[ O \Rightarrow O -| (S x) \Rightarrow false ] - -[\lambda z:nat. \lambda h:(le O z). (eq nat O O)] -match (le_n O): le with -[ le_n \Rightarrow (refl_equal nat O) -| (le_S x y) \Rightarrow (refl_equal nat O) ] - -[\lambda z:nat. \lambda h:(le (plus (plus O O) (plus O O)) z). (eq nat (plus (plus O O) (plus O O)) (plus (plus O O) (plus O O)))] -match (le_n (plus (plus O O) (plus O O))): le with -[ le_n \Rightarrow (refl_equal nat (plus (plus O O) (plus O O))) -| (le_S x y) \Rightarrow (refl_equal nat (plus (plus O O) (plus O O))) ] - -(* -[\lambda z:nat. \lambda h:(le 1 z). (le 0 z)] -match (le_S 2 (le_n 1)): le with -[ le_n \Rightarrow (le_S 1 (le_n 0)) -| (le_S x y) \Rightarrow y ] -*) - -[\lambda z:nat. \lambda h:(le 0 z). (le 0 (S z))] -match (le_S 0 0 (le_n 0)): le with -[ le_n \Rightarrow (le_S 0 0 (le_n 0)) -| (le_S x y) \Rightarrow (le_S 0 (S x) (le_S 0 x y)) ] - - -[\lambda x:bool. nat] -match true:bool with -[ true \Rightarrow O -| false \Rightarrow (S O) ] - -[\lambda x:nat. nat] -match O:nat with -[ O \Rightarrow O -| (S x) \Rightarrow (S (S x)) ] - -[\lambda x:list. list] -match nil:list with -[ nil \Rightarrow nil -| (cons x y) \Rightarrow (cons x y) ] - -\lambda x:False. - [\lambda h:False. True] - match x:False with [] - diff --git a/helm/ocaml/cic_proof_checking/.depend b/helm/ocaml/cic_proof_checking/.depend deleted file mode 100644 index 06b9188a0..000000000 --- a/helm/ocaml/cic_proof_checking/.depend +++ /dev/null @@ -1,24 +0,0 @@ -cicLogger.cmo: cicLogger.cmi -cicLogger.cmx: cicLogger.cmi -cicEnvironment.cmo: cicEnvironment.cmi -cicEnvironment.cmx: cicEnvironment.cmi -cicPp.cmo: cicEnvironment.cmi cicPp.cmi -cicPp.cmx: cicEnvironment.cmx cicPp.cmi -cicUnivUtils.cmo: cicEnvironment.cmi cicUnivUtils.cmi -cicUnivUtils.cmx: cicEnvironment.cmx cicUnivUtils.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 -cicReduction.cmo: cicSubstitution.cmi cicPp.cmi cicEnvironment.cmi \ - cicReduction.cmi -cicReduction.cmx: cicSubstitution.cmx cicPp.cmx cicEnvironment.cmx \ - cicReduction.cmi -cicTypeChecker.cmo: cicUnivUtils.cmi cicSubstitution.cmi cicReduction.cmi \ - cicPp.cmi cicLogger.cmi cicEnvironment.cmi cicTypeChecker.cmi -cicTypeChecker.cmx: cicUnivUtils.cmx cicSubstitution.cmx cicReduction.cmx \ - cicPp.cmx cicLogger.cmx cicEnvironment.cmx cicTypeChecker.cmi -freshNamesGenerator.cmo: cicTypeChecker.cmi cicSubstitution.cmi \ - freshNamesGenerator.cmi -freshNamesGenerator.cmx: cicTypeChecker.cmx cicSubstitution.cmx \ - freshNamesGenerator.cmi diff --git a/helm/ocaml/cic_proof_checking/Makefile b/helm/ocaml/cic_proof_checking/Makefile deleted file mode 100644 index 8e2f99a15..000000000 --- a/helm/ocaml/cic_proof_checking/Makefile +++ /dev/null @@ -1,43 +0,0 @@ - -PACKAGE = cic_proof_checking -PREDICATES = - -REDUCTION_IMPLEMENTATION = cicReductionMachine.ml - -INTERFACE_FILES = \ - cicLogger.mli \ - cicEnvironment.mli \ - cicPp.mli \ - cicUnivUtils.mli \ - cicSubstitution.mli \ - cicMiniReduction.mli \ - cicReduction.mli \ - cicTypeChecker.mli \ - freshNamesGenerator.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -# Metadata tools only need zeta-reduction -EXTRA_OBJECTS_TO_INSTALL = \ - cicSubstitution.cmo cicSubstitution.cmx cicSubstitution.o \ - cicMiniReduction.cmo cicMiniReduction.cmx cicMiniReduction.o -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common - -cicReduction.cmo: OCAMLOPTIONS+=-rectypes -cicReduction.cmx: OCAMLOPTIONS+=-rectypes - -all: all_utilities -opt: opt_utilities - -all_utilities: - @$(MAKE) -C utilities/ all -opt_utilities: - @$(MAKE) -C utilities/ opt - -clean: clean_utilities -clean_utilities: - @$(MAKE) -C utilities/ clean - diff --git a/helm/ocaml/cic_proof_checking/cicEnvironment.ml b/helm/ocaml/cic_proof_checking/cicEnvironment.ml deleted file mode 100644 index 1f6789e76..000000000 --- a/helm/ocaml/cic_proof_checking/cicEnvironment.ml +++ /dev/null @@ -1,545 +0,0 @@ -(* 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 *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a trival cache system (an hash-table) for cic *) -(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -(* ************************************************************************** * - CicEnvironment SETTINGS (trust and clean_tmp) - * ************************************************************************** *) - -let cleanup_tmp = true;; -let trust = ref (fun _ -> true);; -let set_trust f = trust := f -let trust_obj uri = !trust uri -let debug_print = fun x -> prerr_endline (Lazy.force x) - -(* ************************************************************************** * - TYPES - * ************************************************************************** *) - -type type_checked_obj = - CheckedObj of (Cic.obj * CicUniv.universe_graph) (* cooked obj *) - | UncheckedObj of Cic.obj (* uncooked obj to proof-check *) -;; - -exception AlreadyCooked of string;; -exception CircularDependency of string Lazy.t;; -exception CouldNotFreeze of string;; -exception CouldNotUnfreeze of string;; -exception Object_not_found of UriManager.uri;; - - -(* ************************************************************************** * - HERE STARTS THE CACHE MODULE - * ************************************************************************** *) - -(* I think this should be the right place to implement mecanisms and - * invasriants - *) - -(* Cache that uses == instead of = for testing equality *) -(* Invariant: an object is always in at most one of the *) -(* following states: unchecked, frozen and cooked. *) -module Cache : - sig - val find_or_add_to_unchecked : - UriManager.uri -> - get_object_to_add: - (UriManager.uri -> - Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option) -> - Cic.obj * CicUniv.universe_graph * CicUniv.universe list - val can_be_cooked: - UriManager.uri -> bool - val unchecked_to_frozen : - UriManager.uri -> unit - val frozen_to_cooked : - uri:UriManager.uri -> unit - val hack_univ: - UriManager.uri -> CicUniv.universe_graph * CicUniv.universe list -> unit - val find_cooked : - key:UriManager.uri -> - Cic.obj * CicUniv.universe_graph * CicUniv.universe list - val add_cooked : - key:UriManager.uri -> - (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit - val remove: UriManager.uri -> unit - val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit - val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit - val empty : unit -> unit - val is_in_frozen: UriManager.uri -> bool - val is_in_unchecked: UriManager.uri -> bool - val is_in_cooked: UriManager.uri -> bool - val list_all_cooked_uris: unit -> UriManager.uri list - end -= - struct - (************************************************************************* - TASSI: invariant - The cacheOfCookedObjects will contain only objects with a valid universe - graph. valid means that not None (used if there is no universe file - in the universe generation phase). - **************************************************************************) - - (* DATA: the data structure that implements the CACHE *) - module HashedType = - struct - type t = UriManager.uri - let equal = UriManager.eq - let hash = Hashtbl.hash - end - ;; - - module HT = Hashtbl.Make(HashedType);; - - let cacheOfCookedObjects = HT.create 1009;; - - (* DATA: The parking lists - * the lists elements are (uri * (obj * universe_graph option)) - * ( u, ( o, None )) means that the object has no universes file, this - * should happen only in the universe generation phase. - * FIXME: if the universe generation is integrated in the library - * exportation phase, the 'option' MUST be removed. - * ( u, ( o, Some g)) means that the object has a universes file, - * the usual case. - *) - - (* frozen is used to detect circular dependency. *) - let frozen_list = ref [];; - (* unchecked is used to store objects just fetched, nothing more. *) - let unchecked_list = ref [];; - - let empty () = - HT.clear cacheOfCookedObjects; - unchecked_list := [] ; - frozen_list := [] - ;; - - (* FIX: universe stuff?? *) - let dump_to_channel ?(callback = ignore) oc = - HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) - cacheOfCookedObjects; - Marshal.to_channel oc cacheOfCookedObjects [] - ;; - - (* FIX: universes stuff?? *) - let restore_from_channel ?(callback = ignore) ic = - let restored = Marshal.from_channel ic in - (* FIXME: should this empty clean the frozen and unchecked? - * if not, the only-one-empty-end-not-3 patch is wrong - *) - empty (); - HT.iter - (fun k (v,u,l) -> - callback (UriManager.string_of_uri k); - let reconsed_entry = - CicUtil.rehash_obj v, - CicUniv.recons_graph u, - List.map CicUniv.recons_univ l - in - HT.add cacheOfCookedObjects - (UriManager.uri_of_string (UriManager.string_of_uri k)) - reconsed_entry) - restored - ;; - - - let is_in_frozen uri = - List.mem_assoc uri !frozen_list - ;; - - let is_in_unchecked uri = - List.mem_assoc uri !unchecked_list - ;; - - let is_in_cooked uri = - HT.mem cacheOfCookedObjects uri - ;; - - - (******************************************************************* - TASSI: invariant - we need, in the universe generation phase, to traverse objects - that are not yet committed, so we search them in the frozen list. - Only uncommitted objects without a universe file (see the assertion) - can be searched with method - *******************************************************************) - - let find_or_add_to_unchecked uri ~get_object_to_add = - try - let o,g_and_l = List.assq uri !unchecked_list in - match g_and_l with - (* FIXME: we accept both cases, as at the end of this function - * maybe the None universe outside the cache module should be - * avoided elsewhere. - * - * another thing that should be removed if univ generation phase - * and lib exportation are unified. - *) - | None -> o,CicUniv.empty_ugraph,[] - | Some (g,l) -> o,g,l - with - Not_found -> - if List.mem_assq uri !frozen_list then - (* CIRCULAR DEPENDENCY DETECTED, print the error and raise *) - begin - print_endline "\nCircularDependency!\nfrozen list: \n"; - List.iter ( - fun (u,(_,o)) -> - let su = UriManager.string_of_uri u in - let univ = if o = None then "NO_UNIV" else "" in - print_endline (su^" "^univ)) - !frozen_list; - raise (CircularDependency (lazy (UriManager.string_of_uri uri))) - end - else - if HT.mem cacheOfCookedObjects uri then - (* DOUBLE COOK DETECTED, raise the exception *) - raise (AlreadyCooked (UriManager.string_of_uri uri)) - else - (* OK, it is not already frozen nor cooked *) - let obj,ugraph_and_univlist = get_object_to_add uri in - let ugraph_real, univlist_real = - match ugraph_and_univlist with - (* FIXME: not sure it is OK*) - None -> CicUniv.empty_ugraph, [] - | Some ((g,l) as g_and_l) -> g_and_l - in - unchecked_list := - (uri,(obj,ugraph_and_univlist))::!unchecked_list ; - obj, ugraph_real, univlist_real - ;; - - let unchecked_to_frozen uri = - try - let obj,ugraph_and_univlist = List.assq uri !unchecked_list in - unchecked_list := List.remove_assq uri !unchecked_list ; - frozen_list := (uri,(obj,ugraph_and_univlist))::!frozen_list - with - Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri)) - ;; - - - (************************************************************ - TASSI: invariant - only object with a valid universe graph can be committed - - this should disappear if the universe generation phase and the - library exportation are unified. - *************************************************************) - let frozen_to_cooked ~uri = - try - let obj,ugraph_and_univlist = List.assq uri !frozen_list in - match ugraph_and_univlist with - | None -> assert false (* only NON dummy universes can be committed *) - | Some (g,l) -> - CicUniv.assert_univs_have_uri g l; - frozen_list := List.remove_assq uri !frozen_list ; - HT.add cacheOfCookedObjects uri (obj,g,l) - with - Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri)) - ;; - - let can_be_cooked uri = - try - let obj,ugraph_and_univlist = List.assq uri !frozen_list in - (* FIXME: another thing to remove if univ generation phase and lib - * exportation are unified. - *) - match ugraph_and_univlist with - None -> false - | Some _ -> true - with - Not_found -> false - ;; - - (* this function injects a real universe graph in a (uri, (obj, None)) - * element of the frozen list. - * - * FIXME: another thing to remove if univ generation phase and lib - * exportation are unified. - *) - let hack_univ uri (real_ugraph, real_univlist) = - try - let o,ugraph_and_univlist = List.assq uri !frozen_list in - match ugraph_and_univlist with - None -> - frozen_list := List.remove_assoc uri !frozen_list; - frozen_list := - (uri,(o,Some (real_ugraph, real_univlist)))::!frozen_list; - | Some g -> - debug_print (lazy ( - "You are probably hacking an object already hacked or an"^ - " object that has the universe file but is not"^ - " yet committed.")); - assert false - with - Not_found -> - debug_print (lazy ( - "You are hacking an object that is not in the"^ - " frozen_list, this means you are probably generating an"^ - " universe file for an object that already"^ - " as an universe file")); - assert false - ;; - - let find_cooked ~key:uri = HT.find cacheOfCookedObjects uri ;; - - let add_cooked ~key:uri (obj,ugraph,univlist) = - HT.add cacheOfCookedObjects uri (obj,ugraph,univlist) - ;; - - (* invariant - * - * an object can be romeved from the cache only if we are not typechecking - * something. this means check and frozen must be empty. - *) - let remove uri = - if !frozen_list <> [] then - failwith "CicEnvironment.remove while type checking" - else - begin - HT.remove cacheOfCookedObjects uri; - unchecked_list := - List.filter (fun (uri',_) -> not (UriManager.eq uri uri')) !unchecked_list - end - ;; - - let list_all_cooked_uris () = - HT.fold (fun u _ l -> u::l) cacheOfCookedObjects [] - ;; - - end -;; - -(* ************************************************************************ - HERE ENDS THE CACHE MODULE - * ************************************************************************ *) - -(* exported cache functions *) -let dump_to_channel = Cache.dump_to_channel;; -let restore_from_channel = Cache.restore_from_channel;; -let empty = Cache.empty;; - -let total_parsing_time = ref 0.0 - -let get_object_to_add uri = - try - let filename = Http_getter.getxml' uri in - let bodyfilename = - match UriManager.bodyuri_of_uri uri with - None -> None - | Some bodyuri -> - if Http_getter.exists' bodyuri then - Some (Http_getter.getxml' bodyuri) - else - None - in - let obj = - try - let time = Unix.gettimeofday() in - let rc = CicParser.obj_of_xml uri filename bodyfilename in - total_parsing_time := - !total_parsing_time +. ((Unix.gettimeofday()) -. time ); - rc - with exn -> - (match exn with - | CicParser.Getter_failure ("key_not_found", uri) -> - raise (Object_not_found (UriManager.uri_of_string uri)) - | _ -> raise exn) - in - let ugraph_and_univlist,filename_univ = - try - let filename_univ = - let univ_uri = UriManager.univgraphuri_of_uri uri in - Http_getter.getxml' univ_uri - in - Some (CicUniv.ugraph_and_univlist_of_xml filename_univ), - Some filename_univ - with - | Http_getter_types.Key_not_found _ - | Http_getter_types.Unresolvable_URI _ -> - debug_print (lazy ( - "WE HAVE NO UNIVERSE FILE FOR " ^ (UriManager.string_of_uri uri))); - (* WE SHOULD FAIL (or return None, None *) - Some (CicUniv.empty_ugraph, []), None - in - obj, ugraph_and_univlist - with Http_getter_types.Key_not_found _ -> raise (Object_not_found uri) -;; - -(* this is the function to fetch the object in the unchecked list and - * nothing more (except returning it) - *) -let find_or_add_to_unchecked uri = - Cache.find_or_add_to_unchecked uri ~get_object_to_add - -(* set_type_checking_info uri *) -(* must be called once the type-checking of uri is finished *) -(* The object whose uri is uri is unfreezed *) -(* *) -(* the replacement ugraph must be the one returned by the *) -(* typechecker, restricted with the CicUnivUtils.clean_and_fill *) -let set_type_checking_info ?(replace_ugraph_and_univlist=None) uri = -(* - if not (Cache.can_be_cooked uri) && replace_ugraph <> None then begin - debug_print (lazy ( - "?replace_ugraph must be None if you are not committing an "^ - "object that has a universe graph associated "^ - "(can happen only in the fase of universes graphs generation).")); - assert false - else -*) - match Cache.can_be_cooked uri, replace_ugraph_and_univlist with - | true, Some _ - | false, None -> - debug_print (lazy ( - "?replace_ugraph must be (Some ugraph) when committing an object that "^ - "has no associated universe graph. If this is in make_univ phase you "^ - "should drop this exception and let univ_make commit thi object with "^ - "proper arguments")); - assert false - | _ -> - (match replace_ugraph_and_univlist with - | None -> () - | Some g_and_l -> Cache.hack_univ uri g_and_l); - Cache.frozen_to_cooked uri -;; - -(* fetch, unfreeze and commit an uri to the cacheOfCookedObjects and - * return the object,ugraph - *) -let add_trusted_uri_to_cache uri = - let _ = find_or_add_to_unchecked uri in - Cache.unchecked_to_frozen uri; - set_type_checking_info uri; - try - Cache.find_cooked uri - with Not_found -> assert false -;; - -(* get the uri, if we trust it will be added to the cacheOfCookedObjects *) -let get_cooked_obj_with_univlist ?(trust=true) base_ugraph uri = - try - (* the object should be in the cacheOfCookedObjects *) - let o,u,l = Cache.find_cooked uri in - o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l - with Not_found -> - (* this should be an error case, but if we trust the uri... *) - if trust && trust_obj uri then - (* trusting means that we will fetch cook it on the fly *) - let o,u,l = add_trusted_uri_to_cache uri in - o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l - else - (* we don't trust the uri, so we fail *) - begin - debug_print (lazy ("CACHE MISS: " ^ (UriManager.string_of_uri uri))); - raise Not_found - end - -let get_cooked_obj ?trust base_ugraph uri = - let o,g,_ = get_cooked_obj_with_univlist ?trust base_ugraph uri in - o,g - -(* This has not the old semantic :( but is what the name suggests - * - * let is_type_checked ?(trust=true) uri = - * try - * let _ = Cache.find_cooked uri in - * true - * with - * Not_found -> - * trust && trust_obj uri - * ;; - * - * as the get_cooked_obj but returns a type_checked_obj - * - *) -let is_type_checked ?(trust=true) base_ugraph uri = - try - let o,u,_ = Cache.find_cooked uri in - CheckedObj (o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))) - with Not_found -> - (* this should return UncheckedObj *) - if trust && trust_obj uri then - (* trusting means that we will fetch cook it on the fly *) - let o,u,_ = add_trusted_uri_to_cache uri in - CheckedObj ( o, CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)) - else - let o,u,_ = find_or_add_to_unchecked uri in - Cache.unchecked_to_frozen uri; - UncheckedObj o -;; - -(* as the get cooked, but if not present the object is only fetched, - * not unfreezed and committed - *) -let get_obj base_ugraph uri = - try - (* the object should be in the cacheOfCookedObjects *) - let o,u,_ = Cache.find_cooked uri in - o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)) - with Not_found -> - (* this should be an error case, but if we trust the uri... *) - let o,u,_ = find_or_add_to_unchecked uri in - o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)) -;; - -let in_cache uri = - Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri - -let add_type_checked_obj uri (obj,ugraph,univlist) = - Cache.add_cooked ~key:uri (obj,ugraph,univlist) - -let in_library uri = in_cache uri || Http_getter.exists' uri - -let remove_obj = Cache.remove - -let list_uri () = - Cache.list_all_cooked_uris () -;; - -let list_obj () = - try - List.map (fun u -> - let o,ug = get_obj CicUniv.empty_ugraph u in - (u,o,ug)) - (list_uri ()) - with - Not_found -> - debug_print (lazy "Who has removed the uri in the meanwhile?"); - raise Not_found -;; diff --git a/helm/ocaml/cic_proof_checking/cicEnvironment.mli b/helm/ocaml/cic_proof_checking/cicEnvironment.mli deleted file mode 100644 index 55566a614..000000000 --- a/helm/ocaml/cic_proof_checking/cicEnvironment.mli +++ /dev/null @@ -1,136 +0,0 @@ -(* 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 *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a trival cache system (an hash-table) for cic *) -(* ^^^^^^ *) -(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) -(* *) -(****************************************************************************) - -exception CircularDependency of string Lazy.t;; -exception Object_not_found of UriManager.uri;; - -(* as the get cooked, but if not present the object is only fetched, - * not unfreezed and committed - *) -val get_obj : - CicUniv.universe_graph -> UriManager.uri -> - Cic.obj * CicUniv.universe_graph - -type type_checked_obj = - CheckedObj of (Cic.obj * CicUniv.universe_graph) (* cooked obj *) - | UncheckedObj of Cic.obj (* uncooked obj *) - -(* - * I think this should be the real semantic: - * - * val is_type_checked: - * ?trust:bool -> UriManager.uri -> bool - * - * but the old semantic is similar to get_cooked_obj, but - * returns an unchecked object intead of a Not_found - *) -val is_type_checked : - ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> - type_checked_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 and won't be type-checked *) -(* again in the future (is_type_checked will return true) *) -(* *) -(* Since the universes are not exported directly, but generated *) -(* typecheking the library, we can't find them in the library as we *) -(* do for the types. This means that when we commit uris during *) -(* univ generation we can't associate the uri with the universe graph *) -(* we find in the library, we have to calculate it and then inject it *) -(* in the cacke. This is an orrible backdoor used by univ_maker. *) -(* see the .ml file for some reassuring invariants *) -(* WARNING: THIS FUNCTION MUST BE CALLED ONLY BY CicTypeChecker *) -val set_type_checking_info : - ?replace_ugraph_and_univlist: - ((CicUniv.universe_graph * CicUniv.universe list) option) -> - UriManager.uri -> unit - -(* this function is called by CicTypeChecker.typecheck_obj to add to the *) -(* environment a new well typed object that is not yet in the library *) -(* WARNING: THIS FUNCTION MUST BE CALLED ONLY BY CicTypeChecker *) -val add_type_checked_obj : - UriManager.uri -> - (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit - - (** remove a type checked object - * @raise Object_not_found when given term is not in the environment - * @raise Failure when remove_term is invoked while type checking *) -val remove_obj: UriManager.uri -> unit - -(* 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 -> CicUniv.universe_graph -> UriManager.uri -> - Cic.obj * CicUniv.universe_graph - -(* get_cooked_obj_with_univlist ~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_with_univlist : - ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> - Cic.obj * CicUniv.universe_graph * CicUniv.universe list - -(* FUNCTIONS USED ONLY IN THE TOPLEVEL/PROOF-ENGINE *) - -(* (de)serialization *) -val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit -val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit -val empty : unit -> unit - -(** Set trust function. Per default this function is set to (fun _ -> true) *) -val set_trust: (UriManager.uri -> bool) -> unit - - (** @return true for objects currently cooked/frozend/unchecked, false - * otherwise (i.e. objects already parsed from XML) *) -val in_cache : UriManager.uri -> bool - -(* to debug the matitac batch compiler *) -val list_obj: unit -> (UriManager.uri * Cic.obj * CicUniv.universe_graph) list -val list_uri: unit -> UriManager.uri list - - (** @return true for objects available in the library *) -val in_library: UriManager.uri -> bool - - (** total parsing time, only to benchmark the parser *) -val total_parsing_time: float ref - -(* EOF *) diff --git a/helm/ocaml/cic_proof_checking/cicLogger.ml b/helm/ocaml/cic_proof_checking/cicLogger.ml deleted file mode 100644 index 5921c61b0..000000000 --- a/helm/ocaml/cic_proof_checking/cicLogger.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -type msg = - [ `Start_type_checking of UriManager.uri - | `Type_checking_completed of UriManager.uri - | `Trusting of UriManager.uri - ] - -let log ?(level = 1) = - let module U = UriManager in - function - | `Start_type_checking uri -> - HelmLogger.log (`Msg (`DIV (level, None, `T - ("Type-Checking of " ^ (U.string_of_uri uri) ^ " started")))) - | `Type_checking_completed uri -> - HelmLogger.log (`Msg (`DIV (level, Some "green", `T - ("Type-Checking of " ^ (U.string_of_uri uri) ^ " completed")))) - | `Trusting uri -> - HelmLogger.log (`Msg (`DIV (level, Some "blue", `T - ((U.string_of_uri uri) ^ " is trusted.")))) - -class logger = - object - val mutable level = 0 (* indentation level *) - method log (msg: msg) = - match msg with - | `Start_type_checking _ -> - level <- level + 1; - log ~level msg - | `Type_checking_completed _ -> - log ~level msg; - level <- level - 1; - | _ -> log ~level msg - end - -let log msg = log ~level:1 msg - diff --git a/helm/ocaml/cic_proof_checking/cicLogger.mli b/helm/ocaml/cic_proof_checking/cicLogger.mli deleted file mode 100644 index 408bc8879..000000000 --- a/helm/ocaml/cic_proof_checking/cicLogger.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* 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/. - *) - -type msg = - [ `Start_type_checking of UriManager.uri - | `Type_checking_completed of UriManager.uri - | `Trusting of UriManager.uri - ] - - (** Stateless logging. Each message is logged with indentation level 1 *) -val log: msg -> unit - - (** Stateful logging. Each `Start_type_checing message increase the - * indentation level by 1, each `Type_checking_completed message decrease it by - * the same amount. *) -class logger: - object - method log: msg -> unit - end - diff --git a/helm/ocaml/cic_proof_checking/cicMiniReduction.ml b/helm/ocaml/cic_proof_checking/cicMiniReduction.ml deleted file mode 100644 index 5c88713c5..000000000 --- a/helm/ocaml/cic_proof_checking/cicMiniReduction.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let rec letin_nf = - let module C = Cic in - function - C.Rel _ 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.Cast (te,ty) -> C.Cast (letin_nf te, letin_nf ty) - | C.Prod (n,s,t) -> C.Prod (n, letin_nf s, letin_nf 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 (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 - (fun (name,i,ty,bo) -> (name, i, letin_nf ty, letin_nf bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, letin_nf ty, letin_nf bo)) - fl - in - C.CoFix (i, substitutedfl) -;; diff --git a/helm/ocaml/cic_proof_checking/cicMiniReduction.mli b/helm/ocaml/cic_proof_checking/cicMiniReduction.mli deleted file mode 100644 index c923c6acf..000000000 --- a/helm/ocaml/cic_proof_checking/cicMiniReduction.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* 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 letin_nf : Cic.term -> Cic.term diff --git a/helm/ocaml/cic_proof_checking/cicPp.ml b/helm/ocaml/cic_proof_checking/cicPp.ml deleted file mode 100644 index 954134584..000000000 --- a/helm/ocaml/cic_proof_checking/cicPp.ml +++ /dev/null @@ -1,480 +0,0 @@ -(* 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 *) -(* *) -(* This module implements a very simple Coq-like pretty printer that, given *) -(* an object of cic (internal representation) returns a string describing *) -(* the object in a syntax similar to that of coq *) -(* *) -(* It also contains the utility functions to check a name w.r.t the Matita *) -(* naming policy *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -exception CicPpInternalError;; -exception NotEnoughElements;; - -(* Utility functions *) - -let ppname = - function - Cic.Name s -> s - | Cic.Anonymous -> "_" -;; - -(* get_nth l n returns the nth element of the list l if it exists or *) -(* raises NotEnoughElements if l has less than n elements *) -let rec get_nth l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth tail (n-1) - | (_,_) -> raise NotEnoughElements -;; - -(* pp t l *) -(* pretty-prints a term t of cic in an environment l where l is a list of *) -(* identifier names used to resolve DeBrujin indexes. The head of l is the *) -(* name associated to the greatest DeBrujin index in t *) -let rec pp t l = - let module C = Cic in - match t with - C.Rel n -> - begin - try - (match get_nth l n with - Some (C.Name s) -> s - | Some C.Anonymous -> "__" ^ string_of_int n - | None -> "_hidden_" ^ string_of_int n - ) - with - NotEnoughElements -> string_of_int (List.length l - n) - end - | 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 " ; " - (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^ - "]" - | C.Sort s -> - (match s with - C.Prop -> "Prop" - | C.Set -> "Set" - | C.Type _ -> "Type" - (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*) - | C.CProp -> "CProp" - ) - | C.Implicit (Some `Hole) -> "%" - | C.Implicit _ -> "?" - | C.Prod (b,s,t) -> - (match b with - C.Name n -> "(" ^ n ^ ":" ^ 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 ^ ":" ^ pp t l ^ ")" - | C.Lambda (b,s,t) -> - "(\\lambda " ^ ppname b ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")" - | C.LetIn (b,s,t) -> - "[" ^ ppname b ^ ":=" ^ pp s l ^ "]" ^ pp t ((Some b)::l) - | C.Appl li -> - "(" ^ - (List.fold_right - (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i) - li "" - ) ^ ")" - | 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 fst(CicEnvironment.get_obj CicUniv.empty_ugraph 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 - _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1) - ) - | C.MutConstruct (uri,n1,n2,exp_named_subst) -> - (try - match fst(CicEnvironment.get_obj CicUniv.empty_ugraph 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 - _ -> - UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^ - string_of_int n2 - ) - | C.MutCase (uri,n1,ty,te,patterns) -> - let connames = - (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cons) = get_nth dl (n1+1) in - List.map (fun (id,_) -> id) cons - | _ -> raise CicPpInternalError - ) - in - let connames_and_patterns = - let rec combine = - function - [],[] -> [] - | [],l -> List.map (fun x -> "???",Some x) l - | l,[] -> List.map (fun x -> x,None) l - | x::tlx,y::tly -> (x,Some y)::(combine (tlx,tly)) - in - combine (connames,patterns) - in - "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^ - List.fold_right - (fun (x,y) i -> "\n " ^ x ^ " => " ^ - (match y with None -> "" | Some y -> pp y l) ^ i) - connames_and_patterns "" ^ - "\nend" - | C.Fix (no, funs) -> - let snames = List.map (fun (name,_,_,_) -> name) funs in - let names = - List.rev (List.map (function name -> Some (C.Name name)) snames) - in - "\nFix " ^ get_nth snames (no + 1) ^ " {" ^ - List.fold_right - (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^ - " : " ^ pp ty l ^ " := \n" ^ - pp bo (names@l) ^ i) - funs "" ^ - "}\n" - | C.CoFix (no,funs) -> - let snames = List.map (fun (name,_,_) -> name) funs in - let names = - List.rev (List.map (function name -> Some (C.Name name)) snames) - in - "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^ - List.fold_right - (fun (name,ty,bo) i -> "\n" ^ name ^ - " : " ^ pp ty l ^ " := \n" ^ - pp bo (names@l) ^ i) - funs "" ^ - "}\n" -and pp_exp_named_subst exp_named_subst l = - if exp_named_subst = [] then "" else - "\\subst[" ^ - String.concat " ; " ( - List.map - (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp t l) - exp_named_subst - ) ^ "]" -;; - -let ppterm t = - pp t [] -;; - -(* 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 ^ ": " ^ - pp arity [] ^ " =\n " ^ - List.fold_right - (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^ - (if i = "" then "\n" else "\n | ") ^ i) - cons "" -;; - -let ppcontext ?(sep = "\n") context = - let separate s = if s = "" then "" else s ^ sep in - fst (List.fold_right - (fun context_entry (i,name_context) -> - match context_entry with - Some (n,Cic.Decl t) -> - Printf.sprintf "%s%s : %s" (separate i) (ppname n) - (pp t name_context), (Some n)::name_context - | Some (n,Cic.Def (bo,ty)) -> - Printf.sprintf "%s%s : %s := %s" (separate i) (ppname n) - (match ty with - None -> "_" - | Some ty -> pp ty name_context) - (pp bo name_context), (Some n)::name_context - | None -> - Printf.sprintf "%s_ :? _" (separate i), None::name_context - ) context ("",[])) - -(* ppobj obj returns a string with describing the cic object obj in a syntax *) -(* similar to the one used by Coq *) -let ppobj obj = - let module C = Cic in - let module U = UriManager in - match obj with - 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 -> - let conjectures',name_context = - List.fold_right - (fun context_entry (i,name_context) -> - (match context_entry with - Some (n,C.Decl at) -> - (separate i) ^ - ppname n ^ ":" ^ pp at name_context ^ " ", - (Some n)::name_context - | Some (n,C.Def (at,None)) -> - (separate i) ^ - ppname n ^ ":= " ^ pp at name_context ^ " ", - (Some n)::name_context - | None -> - (separate i) ^ "_ :? _ ", None::name_context - | _ -> assert false) - ) context ("",[]) - in - conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^ - pp t name_context ^ "\n" ^ i - ) conjectures "" ^ - "\n" ^ pp value [] ^ " : " ^ pp ty [] - | C.InductiveDefinition (l, params, nparams, _) -> - "Parameters = " ^ - 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 "" -;; - -let ppsort = function - | Cic.Prop -> "Prop" - | Cic.Set -> "Set" - | Cic.Type _ -> "Type" - | Cic.CProp -> "CProp" - - -(* MATITA NAMING CONVENTION *) - -let is_prefix prefix string = - let len = String.length prefix in - let len1 = String.length string in - if len <= len1 then - begin - let head = String.sub string 0 len in - if - (String.compare (String.lowercase head) (String.lowercase prefix)=0) then - begin - let diff = len1-len in - let tail = String.sub string len diff in - if ((diff > 0) && (String.rcontains_from tail 0 '_')) then - Some (String.sub tail 1 (diff-1)) - else Some tail - end - else None - end - else None - -let remove_prefix prefix (last,string) = - if prefix="append" then - begin - prerr_endline last; - prerr_endline string; - end; - if string = "" then (last,string) - else - match is_prefix prefix string with - None -> - if last <> "" then - match is_prefix last prefix with - None -> (last,string) - | Some _ -> - (match is_prefix prefix (last^string) with - None -> (last,string) - | Some tail -> (prefix,tail)) - else (last,string) - | Some tail -> (prefix, tail) - -let legal_suffix string = - if string = "" then true else - begin - let legal_s = Str.regexp "_?\\([0-9]+\\|r\\|l\\|'\\|\"\\)" in - (Str.string_match legal_s string 0) && (Str.matched_string string = string) - end - -(** check if a prefix of string_name is legal for term and returns the tail. - chec_rec cannot fail: at worst it return string_name. - The algorithm is greedy, but last contains the last name matched, providing - a one slot buffer. - string_name is here a pair (last,string_name).*) - -let rec check_rec ctx string_name = - function - | Cic.Rel m -> - (match List.nth ctx (m-1) with - Cic.Name name -> - remove_prefix name string_name - | Cic.Anonymous -> string_name) - | Cic.Meta _ -> string_name - | Cic.Sort sort -> remove_prefix (ppsort sort) string_name - | Cic.Implicit _ -> string_name - | Cic.Cast (te,ty) -> check_rec ctx string_name te - | Cic.Prod (name,so,dest) -> - let l_string_name = check_rec ctx string_name so in - check_rec (name::ctx) string_name dest - | Cic.Lambda (name,so,dest) -> - let string_name = - match name with - Cic.Anonymous -> string_name - | Cic.Name name -> remove_prefix name string_name in - let l_string_name = check_rec ctx string_name so in - check_rec (name::ctx) l_string_name dest - | Cic.LetIn (name,so,dest) -> - let string_name = check_rec ctx string_name so in - check_rec (name::ctx) string_name dest - | Cic.Appl l -> - List.fold_left (check_rec ctx) string_name l - | Cic.Var (uri,exp_named_subst) -> - let name = UriManager.name_of_uri uri in - remove_prefix name string_name - | Cic.Const (uri,exp_named_subst) -> - let name = UriManager.name_of_uri uri in - remove_prefix name string_name - | Cic.MutInd (uri,_,exp_named_subst) -> - let name = UriManager.name_of_uri uri in - remove_prefix name string_name - | Cic.MutConstruct (uri,n,m,exp_named_subst) -> - let name = - (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - Cic.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cons) = get_nth dl (n+1) in - let (id,_) = get_nth cons m in - id - | _ -> assert false) in - remove_prefix name string_name - | Cic.MutCase (_,_,_,te,pl) -> - let strig_name = remove_prefix "match" string_name in - let string_name = check_rec ctx string_name te in - List.fold_right (fun t s -> check_rec ctx s t) pl string_name - | Cic.Fix (_,fl) -> - let strig_name = remove_prefix "fix" string_name in - let names = List.map (fun (name,_,_,_) -> name) fl in - let onames = - List.rev (List.map (function name -> Cic.Name name) names) - in - List.fold_right - (fun (_,_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name - | Cic.CoFix (_,fl) -> - let strig_name = remove_prefix "cofix" string_name in - let names = List.map (fun (name,_,_) -> name) fl in - let onames = - List.rev (List.map (function name -> Cic.Name name) names) - in - List.fold_right - (fun (_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name - -let check_name ?(allow_suffix=false) ctx name term = - let (_,tail) = check_rec ctx ("",name) term in - if (not allow_suffix) then (String.length tail = 0) - else legal_suffix tail - -let check_elim ctx conclusion_name = - let elim = Str.regexp "_elim\\|_case" in - if (Str.string_match elim conclusion_name 0) then - let len = String.length conclusion_name in - let tail = String.sub conclusion_name 5 (len-5) in - legal_suffix tail - else false - -let rec check_names ctx hyp_names conclusion_name t = - match t with - | Cic.Prod (name,s,t) -> - (match hyp_names with - [] -> check_names (name::ctx) hyp_names conclusion_name t - | hd::tl -> - if check_name ctx hd s then - check_names (name::ctx) tl conclusion_name t - else - check_names (name::ctx) hyp_names conclusion_name t) - | Cic.Appl ((Cic.Rel n)::args) -> - (match hyp_names with - | [] -> - (check_name ~allow_suffix:true ctx conclusion_name t) || - (check_elim ctx conclusion_name) - | [what_to_elim] -> - (* what to elim could be an argument - of the predicate: e.g. leb_elim *) - let (last,tail) = - List.fold_left (check_rec ctx) ("",what_to_elim) args in - (tail = "" && check_elim ctx conclusion_name) - | _ -> false) - | Cic.MutCase (_,_,Cic.Lambda(name,so,ty),te,_) -> - (match hyp_names with - | [] -> - (match is_prefix "match" conclusion_name with - None -> check_name ~allow_suffix:true ctx conclusion_name t - | Some tail -> check_name ~allow_suffix:true ctx tail t) - | [what_to_match] -> - (* what to match could be the term te or its type so; in this case the - conclusion name should match ty *) - check_name ~allow_suffix:true (name::ctx) conclusion_name ty && - (check_name ctx what_to_match te || check_name ctx what_to_match so) - | _ -> false) - | _ -> - hyp_names=[] && check_name ~allow_suffix:true ctx conclusion_name t - -let check name term = -(* prerr_endline name; - prerr_endline (ppterm term); *) - let names = Str.split (Str.regexp_string "_to_") name in - let hyp_names,conclusion_name = - match List.rev names with - [] -> assert false - | hd::tl -> - let elim = Str.regexp "_elim\\|_case" in - let len = String.length hd in - try - let pos = Str.search_backward elim hd len in - let hyp = String.sub hd 0 pos in - let concl = String.sub hd pos (len-pos) in - List.rev (hyp::tl),concl - with Not_found -> (List.rev tl),hd in - check_names [] hyp_names conclusion_name term -;; - - diff --git a/helm/ocaml/cic_proof_checking/cicPp.mli b/helm/ocaml/cic_proof_checking/cicPp.mli deleted file mode 100644 index e84ae4fed..000000000 --- a/helm/ocaml/cic_proof_checking/cicPp.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* 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 *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a very simple Coq-like pretty printer that, given *) -(* an object of cic (internal representation) returns a string describing the*) -(* object in a syntax similar to that of coq *) -(* *) -(*****************************************************************************) - -(* ppobj obj returns a string with describing the cic object obj in a syntax*) -(* similar to the one used by Coq *) -val ppobj : Cic.obj -> string - -val ppterm : Cic.term -> string - -val ppcontext : ?sep:string -> Cic.context -> string - -(* Required only by the topLevel. It is the generalization of ppterm to *) -(* work with environments. *) -val pp : Cic.term -> (Cic.name option) list -> string - -val ppname : Cic.name -> string - -val ppsort: Cic.sort -> string - -val check: string -> Cic.term -> bool diff --git a/helm/ocaml/cic_proof_checking/cicReduction.ml b/helm/ocaml/cic_proof_checking/cicReduction.ml deleted file mode 100644 index 56e98775f..000000000 --- a/helm/ocaml/cic_proof_checking/cicReduction.ml +++ /dev/null @@ -1,1074 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -(* TODO unify exceptions *) - -exception WrongUriToInductiveDefinition;; -exception Impossible of int;; -exception ReferenceToConstant;; -exception ReferenceToVariable;; -exception ReferenceToCurrentProof;; -exception ReferenceToInductiveDefinition;; - -let debug = false -let profile = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -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 - in - if !fdebug = 0 then - debug_print (lazy (s ^ "\n" ^ List.fold_right debug_aux (t::env) "")) -;; - -module type Strategy = - sig - type stack_term - type env_term - type ens_term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - val to_env : config -> env_term - val to_ens : config -> ens_term - val from_stack : stack_term -> config - val from_stack_list_for_unwind : - unwind: (config -> Cic.term) -> - stack_term list -> Cic.term list - val from_env : env_term -> config - val from_env_for_unwind : - unwind: (config -> Cic.term) -> - env_term -> Cic.term - val from_ens : ens_term -> config - val from_ens_for_unwind : - unwind: (config -> Cic.term) -> - ens_term -> Cic.term - val stack_to_env : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - stack_term -> env_term - val compute_to_env : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - int -> env_term list -> ens_term Cic.explicit_named_substitution -> - Cic.term -> env_term - val compute_to_stack : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - config -> stack_term - end -;; - -module CallByValueByNameForUnwind = - struct - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - and stack_term = config - and env_term = config * config (* cbv, cbn *) - and ens_term = config * config (* cbv, cbn *) - - let to_env c = c,c - let to_ens c = c,c - let from_stack config = config - let from_stack_list_for_unwind ~unwind l = List.map unwind l - let from_env (c,_) = c - let from_ens (c,_) = c - let from_env_for_unwind ~unwind (_,c) = unwind c - let from_ens_for_unwind ~unwind (_,c) = unwind c - let stack_to_env ~reduce ~unwind config = reduce config, (0,[],[],unwind config,[]) - let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]), (k,e,ens,t,[]) - let compute_to_stack ~reduce ~unwind config = config - end -;; - - -module CallByNameStrategy = - struct - type stack_term = Cic.term - type env_term = Cic.term - type ens_term = Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind 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 -;; - -module CallByValueStrategy = - struct - type stack_term = Cic.term - type env_term = Cic.term - type ens_term = Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind 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 - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind 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 - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = Lazy.force v - let from_ens_for_unwind ~unwind 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 -;; - -module LazyCallByValueStrategyByNameOnConstants = - struct - type stack_term = Cic.term lazy_t - type env_term = Cic.term lazy_t - type ens_term = Cic.term lazy_t - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = Lazy.force v - let from_ens_for_unwind ~unwind 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 -;; - -module LazyCallByNameStrategy = - struct - type stack_term = Cic.term lazy_t - type env_term = Cic.term lazy_t - type ens_term = Cic.term lazy_t - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = Lazy.force v - let from_ens_for_unwind ~unwind 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 - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = (v ~reduce:true) - let from_ens_for_unwind ~unwind 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 config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - and stack_term = config - and env_term = config - and ens_term = config - - let to_env config = config - let to_ens config = config - let from_stack config = config - let from_stack_list_for_unwind ~unwind l = List.map unwind l - let from_env v = v - let from_ens v = v - let from_env_for_unwind ~unwind config = unwind config - let from_ens_for_unwind ~unwind config = unwind config - let stack_to_env ~reduce ~unwind config = reduce config - let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]) - let compute_to_stack ~reduce ~unwind config = config - 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 - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - 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 from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind 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 rec 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_for_unwind ~unwind (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) -> -(* -debug_print (lazy ("%%%%%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_for_unwind ~unwind (List.assq uri ens)) - else - let params = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o 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 = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o 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 = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o 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 = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o 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_for_unwind ~unwind t)) :: - (filter_and_lift (uri::already_instantiated) tl) - | _::tl -> filter_and_lift already_instantiated tl -(* - | (uri,_)::tl -> -debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ; -if List.for_all (function (uri',_) -> not (UriManager.eq uri uri')) -exp_named_subst' then debug_print (lazy "---- OK1") ; -debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; -if List.mem uri params then debug_print (lazy "---- 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 - - and unwind (k,e,ens,t,s) = - let t' = unwind' 0 k e ens t in - if s = [] then t' else Cic.Appl (t'::(RS.from_stack_list_for_unwind ~unwind s)) - ;; - -(* - let unwind = - let profiler_unwind = HExtlib.profile ~enable:profile "are_convertible.unwind" in - fun k e ens t -> - profiler_unwind.HExtlib.profile (unwind k e ens) t - ;; -*) - - let reduce ~delta ?(subst = []) context : config -> config = - let module C = Cic in - let module S = CicSubstitution in - let rec reduce = - function - (k, e, _, C.Rel n, s) as config -> - let config' = - try - Some (RS.from_env (List.nth e (n-1))) - with - Failure _ -> - try - begin - match List.nth context (n - 1 - k) with - None -> assert false - | Some (_,C.Decl _) -> None - | Some (_,C.Def (x,_)) -> Some (0,[],[],S.lift (n - k) x,[]) - end - with - Failure _ -> None - in - (match config' with - Some (k',e',ens',t',s') -> reduce (k',e',ens',t',s'@s) - | None -> config) - | (k, e, ens, C.Var (uri,exp_named_subst), s) as config -> - if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then - let (k',e',ens',t',s') = RS.from_ens (List.assq uri ens) in - reduce (k',e',ens',t',s'@s) - else - ( let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - match o with - C.Constant _ -> raise ReferenceToConstant - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - | C.Variable (_,None,_,_,_) -> config - | 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 (n,l), s) as config -> - (try - let (_, term,_) = CicUtil.lookup_subst n subst in - reduce (k, e, ens,CicSubstitution.subst_meta l term,s) - with CicUtil.Subst_not_found _ -> config) - | (_, _, _, C.Sort _, _) - | (_, _, _, C.Implicit _, _) as config -> config - | (k, e, ens, C.Cast (te,ty), s) -> - reduce (k, e, ens, te, s) - | (_, _, _, C.Prod _, _) as config -> config - | (_, _, _, C.Lambda _, []) as config -> config - | (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), s) -> - let m' = RS.compute_to_env ~reduce ~unwind k e ens m in - reduce (k+1, m'::e, ens, t, s) - | (_, _, _, C.Appl [], _) -> assert false - | (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) - | (_, _, _, C.Const _, _) as config when delta=false-> config - | (k, e, ens, C.Const (uri,exp_named_subst), s) as config -> - (let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - match o 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,_,_,_) -> config - | 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 - ) - | (_, _, _, C.MutInd _, _) - | (_, _, _, C.MutConstruct _, _) as config -> config - | (k, e, ens, C.MutCase (mutind,i,outty,term,pl),s) as config -> - let decofix = - function - (k, e, ens, C.CoFix (i,fl), s) -> - 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,ens,body',s) - | config -> config - in - (match decofix (reduce (k,e,ens,term,[])) with - (k', e', ens', C.MutConstruct (_,_,j,_), []) -> - reduce (k, e, ens, (List.nth pl (j-1)), []) - | (k', e', ens', C.MutConstruct (_,_,j,_), s') -> - let (arity, r) = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph mutind - in - match o with - C.InductiveDefinition (s,ingredients,r,_) -> - let (_,_,arity,_) = List.nth s 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::s) when n > 0 -> eat_first (n - 1, s) - | _ -> raise (Impossible 5) - in - eat_first (num_to_eat,s') - in - reduce (k, e, ens, (List.nth pl (j-1)), ts@s) - | (_, _, _, C.Cast _, _) - | (_, _, _, C.Implicit _, _) -> - raise (Impossible 2) (* we don't trust our whd ;-) *) - | config' -> - (*CSC: here I am unwinding the configuration and for sure I - will do it twice; to avoid this unwinding I should push the - "match [] with _" continuation on the stack; - another possibility is to just return the original configuration, - partially undoing the weak-head computation *) - (*this code is uncorrect since term' lives in e' <> e - let term' = unwind config' in - (k, e, ens, C.MutCase (mutind,i,outty,term',pl),s) - *) - config) - | (k, e, ens, C.Fix (i,fl), s) as config -> - let (_,recindex,_,body) = List.nth fl i in - let recparam = - try - Some (RS.from_stack (List.nth s recindex)) - with - _ -> None - in - (match recparam with - Some recparam -> - (match reduce recparam with - (_,_,_,C.MutConstruct _,_) as config -> - let leng = List.length 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 (k,e,ens,C.Fix (!counter -1, fl),[]))::e)) - in - build_env e - in - let rec replace i s t = - match i,s with - 0,_::tl -> t::tl - | n,he::tl -> he::(replace (n - 1) tl t) - | _,_ -> assert false in - let new_s = - replace recindex s (RS.compute_to_stack ~reduce ~unwind config) - in - reduce (k+leng, new_env, ens, body, new_s) - | _ -> config) - | None -> config - ) - | (_,_,_,C.CoFix _,_) as config -> config - and push_exp_named_subst k e ens = - function - [] -> ens - | (uri,t)::tl -> - push_exp_named_subst k e ((uri,RS.to_ens (k,e,ens,t,[]))::ens) tl - in - reduce - ;; - - let whd ?(delta=true) ?(subst=[]) context t = - unwind (reduce ~delta ~subst context (0, [], [], t, [])) - ;; - - end -;; - - -(* ROTTO = rompe l'unificazione poiche' riduce gli argomenti di un'applicazione - senza ridurre la testa -module R = Reduction CallByNameStrategy;; OK 56.368s -module R = Reduction CallByValueStrategy;; ROTTO -module R = Reduction CallByValueStrategyByNameOnConstants;; ROTTO -module R = Reduction LazyCallByValueStrategy;; ROTTO -module R = Reduction LazyCallByValueStrategyByNameOnConstants;; ROTTO -module R = Reduction LazyCallByNameStrategy;; OK 0m56.398s -module R = Reduction - LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns;; - OK 59.058s -module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;; OK 58.583s -module R = Reduction - ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy;; OK 58.094s -module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);; OK 58.127s -*) -module R = Reduction(CallByValueByNameForUnwind);; -(*module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);;*) -module U = UriManager;; - -let whd = R.whd - -(* -let whd = - let profiler_whd = HExtlib.profile ~enable:profile "are_convertible.whd" in - fun ?(delta=true) ?(subst=[]) context t -> - profiler_whd.HExtlib.profile (whd ~delta ~subst context) t -*) - - (* mimic ocaml (<< 3.08) "=" behaviour. Tests physical equality first then - * fallbacks to structural equality *) -let (===) x y = - Pervasives.compare x y = 0 - -(* t1, t2 must be well-typed *) -let are_convertible whd ?(subst=[]) ?(metasenv=[]) = - let rec aux test_equality_only context t1 t2 ugraph = - let aux2 test_equality_only t1 t2 ugraph = - - (* 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,ugraph - else - begin - let module C = Cic in - match (t1,t2) with - (C.Rel n1, C.Rel n2) -> (n1 = n2),ugraph - | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) -> - if U.eq uri1 uri2 then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - let b',ugraph' = aux test_equality_only context x y ugraph in - (U.eq uri1 uri2 && b' && b),ugraph' - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.Meta (n1,l1), C.Meta (n2,l2)) -> - if n1 = n2 then - let b2, ugraph1 = - let l1 = CicUtil.clean_up_local_context subst metasenv n1 l1 in - let l2 = CicUtil.clean_up_local_context subst metasenv n2 l2 in - List.fold_left2 - (fun (b,ugraph) t1 t2 -> - if b then - match t1,t2 with - None,_ - | _,None -> true,ugraph - | Some t1',Some t2' -> - aux test_equality_only context t1' t2' ugraph - else - false,ugraph - ) (true,ugraph) l1 l2 - in - if b2 then true,ugraph1 else false,ugraph - else - false,ugraph - (* TASSI: CONSTRAINTS *) - | (C.Sort (C.Type t1), C.Sort (C.Type t2)) when test_equality_only -> - true,(CicUniv.add_eq t2 t1 ugraph) - (* TASSI: CONSTRAINTS *) - | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> - true,(CicUniv.add_ge t2 t1 ugraph) - (* TASSI: CONSTRAINTS *) - | (C.Sort s1, C.Sort (C.Type _)) -> (not test_equality_only),ugraph - (* TASSI: CONSTRAINTS *) - | (C.Sort s1, C.Sort s2) -> (s1 = s2),ugraph - | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) -> - let b',ugraph' = aux true context s1 s2 ugraph in - if b' then - aux test_equality_only ((Some (name1, (C.Decl s1)))::context) - t1 t2 ugraph' - else - false,ugraph - | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) -> - let b',ugraph' = aux test_equality_only context s1 s2 ugraph in - if b' then - aux test_equality_only ((Some (name1, (C.Decl s1)))::context) - t1 t2 ugraph' - else - false,ugraph - | (C.LetIn (name1,s1,t1), C.LetIn(_,s2,t2)) -> - let b',ugraph' = aux test_equality_only context s1 s2 ugraph in - if b' then - aux test_equality_only - ((Some (name1, (C.Def (s1,None))))::context) t1 t2 ugraph' - else - false,ugraph - | (C.Appl l1, C.Appl l2) -> - (try - List.fold_right2 - (fun x y (b,ugraph) -> - if b then - aux test_equality_only context x y ugraph - else - false,ugraph) l1 l2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) -> - let b' = U.eq uri1 uri2 in - if b' then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - if b && U.eq uri1 uri2 then - aux test_equality_only context x y ugraph - else - false,ugraph - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.MutInd (uri1,i1,exp_named_subst1), - C.MutInd (uri2,i2,exp_named_subst2) - ) -> - let b' = U.eq uri1 uri2 && i1 = i2 in - if b' then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - if b && U.eq uri1 uri2 then - aux test_equality_only context x y ugraph - else - false,ugraph - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.MutConstruct (uri1,i1,j1,exp_named_subst1), - C.MutConstruct (uri2,i2,j2,exp_named_subst2) - ) -> - let b' = U.eq uri1 uri2 && i1 = i2 && j1 = j2 in - if b' then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - if b && U.eq uri1 uri2 then - aux test_equality_only context x y ugraph - else - false,ugraph - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.MutCase (uri1,i1,outtype1,term1,pl1), - C.MutCase (uri2,i2,outtype2,term2,pl2)) -> - let b' = U.eq uri1 uri2 && i1 = i2 in - if b' then - let b'',ugraph''=aux test_equality_only context - outtype1 outtype2 ugraph in - if b'' then - let b''',ugraph'''= aux test_equality_only context - term1 term2 ugraph'' in - List.fold_right2 - (fun x y (b,ugraph) -> - if b then - aux test_equality_only context x y ugraph - else - false,ugraph) - pl1 pl2 (b''',ugraph''') - else - false,ugraph - else - false,ugraph - | (C.Fix (i1,fl1), C.Fix (i2,fl2)) -> - let tys = - List.map (function (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1 - in - if i1 = i2 then - List.fold_right2 - (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) (b,ugraph) -> - if b && recindex1 = recindex2 then - let b',ugraph' = aux test_equality_only context ty1 ty2 - ugraph in - if b' then - aux test_equality_only (tys@context) bo1 bo2 ugraph' - else - false,ugraph - else - false,ugraph) - fl1 fl2 (true,ugraph) - else - false,ugraph - | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) -> - let tys = - List.map (function (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1 - in - if i1 = i2 then - List.fold_right2 - (fun (_,ty1,bo1) (_,ty2,bo2) (b,ugraph) -> - if b then - let b',ugraph' = aux test_equality_only context ty1 ty2 - ugraph in - if b' then - aux test_equality_only (tys@context) bo1 bo2 ugraph' - else - false,ugraph - else - false,ugraph) - fl1 fl2 (true,ugraph) - else - false,ugraph - | (C.Cast _, _) | (_, C.Cast _) - | (C.Implicit _, _) | (_, C.Implicit _) -> assert false - | (_,_) -> false,ugraph - end - in - debug t1 [t2] "PREWHD"; - let t1' = whd ?delta:(Some true) ?subst:(Some subst) context t1 in - let t2' = whd ?delta:(Some true) ?subst:(Some subst) context t2 in - debug t1' [t2'] "POSTWHD"; - aux2 test_equality_only t1' t2' ugraph - in - aux false (*c t1 t2 ugraph *) -;; - -(* DEBUGGING ONLY -let whd ?(delta=true) ?(subst=[]) context t = - let res = whd ~delta ~subst context t in - let rescsc = CicReductionNaif.whd ~delta ~subst context t in - if not (fst (are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph)) then - begin - debug_print (lazy ("PRIMA: " ^ CicPp.ppterm t)) ; - flush stderr ; - debug_print (lazy ("DOPO: " ^ CicPp.ppterm res)) ; - flush stderr ; - debug_print (lazy ("CSC: " ^ CicPp.ppterm rescsc)) ; - flush stderr ; -fdebug := 0 ; -let _ = are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph in - assert false ; - end - else - res -;; -*) - -let are_convertible = are_convertible whd - -let whd = R.whd - -(* -let profiler_other_whd = HExtlib.profile ~enable:profile "~are_convertible.whd" -let whd ?(delta=true) ?(subst=[]) context t = - let foo () = - whd ~delta ~subst context t - in - profiler_other_whd.HExtlib.profile foo () -*) - -let rec normalize ?(delta=true) ?(subst=[]) ctx term = - let module C = Cic in - let t = whd ~delta ~subst ctx term in - let aux = normalize ~delta ~subst in - let decl name t = Some (name, C.Decl t) in - match t with - | C.Rel n -> t - | C.Var (uri,exp_named_subst) -> - C.Var (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.Meta (i,l) -> - C.Meta (i,List.map (function Some t -> Some (aux ctx t) | None -> None) l) - | C.Sort _ -> t - | C.Implicit _ -> t - | C.Cast (te,ty) -> C.Cast (aux ctx te, aux ctx ty) - | C.Prod (n,s,t) -> - let s' = aux ctx s in - C.Prod (n, s', aux ((decl n s')::ctx) t) - | C.Lambda (n,s,t) -> - let s' = aux ctx s in - C.Lambda (n, s', aux ((decl n s')::ctx) t) - | C.LetIn (n,s,t) -> - (* the term is already in weak head normal form *) - assert false - | C.Appl (h::l) -> C.Appl (h::(List.map (aux ctx) l)) - | C.Appl [] -> assert false - | C.Const (uri,exp_named_subst) -> - C.Const (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.MutInd (uri,typeno,exp_named_subst) -> - C.MutInd (uri,typeno, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - C.MutConstruct (uri, typeno, consno, - List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i, aux ctx outt, aux ctx t, List.map (aux ctx) pl) -(*CSC: to be completed, I suppose *) - | C.Fix _ -> t - | C.CoFix _ -> t - -let normalize ?delta ?subst ctx term = -(* prerr_endline ("NORMALIZE:" ^ CicPp.ppterm term); *) - let t = normalize ?delta ?subst ctx term in -(* prerr_endline ("NORMALIZED:" ^ CicPp.ppterm t); *) - t - - -(* performs an head beta/cast reduction *) -let rec head_beta_reduce = - function - (Cic.Appl (Cic.Lambda (_,_,t)::he'::tl')) -> - let he'' = CicSubstitution.subst he' t in - if tl' = [] then - he'' - else - let he''' = - match he'' with - Cic.Appl l -> Cic.Appl (l@tl') - | _ -> Cic.Appl (he''::tl') - in - head_beta_reduce he''' - | Cic.Cast (te,_) -> head_beta_reduce te - | t -> t diff --git a/helm/ocaml/cic_proof_checking/cicReduction.mli b/helm/ocaml/cic_proof_checking/cicReduction.mli deleted file mode 100644 index e3619053d..000000000 --- a/helm/ocaml/cic_proof_checking/cicReduction.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* 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 WrongUriToInductiveDefinition -exception ReferenceToConstant -exception ReferenceToVariable -exception ReferenceToCurrentProof -exception ReferenceToInductiveDefinition -val fdebug : int ref -val whd : - ?delta:bool -> ?subst:Cic.substitution -> Cic.context -> Cic.term -> Cic.term -val are_convertible : - ?subst:Cic.substitution -> ?metasenv:Cic.metasenv -> - Cic.context -> Cic.term -> Cic.term -> CicUniv.universe_graph -> - bool * CicUniv.universe_graph -val normalize: - ?delta:bool -> ?subst:Cic.substitution -> Cic.context -> Cic.term -> Cic.term - -(* performs an head beta/cast reduction *) -val head_beta_reduce: Cic.term -> Cic.term diff --git a/helm/ocaml/cic_proof_checking/cicSubstitution.ml b/helm/ocaml/cic_proof_checking/cicSubstitution.ml deleted file mode 100644 index a30a036cb..000000000 --- a/helm/ocaml/cic_proof_checking/cicSubstitution.ml +++ /dev/null @@ -1,428 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -exception CannotSubstInMeta;; -exception RelToHiddenHypothesis;; -exception ReferenceToVariable;; -exception ReferenceToConstant;; -exception ReferenceToCurrentProof;; -exception ReferenceToInductiveDefinition;; - -let debug_print = fun _ -> () - -let lift_from k n = - let rec liftaux k = - let module C = Cic in - function - C.Rel m -> - if m < k then - C.Rel m - else - C.Rel (m + n) - | 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 - (function - None -> None - | Some t -> Some (liftaux k t) - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty) - | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t) - | 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 (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 - let liftedfl = - List.map - (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (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, liftaux k ty, liftaux (k+len) bo)) - fl - in - C.CoFix (i, liftedfl) - in - liftaux k - -let lift n t = - if n = 0 then - t - else - lift_from 1 n t -;; - -let subst arg = - let rec substaux k = - let module C = Cic in - function - C.Rel n as t -> - (match n with - n when n = k -> lift (k - 1) arg - | n when n < k -> t - | _ -> C.Rel (n - 1) - ) - | 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) -> - 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,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 - 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 -;; - -(*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 t = -(* -debug_print (lazy ("@@@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 - lift (k -1) arg - with - Not_found -> - let params = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj with - C.Constant _ -> raise ReferenceToConstant - | C.Variable (_,_,_,params,_) -> params - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - in -(* -debug_print (lazy "\n\n---- BEGIN ") ; -debug_print (lazy ("----params: " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; -debug_print (lazy ("----S(" ^ UriManager.string_of_uri uri ^ "): " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst))) ; -debug_print (lazy ("----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 -(* -debug_print (lazy ("----D: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst''))) ; -debug_print (lazy "---- END\n\n ") ; -*) - C.Var (uri,exp_named_subst'') - ) - | C.Meta (i, l) -> - 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 = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj 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 = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj 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 = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj 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 -> -debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ; -if List.for_all (function (uri',_) -> not (UriManager.eq uri uri')) -exp_named_subst' then debug_print (lazy "---- OK1") ; -debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; -if List.mem uri params then debug_print (lazy "---- 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 - if exp_named_subst = [] then t - else substaux 1 t -;; - -(* subst_meta [t_1 ; ... ; t_n] t *) -(* returns the term [t] where [Rel i] is substituted with [t_i] *) -(* [t_i] is lifted as usual when it crosses an abstraction *) -let subst_meta l t = - let module C = Cic in - if l = [] then t else - let rec aux k = function - C.Rel n as t -> - if n <= k then t else - (try - match List.nth l (n-k-1) with - None -> raise RelToHiddenHypothesis - | Some t -> lift k t - with - (Failure _) -> assert false - ) - | 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 - (function - None -> None - | Some t -> - try - Some (aux k t) - with - RelToHiddenHypothesis -> None - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) (*CSC ??? *) - | 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,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 = - 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 0 t -;; - diff --git a/helm/ocaml/cic_proof_checking/cicSubstitution.mli b/helm/ocaml/cic_proof_checking/cicSubstitution.mli deleted file mode 100644 index 21a1f5d0e..000000000 --- a/helm/ocaml/cic_proof_checking/cicSubstitution.mli +++ /dev/null @@ -1,56 +0,0 @@ -(* 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 CannotSubstInMeta;; -exception RelToHiddenHypothesis;; -exception ReferenceToVariable;; -exception ReferenceToConstant;; -exception ReferenceToInductiveDefinition;; - -(* lift n t *) -(* lifts [t] of [n] *) -(* NOTE: the opposite function (delift_rels) is defined in CicMetaSubst *) -(* since it needs to restrict the metavariables in case of failure *) -val lift : int -> Cic.term -> Cic.term - - -(* lift from n t *) -(* as lift but lifts only indexes >= from *) -val lift_from: int -> 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 - -(* subst_meta [t_1 ; ... ; t_n] t *) -(* returns the term [t] where [Rel i] is substituted with [t_i] *) -(* [t_i] is lifted as usual when it crosses an abstraction *) -val subst_meta : (Cic.term option) list -> Cic.term -> Cic.term - diff --git a/helm/ocaml/cic_proof_checking/cicTypeChecker.ml b/helm/ocaml/cic_proof_checking/cicTypeChecker.ml deleted file mode 100644 index 951f68dbd..000000000 --- a/helm/ocaml/cic_proof_checking/cicTypeChecker.ml +++ /dev/null @@ -1,2170 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -(* TODO factorize functions to frequent errors (e.g. "Unknwon mutual inductive - * ...") *) - -open Printf - -exception AssertFailure of string Lazy.t;; -exception TypeCheckerFailure of string Lazy.t;; - -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 (TypeCheckerFailure (lazy (List.fold_right debug_aux (t::context) ""))) -;; - -let debug_print = fun _ -> ();; - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> - raise (TypeCheckerFailure (lazy "Parameters number < left parameters number")) -;; - -let debrujin_constructor ?(cb=fun _ _ -> ()) uri number_of_types = - let rec aux k t = - let module C = Cic in - let res = - match t with - C.Rel n as t when n <= k -> t - | C.Rel _ -> - raise (TypeCheckerFailure (lazy "unbound variable found in constructor type")) - | 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 (function None -> None | Some t -> Some (aux k t)) l in - C.Meta (i,l') - | 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 - (lazy ("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 - cb t res; - res - in - aux 0 -;; - -exception CicEnvironmentError;; - -let rec type_of_constant ~logger uri ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj,ugraph = - match CicEnvironment.is_type_checked ~trust:true ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj uobj -> - logger#log (`Start_type_checking uri) ; - (* let's typecheck the uncooked obj *) - -(**************************************************************** - TASSI: FIXME qui e' inutile ricordarselo, - tanto poi lo richiediamo alla cache che da quello su disco -*****************************************************************) - - let ugraph_dust = - (match uobj with - C.Constant (_,Some te,ty,_,_) -> - let _,ugraph = type_of ~logger ty ugraph in - let type_of_te,ugraph' = type_of ~logger te ugraph in - let b',ugraph'' = (R.are_convertible [] type_of_te ty ugraph') in - if not b' then - raise (TypeCheckerFailure (lazy (sprintf - "the constant %s is not well typed because the type %s of the body is not convertible to the declared type %s" - (U.string_of_uri uri) (CicPp.ppterm type_of_te) - (CicPp.ppterm ty)))) - else - ugraph' - | C.Constant (_,None,ty,_,_) -> - (* only to check that ty is well-typed *) - let _,ugraph' = type_of ~logger ty ugraph in - ugraph' - | C.CurrentProof (_,conjs,te,ty,_,_) -> - let _,ugraph1 = - List.fold_left - (fun (metasenv,ugraph) ((_,context,ty) as conj) -> - let _,ugraph' = - type_of_aux' ~logger metasenv context ty ugraph - in - (metasenv @ [conj],ugraph') - ) ([],ugraph) conjs - in - let _,ugraph2 = type_of_aux' ~logger conjs [] ty ugraph1 in - let type_of_te,ugraph3 = - type_of_aux' ~logger conjs [] te ugraph2 - in - let b,ugraph4 = (R.are_convertible [] type_of_te ty ugraph3) in - if not b then - raise (TypeCheckerFailure (lazy (sprintf - "the current proof %s is not well typed because the type %s of the body is not convertible to the declared type %s" - (U.string_of_uri uri) (CicPp.ppterm type_of_te) - (CicPp.ppterm ty)))) - else - ugraph4 - | _ -> - raise - (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri)))) - in - try - CicEnvironment.set_type_checking_info uri; - logger#log (`Type_checking_completed uri) ; - match CicEnvironment.is_type_checked ~trust:false ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError - with Invalid_argument s -> - (*debug_print (lazy s);*) - uobj,ugraph_dust - in - match cobj,ugraph with - (C.Constant (_,_,ty,_,_)),g -> ty,g - | (C.CurrentProof (_,_,_,ty,_,_)),g -> ty,g - | _ -> - raise (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri))) - -and type_of_variable ~logger uri ugraph = - 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 ~trust:true ugraph uri with - CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> ty,ugraph' - | CicEnvironment.UncheckedObj (C.Variable (_,bo,ty,_,_)) -> - logger#log (`Start_type_checking uri) ; - (* only to check that ty is well-typed *) - let _,ugraph1 = type_of ~logger ty ugraph in - let ugraph2 = - (match bo with - None -> ugraph - | Some bo -> - let ty_bo,ugraph' = type_of ~logger bo ugraph1 in - let b,ugraph'' = (R.are_convertible [] ty_bo ty ugraph') in - if not b then - raise (TypeCheckerFailure - (lazy ("Unknown variable:" ^ U.string_of_uri uri))) - else - ugraph'') - in - (try - CicEnvironment.set_type_checking_info uri ; - logger#log (`Type_checking_completed uri) ; - match CicEnvironment.is_type_checked ~trust:false ugraph uri with - CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> - ty,ugraph' - | CicEnvironment.CheckedObj _ - | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError - with Invalid_argument s -> - (*debug_print (lazy s);*) - ty,ugraph2) - | _ -> - raise (TypeCheckerFailure (lazy ("Unknown variable:" ^ U.string_of_uri uri))) - -and does_not_occur ?(subst=[]) context n nn te = - let module C = Cic in - (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *) - (*CSC: venga mangiata durante la whd sembra presentare problemi di *) - (*CSC: universi *) - match CicReduction.whd ~subst context te with - C.Rel m when m > n && m <= nn -> false - | C.Rel _ - | C.Sort _ - | C.Implicit _ -> true - | C.Meta (_,l) -> - List.fold_right - (fun x i -> - match x with - None -> i - | Some x -> i && does_not_occur ~subst context n nn x) l true - | C.Cast (te,ty) -> - does_not_occur ~subst context n nn te && does_not_occur ~subst context n nn ty - | C.Prod (name,so,dest) -> - does_not_occur ~subst context n nn so && - does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) - (nn + 1) dest - | C.Lambda (name,so,dest) -> - does_not_occur ~subst context n nn so && - does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) (nn + 1) - dest - | C.LetIn (name,so,dest) -> - does_not_occur ~subst context n nn so && - does_not_occur ~subst ((Some (name,(C.Def (so,None))))::context) - (n + 1) (nn + 1) dest - | C.Appl l -> - List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true - | 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 ~subst context n nn x) - exp_named_subst true - | C.MutCase (_,_,out,te,pl) -> - does_not_occur ~subst context n nn out && does_not_occur ~subst context n nn te && - List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - let tys = - List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl - in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - let tys = - List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl - in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo - ) fl true - -(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *) -(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *) -(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *) -(*CSC strictly_positive *) -(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *) -and weakly_positive context n nn uri te = - let module C = Cic in -(*CSC: Che schifo! Bisogna capire meglio e trovare una soluzione ragionevole!*) - let dummy_mutind = - C.MutInd (HelmLibraryObjects.Datatypes.nat_URI,0,[]) - in - (*CSC: mettere in cicSubstitution *) - let rec subst_inductive_type_with_dummy_mutind = - function - C.MutInd (uri',0,_) when UriManager.eq uri' uri -> - dummy_mutind - | 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) -> - C.Prod (name, subst_inductive_type_with_dummy_mutind so, - subst_inductive_type_with_dummy_mutind ta) - | C.Lambda (name,so,ta) -> - C.Lambda (name, subst_inductive_type_with_dummy_mutind so, - subst_inductive_type_with_dummy_mutind ta) - | C.Appl tl -> - C.Appl (List.map subst_inductive_type_with_dummy_mutind tl) - | 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.Fix (i,fl) -> - C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i, - subst_inductive_type_with_dummy_mutind ty, - subst_inductive_type_with_dummy_mutind bo)) fl) - | C.CoFix (i,fl) -> - 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.Anonymous,source,dest) -> - strictly_positive context n nn - (subst_inductive_type_with_dummy_mutind source) && - 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 -> - (* dummy abstraction, so we behave as in the anonimous case *) - strictly_positive context n nn - (subst_inductive_type_with_dummy_mutind source) && - weakly_positive ((Some (name,(C.Decl source)))::context) - (n + 1) (nn + 1) uri dest - | C.Prod (name,source,dest) -> - does_not_occur context n nn - (subst_inductive_type_with_dummy_mutind source)&& - weakly_positive ((Some (name,(C.Decl source)))::context) - (n + 1) (nn + 1) uri dest - | _ -> - raise (TypeCheckerFailure (lazy "Malformed inductive constructor type")) - -(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *) -(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *) -and instantiate_parameters params c = - let module C = Cic in - match (c,params) with - (c,[]) -> c - | (C.Prod (_,_,ta), he::tl) -> - instantiate_parameters tl - (CicSubstitution.subst he ta) - | (C.Cast (te,_), _) -> instantiate_parameters params te - | (t,l) -> raise (AssertFailure (lazy "1")) - -and strictly_positive context n nn te = - let module C = Cic in - let module U = UriManager in - match CicReduction.whd context te with - C.Rel _ -> true - | C.Cast (te,ty) -> - (*CSC: bisogna controllare ty????*) - strictly_positive context n nn te - | C.Prod (name,so,ta) -> - does_not_occur context n nn so && - 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,exp_named_subst))::tl) -> - let (ok,paramsno,ity,cl,name) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tl,_,paramsno,_) -> - let (name,_,ity,cl) = List.nth tl i in - (List.length tl = 1, paramsno, ity, cl, name) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown inductive type:" ^ 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 - (CicSubstitution.subst_vars exp_named_subst te) - ) cl - in - ok && - List.fold_right - (fun x i -> i && does_not_occur context n nn x) - arguments true && - (*CSC: MEGAPATCH3 (sara' quella giusta?)*) - List.fold_right - (fun x i -> - i && - weakly_positive - ((Some (C.Name name,(Cic.Decl ity)))::context) (n+1) (nn+1) uri - x - ) cl' true - | t -> does_not_occur context n nn t - -(* the inductive type indexes are s.t. n < x <= nn *) -and are_all_occurrences_positive context uri indparamsno i n nn te = - let module C = Cic in - match CicReduction.whd context te with - C.Appl ((C.Rel m)::tl) when m = i -> - (*CSC: riscrivere fermandosi a 0 *) - (* let's check if the inductive type is applied at least to *) - (* indparamsno parameters *) - let last = - List.fold_left - (fun k x -> - if k = 0 then 0 - else - match CicReduction.whd context x with - C.Rel m when m = n - (indparamsno - k) -> k - 1 - | _ -> - raise (TypeCheckerFailure - (lazy - ("Non-positive occurence in mutual inductive definition(s) [1]" ^ - 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 (TypeCheckerFailure - (lazy ("Non-positive occurence in mutual inductive definition(s) [2]"^ - UriManager.string_of_uri uri))) - | C.Rel m when m = i -> - if indparamsno = 0 then - true - else - raise (TypeCheckerFailure - (lazy ("Non-positive occurence in mutual inductive definition(s) [3]"^ - UriManager.string_of_uri uri))) - | C.Prod (C.Anonymous,source,dest) -> - strictly_positive context n nn source && - are_all_occurrences_positive - ((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 -> - (* dummy abstraction, so we behave as in the anonimous case *) - strictly_positive context n nn source && - are_all_occurrences_positive - ((Some (name,(C.Decl source)))::context) uri indparamsno - (i+1) (n + 1) (nn + 1) dest - | C.Prod (name,source,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 - (TypeCheckerFailure (lazy ("Malformed inductive constructor type " ^ - (UriManager.string_of_uri 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 ~logger uri (itl,_,indparamsno) ugraph = - let module U = UriManager in - (* let's check if the arity of the inductive types are well *) - (* formed *) - let ugrap1 = List.fold_left - (fun ugraph (_,_,x,_) -> let _,ugraph' = - type_of ~logger x ugraph in ugraph') - ugraph itl in - - (* 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 _,ugraph2 = - List.fold_right - (fun (_,_,_,cl) (i,ugraph) -> - let ugraph'' = - List.fold_left - (fun ugraph (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 _,ugraph' = type_of ~logger augmented_term ugraph in - (* let's check also the positivity conditions *) - if - not - (are_all_occurrences_positive tys uri indparamsno i 0 len - debrujinedte) - then - raise - (TypeCheckerFailure - (lazy ("Non positive occurence in " ^ U.string_of_uri uri))) - else - ugraph' - ) ugraph cl in - (i + 1),ugraph'' - ) itl (1,ugrap1) - in - ugraph2 - -(* Main function to checks the correctness of a mutual *) -(* inductive block definition. *) -and check_mutual_inductive_defs uri obj ugraph = - match obj with - Cic.InductiveDefinition (itl, params, indparamsno, _) -> - typecheck_mutual_inductive_defs uri (itl,params,indparamsno) ugraph - | _ -> - raise (TypeCheckerFailure ( - lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - -and type_of_mutual_inductive_defs ~logger uri i ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj,ugraph1 = - match CicEnvironment.is_type_checked ~trust:true ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj uobj -> - logger#log (`Start_type_checking uri) ; - let ugraph1_dust = - check_mutual_inductive_defs ~logger uri uobj ugraph - in - (* TASSI: FIXME: check ugraph1 == ugraph ritornato da env *) - try - CicEnvironment.set_type_checking_info uri ; - logger#log (`Type_checking_completed uri) ; - (match CicEnvironment.is_type_checked ~trust:false ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> (cobj,ugraph') - | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError - ) - with - Invalid_argument s -> - (*debug_print (lazy s);*) - uobj,ugraph1_dust - in - match cobj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,arity,_) = List.nth dl i in - arity,ugraph1 - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ U.string_of_uri uri))) - -and type_of_mutual_inductive_constr ~logger uri i j ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj,ugraph1 = - match CicEnvironment.is_type_checked ~trust:true ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj uobj -> - logger#log (`Start_type_checking uri) ; - let ugraph1_dust = - check_mutual_inductive_defs ~logger uri uobj ugraph - in - (* check ugraph1 validity ??? == ugraph' *) - try - CicEnvironment.set_type_checking_info uri ; - logger#log (`Type_checking_completed uri) ; - (match - CicEnvironment.is_type_checked ~trust:false ugraph uri - with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj _ -> - raise CicEnvironmentError) - with - Invalid_argument s -> - (*debug_print (lazy s);*) - uobj,ugraph1_dust - in - match cobj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cl) = List.nth dl i in - let (_,ty) = List.nth cl (j-1) in - ty,ugraph1 - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri))) - -and recursive_args context n nn te = - let module C = Cic in - match CicReduction.whd context te with - C.Rel _ -> [] - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit _ - | C.Cast _ (*CSC ??? *) -> - raise (AssertFailure (lazy "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 (AssertFailure (lazy "4")) (* due to type-checking *) - | C.Appl _ -> [] - | C.Const _ -> raise (AssertFailure (lazy "5")) - | C.MutInd _ - | C.MutConstruct _ - | C.MutCase _ - | C.Fix _ - | C.CoFix _ -> raise (AssertFailure (lazy "6")) (* due to type-checking *) - -and get_new_safes ~subst context p c rl safes n nn x = - let module C = Cic in - let module U = UriManager in - let module R = CicReduction in - match (R.whd ~subst context c, R.whd ~subst context p, rl) with - (C.Prod (_,so,ta1), C.Lambda (name,_,ta2), b::tl) -> - (* we are sure that the two sources are convertible because we *) - (* have just checked this. So let's go along ... *) - let safes' = - List.map (fun x -> x + 1) safes - in - let safes'' = - if b then 1::safes' else safes' - in - get_new_safes ~subst ((Some (name,(C.Decl so)))::context) - ta2 ta1 tl safes'' (n+1) (nn+1) (x+1) - | (C.Prod _, (C.MutConstruct _ as e), _) - | (C.Prod _, (C.Rel _ as e), _) - | (C.MutInd _, e, []) - | (C.Appl _, e, []) -> (e,safes,n,nn,x,context) - | (c,p,l) -> - (* CSC: If the next exception is raised, it just means that *) - (* CSC: the proof-assistant allows to use very strange things *) - (* 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 - (AssertFailure (lazy - (Printf.sprintf "Get New Safes: c=%s ; p=%s" - (CicPp.ppterm c) (CicPp.ppterm p)))) - -and split_prods ~subst context n te = - let module C = Cic in - let module R = CicReduction in - match (n, R.whd ~subst context te) with - (0, _) -> context,te - | (n, C.Prod (name,so,ta)) when n > 0 -> - split_prods ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta - | (_, _) -> raise (AssertFailure (lazy "8")) - -and eat_lambdas ~subst context n te = - let module C = Cic in - let module R = CicReduction in - match (n, R.whd ~subst context te) with - (0, _) -> (te, 0, context) - | (n, C.Lambda (name,so,ta)) when n > 0 -> - let (te, k, context') = - eat_lambdas ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta - in - (te, k + 1, context') - | (n, te) -> - raise (AssertFailure (lazy (sprintf "9 (%d, %s)" n (CicPp.ppterm te)))) - -(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *) -and check_is_really_smaller_arg ~subst context n nn kl x safes te = - (*CSC: forse la whd si puo' fare solo quando serve veramente. *) - (*CSC: cfr guarded_by_destructors *) - let module C = Cic in - let module U = UriManager in - match CicReduction.whd ~subst context te with - C.Rel m when List.mem m safes -> true - | C.Rel _ -> false - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit _ - | C.Cast _ -(* | C.Cast (te,ty) -> - check_is_really_smaller_arg ~subst n nn kl x safes te && - check_is_really_smaller_arg ~subst n nn kl x safes ty*) -(* | C.Prod (_,so,ta) -> - check_is_really_smaller_arg ~subst n nn kl x safes so && - check_is_really_smaller_arg ~subst (n+1) (nn+1) kl (x+1) - (List.map (fun x -> x + 1) safes) ta*) - | C.Prod _ -> raise (AssertFailure (lazy "10")) - | C.Lambda (name,so,ta) -> - check_is_really_smaller_arg ~subst context n nn kl x safes so && - check_is_really_smaller_arg ~subst ((Some (name,(C.Decl so)))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.LetIn (name,so,ta) -> - check_is_really_smaller_arg ~subst context n nn kl x safes so && - check_is_really_smaller_arg ~subst ((Some (name,(C.Def (so,None))))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.Appl (he::_) -> - (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *) - (*CSC: solo perche' non abbiamo trovato controesempi *) - check_is_really_smaller_arg ~subst context n nn kl x safes he - | C.Appl [] -> raise (AssertFailure (lazy "11")) - | C.Const _ - | C.MutInd _ -> raise (AssertFailure (lazy "12")) - | C.MutConstruct _ -> false - | C.MutCase (uri,i,outtype,term,pl) -> - (match term with - C.Rel m when List.mem m safes || m = x -> - let (tys,len,isinductive,paramsno,cl) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tl,_,paramsno,_) -> - let tys = - List.map - (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) tl - in - let (_,isinductive,_,cl) = List.nth tl i in - let cl' = - List.map - (fun (id,ty) -> - (id, snd (split_prods ~subst tys paramsno ty))) cl - in - (tys,List.length tl,isinductive,paramsno,cl') - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - in - if not isinductive then - List.fold_right - (fun p i -> - i && check_is_really_smaller_arg ~subst context n nn kl x safes p) - pl true - else - let pl_and_cl = - try - List.combine pl cl - with - Invalid_argument _ -> - raise (TypeCheckerFailure (lazy "not enough patterns")) - in - List.fold_right - (fun (p,(_,c)) i -> - let rl' = - 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 ~subst context p c rl' safes n nn x - in - i && - check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e - ) pl_and_cl true - | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> - let (tys,len,isinductive,paramsno,cl) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tl,_,paramsno,_) -> - let (_,isinductive,_,cl) = List.nth tl i in - let tys = - List.map (fun (n,_,ty,_) -> - Some(Cic.Name n,(Cic.Decl ty))) tl - in - let cl' = - List.map - (fun (id,ty) -> - (id, snd (split_prods ~subst tys paramsno ty))) cl - in - (tys,List.length tl,isinductive,paramsno,cl') - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - in - if not isinductive then - List.fold_right - (fun p i -> - i && check_is_really_smaller_arg ~subst context n nn kl x safes p) - pl true - else - let pl_and_cl = - try - List.combine pl cl - with - Invalid_argument _ -> - raise (TypeCheckerFailure (lazy "not enough patterns")) - in - (*CSC: supponiamo come prima che nessun controllo sia necessario*) - (*CSC: sugli argomenti di una applicazione *) - List.fold_right - (fun (p,(_,c)) i -> - let rl' = - 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 ~subst context p c rl' safes n nn x - in - i && - check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e - ) pl_and_cl true - | _ -> - List.fold_right - (fun p i -> - i && check_is_really_smaller_arg ~subst context n nn kl x safes p - ) pl true - ) - | C.Fix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,_,ty,bo) i -> - i && - check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl - x_plus_len safes' bo - ) fl true - | C.CoFix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,ty,bo) i -> - i && - check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl - x_plus_len safes' bo - ) fl true - -and guarded_by_destructors ~subst context n nn kl x safes = - let module C = Cic in - let module U = UriManager in - function - C.Rel m when m > n && m <= nn -> false - | C.Rel m -> - (match List.nth context (n-1) with - Some (_,C.Decl _) -> true - | Some (_,C.Def (bo,_)) -> - guarded_by_destructors ~subst context m nn kl x safes - (CicSubstitution.lift m bo) - | None -> raise (TypeCheckerFailure (lazy "Reference to deleted hypothesis")) - ) - | C.Meta _ - | C.Sort _ - | C.Implicit _ -> true - | C.Cast (te,ty) -> - guarded_by_destructors ~subst context n nn kl x safes te && - guarded_by_destructors ~subst context n nn kl x safes ty - | C.Prod (name,so,ta) -> - guarded_by_destructors ~subst context n nn kl x safes so && - guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.Lambda (name,so,ta) -> - guarded_by_destructors ~subst context n nn kl x safes so && - guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.LetIn (name,so,ta) -> - guarded_by_destructors ~subst context n nn kl x safes so && - guarded_by_destructors ~subst ((Some (name,(C.Def (so,None))))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - let k = List.nth kl (m - n - 1) in - if not (List.length tl > k) then false - else - List.fold_right - (fun param i -> - i && guarded_by_destructors ~subst context n nn kl x safes param - ) tl true && - check_is_really_smaller_arg ~subst context n nn kl x safes (List.nth tl k) - | C.Appl tl -> - List.fold_right - (fun t i -> i && guarded_by_destructors ~subst context n nn kl x safes t) - tl true - | 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 ~subst context n nn kl x safes t) - exp_named_subst true - | C.MutCase (uri,i,outtype,term,pl) -> - (match CicReduction.whd ~subst context term with - C.Rel m when List.mem m safes || m = x -> - let (tys,len,isinductive,paramsno,cl) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tl,_,paramsno,_) -> - let len = List.length tl in - let (_,isinductive,_,cl) = List.nth tl i in - let tys = - List.map (fun (n,_,ty,_) -> - Some(Cic.Name n,(Cic.Decl ty))) tl - in - let cl' = - List.map - (fun (id,ty) -> - let debrujinedty = debrujin_constructor uri len ty in - (id, snd (split_prods ~subst tys paramsno ty), - snd (split_prods ~subst tys paramsno debrujinedty) - )) cl - in - (tys,len,isinductive,paramsno,cl') - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - in - if not isinductive then - guarded_by_destructors ~subst context n nn kl x safes outtype && - guarded_by_destructors ~subst context n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> - i && guarded_by_destructors ~subst context n nn kl x safes p) - pl true - else - let pl_and_cl = - try - List.combine pl cl - with - Invalid_argument _ -> - raise (TypeCheckerFailure (lazy "not enough patterns")) - in - guarded_by_destructors ~subst context n nn kl x safes outtype && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun (p,(_,c,brujinedc)) i -> - let rl' = recursive_args tys 0 len brujinedc in - let (e,safes',n',nn',x',context') = - get_new_safes ~subst context p c rl' safes n nn x - in - i && - guarded_by_destructors ~subst context' n' nn' kl x' safes' e - ) pl_and_cl true - | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> - let (tys,len,isinductive,paramsno,cl) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tl,_,paramsno,_) -> - let (_,isinductive,_,cl) = List.nth tl i in - let tys = - List.map - (fun (n,_,ty,_) -> Some(Cic.Name n,(Cic.Decl ty))) tl - in - let cl' = - List.map - (fun (id,ty) -> - (id, snd (split_prods ~subst tys paramsno ty))) cl - in - (tys,List.length tl,isinductive,paramsno,cl') - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - in - if not isinductive then - guarded_by_destructors ~subst context n nn kl x safes outtype && - guarded_by_destructors ~subst context n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> - i && guarded_by_destructors ~subst context n nn kl x safes p) - pl true - else - let pl_and_cl = - try - List.combine pl cl - with - Invalid_argument _ -> - raise (TypeCheckerFailure (lazy "not enough patterns")) - in - guarded_by_destructors ~subst context n nn kl x safes outtype && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun t i -> - i && guarded_by_destructors ~subst context n nn kl x safes t) - tl true && - List.fold_right - (fun (p,(_,c)) i -> - let rl' = - 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 ~subst context p c rl' safes n nn x - in - i && - guarded_by_destructors ~subst context' n' nn' kl x' safes' e - ) pl_and_cl true - | _ -> - guarded_by_destructors ~subst context n nn kl x safes outtype && - guarded_by_destructors ~subst context n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> i && guarded_by_destructors ~subst context n nn kl x safes p) - pl true - ) - | C.Fix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,_,ty,bo) i -> - i && guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty && - guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl - x_plus_len safes' bo - ) fl true - | C.CoFix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,ty,bo) i -> - i && - guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty && - guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl - x_plus_len safes' bo - ) fl true - -(* the boolean h means already protected *) -(* args is the list of arguments the type of the constructor that may be *) -(* found in head position must be applied to. *) -and guarded_by_constructors ~subst context n nn h te args coInductiveTypeURI = - let module C = Cic in - (*CSC: There is a lot of code replication between the cases X and *) - (*CSC: (C.Appl X tl). Maybe it will be better to define a function *) - (*CSC: that maps X into (C.Appl X []) when X is not already a C.Appl *) - match CicReduction.whd ~subst context te with - C.Rel m when m > n && m <= nn -> h - | C.Rel _ -> true - | C.Meta _ - | C.Sort _ - | C.Implicit _ - | C.Cast _ - | C.Prod _ - | C.LetIn _ -> - (* the term has just been type-checked *) - raise (AssertFailure (lazy "17")) - | C.Lambda (name,so,de) -> - does_not_occur ~subst context n nn so && - guarded_by_constructors ~subst ((Some (name,(C.Decl so)))::context) - (n + 1) (nn + 1) h de args coInductiveTypeURI - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - h && - List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) tl true - | C.Appl ((C.MutConstruct (uri,i,j,exp_named_subst))::tl) -> - let consty = - let obj,_ = - try - CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (itl,_,_,_) -> - let (_,_,_,cl) = List.nth itl i in - let (_,cons) = List.nth cl (j - 1) in - CicSubstitution.subst_vars exp_named_subst cons - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri))) - in - let rec analyse_branch context ty te = - match CicReduction.whd ~subst context ty with - C.Meta _ -> raise (AssertFailure (lazy "34")) - | C.Rel _ - | C.Var _ - | C.Sort _ -> - does_not_occur ~subst context n nn te - | C.Implicit _ - | C.Cast _ -> - raise (AssertFailure (lazy "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 (AssertFailure (lazy "25"))(* due to type-checking *) - | C.Appl ((C.MutInd (uri,_,_))::_) when uri == coInductiveTypeURI -> - guarded_by_constructors ~subst context n nn true te [] - coInductiveTypeURI - | C.Appl ((C.MutInd (uri,_,_))::_) -> - guarded_by_constructors ~subst context n nn true te tl - coInductiveTypeURI - | C.Appl _ -> - does_not_occur ~subst context n nn te - | C.Const _ -> raise (AssertFailure (lazy "26")) - | C.MutInd (uri,_,_) when uri == coInductiveTypeURI -> - guarded_by_constructors ~subst context n nn true te [] - coInductiveTypeURI - | C.MutInd _ -> - does_not_occur ~subst context n nn te - | C.MutConstruct _ -> raise (AssertFailure (lazy "27")) - (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *) - (*CSC: in head position. *) - | C.MutCase _ - | C.Fix _ - | C.CoFix _ -> - raise (AssertFailure (lazy "28"))(* due to type-checking *) - in - let rec analyse_instantiated_type context ty l = - match CicReduction.whd ~subst context ty with - C.Rel _ - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit _ - | C.Cast _ -> raise (AssertFailure (lazy "29"))(* due to type-checking *) - | C.Prod (name,so,de) -> - begin - match l with - [] -> true - | he::tl -> - analyse_branch context so he && - analyse_instantiated_type - ((Some (name,(C.Decl so)))::context) de tl - end - | C.Lambda _ - | C.LetIn _ -> - raise (AssertFailure (lazy "30"))(* due to type-checking *) - | C.Appl _ -> - List.fold_left - (fun i x -> i && does_not_occur ~subst context n nn x) true l - | C.Const _ -> raise (AssertFailure (lazy "31")) - | C.MutInd _ -> - List.fold_left - (fun i x -> i && does_not_occur ~subst context n nn x) true l - | C.MutConstruct _ -> raise (AssertFailure (lazy "32")) - (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *) - (*CSC: in head position. *) - | C.MutCase _ - | C.Fix _ - | C.CoFix _ -> - raise (AssertFailure (lazy "33"))(* due to type-checking *) - in - let rec instantiate_type args consty = - function - [] -> true - | tlhe::tltl as l -> - let consty' = CicReduction.whd ~subst context consty in - match args with - he::tl -> - begin - match consty' with - C.Prod (_,_,de) -> - let instantiated_de = CicSubstitution.subst he de in - (*CSC: siamo sicuri che non sia troppo forte? *) - does_not_occur ~subst context n nn tlhe & - instantiate_type tl instantiated_de tltl - | _ -> - (*CSC:We do not consider backbones with a MutCase, a *) - (*CSC:FixPoint, a CoFixPoint and so on in head position.*) - raise (AssertFailure (lazy "23")) - end - | [] -> analyse_instantiated_type context consty' l - (* These are all the other cases *) - in - instantiate_type args consty tl - | C.Appl ((C.CoFix (_,fl))::tl) -> - List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl && - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *) - and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len - h bo args coInductiveTypeURI - ) fl true - | C.Appl ((C.MutCase (_,_,out,te,pl))::tl) -> - List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl && - does_not_occur ~subst context n nn out && - does_not_occur ~subst context n nn te && - List.fold_right - (fun x i -> - i && - guarded_by_constructors ~subst context n nn h x args - coInductiveTypeURI - ) pl true - | C.Appl l -> - List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true - | C.Var (_,exp_named_subst) - | C.Const (_,exp_named_subst) -> - List.fold_right - (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true - | C.MutInd _ -> assert false - | C.MutConstruct (_,_,_,exp_named_subst) -> - List.fold_right - (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true - | C.MutCase (_,_,out,te,pl) -> - does_not_occur ~subst context n nn out && - does_not_occur ~subst context n nn te && - List.fold_right - (fun x i -> - i && - guarded_by_constructors ~subst context n nn h x args - coInductiveTypeURI - ) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *) - and tys = List.map (fun (n,_,ty,_)-> Some (C.Name n,(C.Decl ty))) fl in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - does_not_occur ~subst (tys@context) n_plus_len nn_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *) - and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len - h bo - args coInductiveTypeURI - ) fl true - -and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i - need_dummy ind arity1 arity2 ugraph = - let module C = Cic in - let module U = UriManager in - let arity1 = CicReduction.whd ~subst context arity1 in - let rec check_allowed_sort_elimination_aux ugraph context arity2 need_dummy = - match arity1, CicReduction.whd ~subst context arity2 with - (C.Prod (_,so1,de1), C.Prod (_,so2,de2)) -> - let b,ugraph1 = - CicReduction.are_convertible ~subst ~metasenv context so1 so2 ugraph in - if b then - check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i - need_dummy (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2 - ugraph1 - else - false,ugraph1 - | (C.Sort _, C.Prod (name,so,ta)) when not need_dummy -> - let b,ugraph1 = - CicReduction.are_convertible ~subst ~metasenv context so ind ugraph in - if not b then - false,ugraph1 - else - check_allowed_sort_elimination_aux ugraph1 - ((Some (name,C.Decl so))::context) ta true - | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true,ugraph - | (C.Sort C.Prop, C.Sort C.Set) - | (C.Sort C.Prop, C.Sort C.CProp) - | (C.Sort C.Prop, C.Sort (C.Type _) ) when need_dummy -> - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (itl,_,paramsno,_) -> - let itl_len = List.length itl in - let (name,_,ty,cl) = List.nth itl i in - let cl_len = List.length cl in - if (cl_len = 0 || (itl_len = 1 && cl_len = 1)) then - let non_informative,ugraph = - if cl_len = 0 then true,ugraph - else - is_non_informative ~logger [Some (C.Name name,C.Decl ty)] - paramsno (snd (List.nth cl 0)) ugraph - in - (* is it a singleton or empty non recursive and non informative - definition? *) - non_informative, ugraph - else - false,ugraph - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true , ugraph - | (C.Sort C.CProp, C.Sort C.Prop) when need_dummy -> true , ugraph - | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true , ugraph - | (C.Sort C.Set, C.Sort C.CProp) when need_dummy -> true , ugraph - | (C.Sort C.CProp, C.Sort C.Set) when need_dummy -> true , ugraph - | (C.Sort C.CProp, C.Sort C.CProp) when need_dummy -> true , ugraph - | ((C.Sort C.Set, C.Sort (C.Type _)) | (C.Sort C.CProp, C.Sort (C.Type _))) - when need_dummy -> - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (itl,_,paramsno,_) -> - let tys = - List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl - in - let (_,_,_,cl) = List.nth itl i in - (List.fold_right - (fun (_,x) (i,ugraph) -> - if i then - is_small ~logger tys paramsno x ugraph - else - false,ugraph - ) cl (true,ugraph)) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | (C.Sort (C.Type _), C.Sort _) when need_dummy -> true , ugraph - | (_,_) -> false,ugraph - in - check_allowed_sort_elimination_aux ugraph context arity2 need_dummy - -and type_of_branch ~subst context argsno need_dummy outtype term constype = - let module C = Cic in - let module R = CicReduction in - match R.whd ~subst context constype with - C.MutInd (_,_,_) -> - if need_dummy then - outtype - else - C.Appl [outtype ; term] - | C.Appl (C.MutInd (_,_,_)::tl) -> - let (_,arguments) = split tl argsno - in - if need_dummy && arguments = [] then - outtype - else - C.Appl (outtype::arguments@(if need_dummy then [] else [term])) - | C.Prod (name,so,de) -> - let term' = - match CicSubstitution.lift 1 term with - C.Appl l -> C.Appl (l@[C.Rel 1]) - | t -> C.Appl [t ; C.Rel 1] - in - C.Prod (C.Anonymous,so,type_of_branch ~subst - ((Some (name,(C.Decl so)))::context) argsno need_dummy - (CicSubstitution.lift 1 outtype) term' de) - | _ -> raise (AssertFailure (lazy "20")) - -(* 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 ~logger ~subst metasenv context - canonical_context l ugraph -= - 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.subst_meta l (S.lift i t))))::(aux (i+1) tl) - | (Some (n,C.Def (t,None)))::tl -> - (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl) - | None::tl -> None::(aux (i+1) tl) - | (Some (n,C.Def (t,Some ty)))::tl -> - (Some (n,C.Def ((S.subst_meta l (S.lift i t)),Some (S.subst_meta l (S.lift i ty)))))::(aux (i+1) tl) - in - aux 1 canonical_context - in - List.fold_left2 - (fun ugraph t ct -> - match (t,ct) with - | _,None -> ugraph - | Some t,Some (_,C.Def (ct,_)) -> - let b,ugraph1 = - R.are_convertible ~subst ~metasenv context t ct ugraph - in - if not b then - raise - (TypeCheckerFailure - (lazy (sprintf "Not well typed metavariable local context: expected a term convertible with %s, found %s" (CicPp.ppterm ct) (CicPp.ppterm t)))) - else - ugraph1 - | Some t,Some (_,C.Decl ct) -> - let type_t,ugraph1 = - type_of_aux' ~logger ~subst metasenv context t ugraph - in - let b,ugraph2 = - R.are_convertible ~subst ~metasenv context type_t ct ugraph1 - in - if not b then - raise (TypeCheckerFailure - (lazy (sprintf "Not well typed metavariable local context: expected a term of type %s, found %s of type %s" - (CicPp.ppterm ct) (CicPp.ppterm t) - (CicPp.ppterm type_t)))) - else - ugraph2 - | None, _ -> - raise (TypeCheckerFailure - (lazy ("Not well typed metavariable local context: "^ - "an hypothesis, that is not hidden, is not instantiated"))) - ) ugraph l lifted_canonical_context - - -(* - type_of_aux' is just another name (with a different scope) - for type_of_aux -*) - -and type_of_aux' ~logger ?(subst = []) metasenv context t ugraph = - let rec type_of_aux ~logger context t ugraph = - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module U = UriManager in - match t with - C.Rel n -> - (try - match List.nth context (n - 1) with - Some (_,C.Decl t) -> S.lift n t,ugraph - | Some (_,C.Def (_,Some ty)) -> S.lift n ty,ugraph - | Some (_,C.Def (bo,None)) -> - debug_print (lazy "##### CASO DA INVESTIGARE E CAPIRE") ; - type_of_aux ~logger context (S.lift n bo) ugraph - | None -> raise - (TypeCheckerFailure (lazy "Reference to deleted hypothesis")) - with - _ -> - raise (TypeCheckerFailure (lazy "unbound variable")) - ) - | C.Var (uri,exp_named_subst) -> - incr fdebug ; - let ugraph1 = - check_exp_named_subst ~logger ~subst context exp_named_subst ugraph - in - let ty,ugraph2 = type_of_variable ~logger uri ugraph1 in - let ty1 = CicSubstitution.subst_vars exp_named_subst ty in - decr fdebug ; - ty1,ugraph2 - | C.Meta (n,l) -> - (try - let (canonical_context,term,ty) = CicUtil.lookup_subst n subst in - let ugraph1 = - check_metasenv_consistency ~logger - ~subst metasenv context canonical_context l ugraph - in - (* assuming subst is well typed !!!!! *) - ((CicSubstitution.subst_meta l ty), ugraph1) - (* type_of_aux context (CicSubstitution.subst_meta l term) *) - with CicUtil.Subst_not_found _ -> - let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in - let ugraph1 = - check_metasenv_consistency ~logger - ~subst metasenv context canonical_context l ugraph - in - ((CicSubstitution.subst_meta l ty),ugraph1)) - (* TASSI: CONSTRAINTS *) - | C.Sort (C.Type t) -> - let t' = CicUniv.fresh() in - let ugraph1 = CicUniv.add_gt t' t ugraph in - (C.Sort (C.Type t')),ugraph1 - (* TASSI: CONSTRAINTS *) - | C.Sort s -> (C.Sort (C.Type (CicUniv.fresh ()))),ugraph - | C.Implicit _ -> raise (AssertFailure (lazy "21")) - | C.Cast (te,ty) as t -> - let _,ugraph1 = type_of_aux ~logger context ty ugraph in - let ty_te,ugraph2 = type_of_aux ~logger context te ugraph1 in - let b,ugraph3 = - R.are_convertible ~subst ~metasenv context ty_te ty ugraph2 - in - if b then - ty,ugraph3 - else - raise (TypeCheckerFailure - (lazy (sprintf "Invalid cast %s" (CicPp.ppterm t)))) - | C.Prod (name,s,t) -> - let sort1,ugraph1 = type_of_aux ~logger context s ugraph in - let sort2,ugraph2 = - type_of_aux ~logger ((Some (name,(C.Decl s)))::context) t ugraph1 - in - sort_of_prod ~subst context (name,s) (sort1,sort2) ugraph2 - | C.Lambda (n,s,t) -> - let sort1,ugraph1 = type_of_aux ~logger context s ugraph in - (match R.whd ~subst context sort1 with - C.Meta _ - | C.Sort _ -> () - | _ -> - raise - (TypeCheckerFailure (lazy (sprintf - "Not well-typed lambda-abstraction: the source %s should be a type; instead it is a term of type %s" (CicPp.ppterm s) - (CicPp.ppterm sort1)))) - ) ; - let type2,ugraph2 = - type_of_aux ~logger ((Some (n,(C.Decl s)))::context) t ugraph1 - in - (C.Prod (n,s,type2)),ugraph2 - | C.LetIn (n,s,t) -> - (* only to check if s is well-typed *) - let ty,ugraph1 = type_of_aux ~logger context s ugraph in - (* 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 ~subst 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. *) - let ty1,ugraph2 = - type_of_aux ~logger - ((Some (n,(C.Def (s,Some ty))))::context) t ugraph1 - in - (CicSubstitution.subst s ty1),ugraph2 - | C.Appl (he::tl) when List.length tl > 0 -> - let hetype,ugraph1 = type_of_aux ~logger context he ugraph in - let tlbody_and_type,ugraph2 = - List.fold_right ( - fun x (l,ugraph) -> - let ty,ugraph1 = type_of_aux ~logger context x ugraph in - let _,ugraph1 = type_of_aux ~logger context ty ugraph1 in - ((x,ty)::l,ugraph1)) - tl ([],ugraph1) - in - (* TASSI: questa c'era nel mio... ma non nel CVS... *) - (* let _,ugraph2 = type_of_aux context hetype ugraph2 in *) - eat_prods ~subst context hetype tlbody_and_type ugraph2 - | C.Appl _ -> raise (AssertFailure (lazy "Appl: no arguments")) - | C.Const (uri,exp_named_subst) -> - incr fdebug ; - let ugraph1 = - check_exp_named_subst ~logger ~subst context exp_named_subst ugraph - in - let cty,ugraph2 = type_of_constant ~logger uri ugraph1 in - let cty1 = - CicSubstitution.subst_vars exp_named_subst cty - in - decr fdebug ; - cty1,ugraph2 - | C.MutInd (uri,i,exp_named_subst) -> - incr fdebug ; - let ugraph1 = - check_exp_named_subst ~logger ~subst context exp_named_subst ugraph - in - (* TASSI: da me c'era anche questa, ma in CVS no *) - let mty,ugraph2 = type_of_mutual_inductive_defs ~logger uri i ugraph1 in - (* fine parte dubbia *) - let cty = - CicSubstitution.subst_vars exp_named_subst mty - in - decr fdebug ; - cty,ugraph2 - | C.MutConstruct (uri,i,j,exp_named_subst) -> - let ugraph1 = - check_exp_named_subst ~logger ~subst context exp_named_subst ugraph - in - (* TASSI: idem come sopra *) - let mty,ugraph2 = - type_of_mutual_inductive_constr ~logger uri i j ugraph1 - in - let cty = - CicSubstitution.subst_vars exp_named_subst mty - in - cty,ugraph2 - | C.MutCase (uri,i,outtype,term,pl) -> - let outsort,ugraph1 = type_of_aux ~logger context outtype ugraph in - let (need_dummy, k) = - let rec guess_args context t = - let outtype = CicReduction.whd ~subst context t in - match outtype with - C.Sort _ -> (true, 0) - | C.Prod (name, s, t) -> - let (b, n) = - guess_args ((Some (name,(C.Decl s)))::context) t in - if n = 0 then - (* last prod before sort *) - match CicReduction.whd ~subst context s with -(*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 - (TypeCheckerFailure - (lazy (sprintf - "Malformed case analasys' output type %s" - (CicPp.ppterm outtype)))) - in -(* - let (parameters, arguments, exp_named_subst),ugraph2 = - let ty,ugraph2 = type_of_aux context term ugraph1 in - match R.whd ~subst context ty with - (*CSC manca il caso dei CAST *) -(*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),ugraph2 - else - raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s, but is expected to be (an application of) %s#1/%d{_}") - (CicPp.ppterm typ) (U.string_of_uri uri) i))) - | C.Appl - ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' -> - if U.eq uri uri' && i = i' then - let params,args = - split tl (List.length tl - k) - in (params,args,exp_named_subst),ugraph2 - else - raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s, "^ - "but is expected to be (an application of) "^ - "%s#1/%d{_}") - (CicPp.ppterm typ') (U.string_of_uri uri) i))) - | _ -> - raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysis: "^ - "analysed term %s is not an inductive one") - (CicPp.ppterm term)))) -*) - let (b, k) = guess_args context outsort in - if not b then (b, k - 1) else (b, k) in - let (parameters, arguments, exp_named_subst),ugraph2 = - let ty,ugraph2 = type_of_aux ~logger context term ugraph1 in - match R.whd ~subst context ty with - C.MutInd (uri',i',exp_named_subst) as typ -> - if U.eq uri uri' && i = i' then - ([],[],exp_named_subst),ugraph2 - else raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}") - (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) 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),ugraph2 - else raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}") - (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i))) - | _ -> - raise - (TypeCheckerFailure - (lazy (sprintf - "Case analysis: analysed term %s is not an inductive one" - (CicPp.ppterm term)))) - 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,i,exp_named_subst) - else - C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters) - in - let type_of_sort_of_ind_ty,ugraph3 = - type_of_aux ~logger context sort_of_ind_type ugraph2 in - let b,ugraph4 = - check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i - need_dummy sort_of_ind_type type_of_sort_of_ind_ty outsort ugraph3 - in - if not b then - raise - (TypeCheckerFailure (lazy ("Case analasys: sort elimination not allowed"))); - (* let's check if the type of branches are right *) - let parsno = - let obj,_ = - try - CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (_,_,parsno,_) -> parsno - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - in - let (_,branches_ok,ugraph5) = - List.fold_left - (fun (j,b,ugraph) p -> - if b then - let cons = - if parameters = [] then - (C.MutConstruct (uri,i,j,exp_named_subst)) - else - (C.Appl - (C.MutConstruct (uri,i,j,exp_named_subst)::parameters)) - in - let ty_p,ugraph1 = type_of_aux ~logger context p ugraph in - let ty_cons,ugraph3 = type_of_aux ~logger context cons ugraph1 in - (* 2 is skipped *) - let ty_branch = - type_of_branch ~subst context parsno need_dummy outtype cons - ty_cons in - let b1,ugraph4 = - R.are_convertible - ~subst ~metasenv context ty_p ty_branch ugraph3 - in - if not b1 then - debug_print (lazy - ("#### " ^ CicPp.ppterm ty_p ^ - " <==> " ^ CicPp.ppterm ty_branch)); - (j + 1,b1,ugraph4) - else - (j,false,ugraph) - ) (1,true,ugraph4) pl - in - if not branches_ok then - raise - (TypeCheckerFailure (lazy "Case analysys: wrong branch type")); - let arguments' = - if not need_dummy then outtype::arguments@[term] - else outtype::arguments in - let outtype = - if need_dummy && arguments = [] then outtype - else CicReduction.head_beta_reduce (C.Appl arguments') - in - outtype,ugraph5 - | C.Fix (i,fl) -> - let types_times_kl,ugraph1 = - (* WAS: list rev list map *) - List.fold_left - (fun (l,ugraph) (n,k,ty,_) -> - let _,ugraph1 = type_of_aux ~logger context ty ugraph in - ((Some (C.Name n,(C.Decl ty)),k)::l,ugraph1) - ) ([],ugraph) fl - in - let (types,kl) = List.split types_times_kl in - let len = List.length types in - let ugraph2 = - List.fold_left - (fun ugraph (name,x,ty,bo) -> - let ty_bo,ugraph1 = - type_of_aux ~logger (types@context) bo ugraph - in - let b,ugraph2 = - R.are_convertible ~subst ~metasenv (types@context) - ty_bo (CicSubstitution.lift len ty) ugraph1 in - if b then - begin - let (m, eaten, context') = - eat_lambdas ~subst (types @ context) (x + 1) bo - in - (* - let's control the guarded by - destructors conditions D{f,k,x,M} - *) - if not (guarded_by_destructors ~subst context' eaten - (len + eaten) kl 1 [] m) then - raise - (TypeCheckerFailure - (lazy ("Fix: not guarded by destructors"))) - else - ugraph2 - end - else - raise (TypeCheckerFailure (lazy ("Fix: ill-typed bodies"))) - ) ugraph1 fl in - (*CSC: controlli mancanti solo su D{f,k,x,M} *) - let (_,_,ty,_) = List.nth fl i in - ty,ugraph2 - | C.CoFix (i,fl) -> - let types,ugraph1 = - List.fold_left - (fun (l,ugraph) (n,ty,_) -> - let _,ugraph1 = - type_of_aux ~logger context ty ugraph in - (Some (C.Name n,(C.Decl ty))::l,ugraph1) - ) ([],ugraph) fl - in - let len = List.length types in - let ugraph2 = - List.fold_left - (fun ugraph (_,ty,bo) -> - let ty_bo,ugraph1 = - type_of_aux ~logger (types @ context) bo ugraph - in - let b,ugraph2 = - R.are_convertible ~subst ~metasenv (types @ context) ty_bo - (CicSubstitution.lift len ty) ugraph1 - in - if b then - begin - (* let's control that the returned type is coinductive *) - match returns_a_coinductive ~subst context ty with - None -> - raise - (TypeCheckerFailure - (lazy "CoFix: does not return a coinductive type")) - | Some uri -> - (* - let's control the guarded by constructors - conditions C{f,M} - *) - if not (guarded_by_constructors ~subst - (types @ context) 0 len false bo [] uri) then - raise - (TypeCheckerFailure - (lazy "CoFix: not guarded by constructors")) - else - ugraph2 - end - else - raise - (TypeCheckerFailure (lazy "CoFix: ill-typed bodies")) - ) ugraph1 fl - in - let (_,ty,_) = List.nth fl i in - ty,ugraph2 - - and check_exp_named_subst ~logger ~subst context ugraph = - let rec check_exp_named_subst_aux ~logger esubsts l ugraph = - match l with - [] -> ugraph - | ((uri,t) as item)::tl -> - let ty_uri,ugraph1 = type_of_variable ~logger uri ugraph in - let typeofvar = - CicSubstitution.subst_vars esubsts ty_uri in - let typeoft,ugraph2 = type_of_aux ~logger context t ugraph1 in - let b,ugraph3 = - CicReduction.are_convertible ~subst ~metasenv - context typeoft typeofvar ugraph2 - in - if b then - check_exp_named_subst_aux ~logger (esubsts@[item]) tl ugraph3 - else - begin - CicReduction.fdebug := 0 ; - ignore - (CicReduction.are_convertible - ~subst ~metasenv context typeoft typeofvar ugraph2) ; - fdebug := 0 ; - debug typeoft [typeofvar] ; - raise (TypeCheckerFailure (lazy "Wrong Explicit Named Substitution")) - end - in - check_exp_named_subst_aux ~logger [] ugraph - - and sort_of_prod ~subst context (name,s) (t1, t2) ugraph = - let module C = Cic in - let t1' = CicReduction.whd ~subst context t1 in - let t2' = CicReduction.whd ~subst ((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 or s2 = C.CProp) -> - (* different from Coq manual!!! *) - C.Sort s2,ugraph - | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> - (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *) - let t' = CicUniv.fresh() in - let ugraph1 = CicUniv.add_ge t' t1 ugraph in - let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in - C.Sort (C.Type t'),ugraph2 - | (C.Sort _,C.Sort (C.Type t1)) -> - (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *) - C.Sort (C.Type t1),ugraph (* c'e' bisogno di un fresh? *) - | (C.Meta _, C.Sort _) -> t2',ugraph - | (C.Meta _, (C.Meta (_,_) as t)) - | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t -> - t2',ugraph - | (_,_) -> raise (TypeCheckerFailure (lazy (sprintf - "Prod: expected two sorts, found = %s, %s" (CicPp.ppterm t1') - (CicPp.ppterm t2')))) - - and eat_prods ~subst context hetype l ugraph = - (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *) - (*CSC: cucinati *) - match l with - [] -> hetype,ugraph - | (hete, hety)::tl -> - (match (CicReduction.whd ~subst context hetype) with - Cic.Prod (n,s,t) -> - let b,ugraph1 = - CicReduction.are_convertible - ~subst ~metasenv context hety s ugraph - in - if b then - begin - CicReduction.fdebug := -1 ; - eat_prods ~subst context - (CicSubstitution.subst hete t) tl ugraph1 - (*TASSI: not sure *) - end - else - begin - CicReduction.fdebug := 0 ; - ignore (CicReduction.are_convertible - ~subst ~metasenv context s hety ugraph) ; - fdebug := 0 ; - debug s [hety] ; - raise - (TypeCheckerFailure - (lazy (sprintf - ("Appl: wrong parameter-type, expected %s, found %s") - (CicPp.ppterm hetype) (CicPp.ppterm s)))) - end - | _ -> - raise (TypeCheckerFailure - (lazy "Appl: this is not a function, it cannot be applied")) - ) - - and returns_a_coinductive ~subst context ty = - let module C = Cic in - match CicReduction.whd ~subst context ty with - C.MutInd (uri,i,_) -> - (*CSC: definire una funzioncina per questo codice sempre replicato *) - let obj,_ = - try - CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri - with Not_found -> assert false - in - (match obj with - C.InductiveDefinition (itl,_,_,_) -> - let (_,is_inductive,_,_) = List.nth itl i in - if is_inductive then None else (Some uri) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | C.Appl ((C.MutInd (uri,i,_))::_) -> - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (itl,_,_,_) -> - let (_,is_inductive,_,_) = List.nth itl i in - if is_inductive then None else (Some uri) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | C.Prod (n,so,de) -> - returns_a_coinductive ~subst ((Some (n,C.Decl so))::context) de - | _ -> None - - in -(*CSC -debug_print (lazy ("INIZIO TYPE_OF_AUX " ^ CicPp.ppterm t)) ; flush stderr ; -let res = -*) - type_of_aux ~logger context t ugraph -(* -in debug_print (lazy "FINE TYPE_OF_AUX") ; flush stderr ; res -*) - -(* is a small constructor? *) -(*CSC: ottimizzare calcolando staticamente *) -and is_small_or_non_informative ~condition ~logger context paramsno c ugraph = - let rec is_small_or_non_informative_aux ~logger context c ugraph = - let module C = Cic in - match CicReduction.whd context c with - C.Prod (n,so,de) -> - let s,ugraph1 = type_of_aux' ~logger [] context so ugraph in - let b = condition s in - if b then - is_small_or_non_informative_aux - ~logger ((Some (n,(C.Decl so)))::context) de ugraph1 - else - false,ugraph1 - | _ -> true,ugraph (*CSC: we trust the type-checker *) - in - let (context',dx) = split_prods ~subst:[] context paramsno c in - is_small_or_non_informative_aux ~logger context' dx ugraph - -and is_small ~logger = - is_small_or_non_informative - ~condition:(fun s -> s=Cic.Sort Cic.Prop || s=Cic.Sort Cic.Set) - ~logger - -and is_non_informative ~logger = - is_small_or_non_informative - ~condition:(fun s -> s=Cic.Sort Cic.Prop) - ~logger - -and type_of ~logger t ugraph = -(*CSC -debug_print (lazy ("INIZIO TYPE_OF_AUX' " ^ CicPp.ppterm t)) ; flush stderr ; -let res = -*) - type_of_aux' ~logger [] [] t ugraph -(*CSC -in debug_print (lazy "FINE TYPE_OF_AUX'") ; flush stderr ; res -*) -;; - -let typecheck_obj0 ~logger uri ugraph = - let module C = Cic in - function - C.Constant (_,Some te,ty,_,_) -> - let _,ugraph = type_of ~logger ty ugraph in - let ty_te,ugraph = type_of ~logger te ugraph in - let b,ugraph = (CicReduction.are_convertible [] ty_te ty ugraph) in - if not b then - raise (TypeCheckerFailure - (lazy - ("the type of the body is not the one expected:\n" ^ - CicPp.ppterm ty_te ^ "\nvs\n" ^ - CicPp.ppterm ty))) - else - ugraph - | C.Constant (_,None,ty,_,_) -> - (* only to check that ty is well-typed *) - let _,ugraph = type_of ~logger ty ugraph in - ugraph - | C.CurrentProof (_,conjs,te,ty,_,_) -> - let _,ugraph = - List.fold_left - (fun (metasenv,ugraph) ((_,context,ty) as conj) -> - let _,ugraph = - type_of_aux' ~logger metasenv context ty ugraph - in - metasenv @ [conj],ugraph - ) ([],ugraph) conjs - in - let _,ugraph = type_of_aux' ~logger conjs [] ty ugraph in - let type_of_te,ugraph = - type_of_aux' ~logger conjs [] te ugraph - in - let b,ugraph = CicReduction.are_convertible [] type_of_te ty ugraph in - if not b then - raise (TypeCheckerFailure (lazy (sprintf - "the current proof is not well typed because the type %s of the body is not convertible to the declared type %s" - (CicPp.ppterm type_of_te) (CicPp.ppterm ty)))) - else - ugraph - | C.Variable (_,bo,ty,_,_) -> - (* only to check that ty is well-typed *) - let _,ugraph = type_of ~logger ty ugraph in - (match bo with - None -> ugraph - | Some bo -> - let ty_bo,ugraph = type_of ~logger bo ugraph in - let b,ugraph = CicReduction.are_convertible [] ty_bo ty ugraph in - if not b then - raise (TypeCheckerFailure - (lazy "the body is not the one expected")) - else - ugraph - ) - | (C.InductiveDefinition _ as obj) -> - check_mutual_inductive_defs ~logger uri obj ugraph - -let typecheck uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let logger = new CicLogger.logger in - (* ??? match CicEnvironment.is_type_checked ~trust:true uri with ???? *) - match CicEnvironment.is_type_checked ~trust:false CicUniv.empty_ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> - (* debug_print (lazy ("NON-INIZIO A TYPECHECKARE " ^ U.string_of_uri uri));*) - cobj,ugraph' - | CicEnvironment.UncheckedObj uobj -> - (* let's typecheck the uncooked object *) - logger#log (`Start_type_checking uri) ; - (* debug_print (lazy ("INIZIO A TYPECHECKARE " ^ U.string_of_uri uri)); *) - let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph uobj in - try - CicEnvironment.set_type_checking_info uri; - logger#log (`Type_checking_completed uri); - match CicEnvironment.is_type_checked ~trust:false ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | _ -> raise CicEnvironmentError - with - (* - this is raised if set_type_checking_info is called on an object - that has no associated universe file. If we are in univ_maker - phase this is OK since univ_maker will properly commit the - object. - *) - Invalid_argument s -> - (*debug_print (lazy s);*) - uobj,ugraph -;; - -let typecheck_obj ~logger uri obj = - let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph obj in - let ugraph, univlist, obj = CicUnivUtils.clean_and_fill uri obj ugraph in - CicEnvironment.add_type_checked_obj uri (obj,ugraph,univlist) - -(** wrappers which instantiate fresh loggers *) - -let type_of_aux' ?(subst = []) metasenv context t ugraph = - let logger = new CicLogger.logger in - type_of_aux' ~logger ~subst metasenv context t ugraph - -let typecheck_obj uri obj = - let logger = new CicLogger.logger in - typecheck_obj ~logger uri obj - -(* check_allowed_sort_elimination uri i s1 s2 - This function is used outside the kernel to determine in advance whether - a MutCase will be allowed or not. - [uri,i] is the type of the term to match - [s1] is the sort of the term to eliminate (i.e. the head of the arity - of the inductive type [uri,i]) - [s2] is the sort of the goal (i.e. the head of the type of the outtype - of the MutCase) *) -let check_allowed_sort_elimination uri i s1 s2 = - fst (check_allowed_sort_elimination ~subst:[] ~metasenv:[] - ~logger:(new CicLogger.logger) [] uri i true - (Cic.Implicit None) (* never used *) (Cic.Sort s1) (Cic.Sort s2) - CicUniv.empty_ugraph) diff --git a/helm/ocaml/cic_proof_checking/cicTypeChecker.mli b/helm/ocaml/cic_proof_checking/cicTypeChecker.mli deleted file mode 100644 index e9419171e..000000000 --- a/helm/ocaml/cic_proof_checking/cicTypeChecker.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* 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/. - *) - -(* These are the only exceptions that will be raised *) -exception TypeCheckerFailure of string Lazy.t -exception AssertFailure of string Lazy.t - -(* this function is exported to be used also by the refiner; - the callback function (defaul value: ignore) is invoked on each - processed subterm; its first argument is the undebrujined term (the - input); its second argument the corresponding debrujined term (the - output). The callback is used to relocalize the error messages *) -val debrujin_constructor : - ?cb:(Cic.term -> Cic.term -> unit) -> - UriManager.uri -> int -> Cic.term -> Cic.term - -val typecheck : UriManager.uri -> Cic.obj * CicUniv.universe_graph - -(* FUNCTIONS USED ONLY IN THE TOPLEVEL *) - -(* type_of_aux' metasenv context term *) -val type_of_aux': - ?subst:Cic.substitution -> Cic.metasenv -> Cic.context -> - Cic.term -> CicUniv.universe_graph -> - Cic.term * CicUniv.universe_graph - -(* typechecks the obj and puts it in the environment *) -val typecheck_obj : UriManager.uri -> Cic.obj -> unit - -(* check_allowed_sort_elimination uri i s1 s2 - This function is used outside the kernel to determine in advance whether - a MutCase will be allowed or not. - [uri,i] is the type of the term to match - [s1] is the sort of the term to eliminate (i.e. the head of the arity - of the inductive type [uri,i]) - [s2] is the sort of the goal (i.e. the head of the type of the outtype - of the MutCase) *) -val check_allowed_sort_elimination: - UriManager.uri -> int -> Cic.sort -> Cic.sort -> bool diff --git a/helm/ocaml/cic_proof_checking/cicUnivUtils.ml b/helm/ocaml/cic_proof_checking/cicUnivUtils.ml deleted file mode 100644 index cd1aeba32..000000000 --- a/helm/ocaml/cic_proof_checking/cicUnivUtils.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* 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 *) -(* *) -(* Enrico Tassi *) -(* 23/04/2004 *) -(* *) -(* This module implements some useful function regarding univers graphs *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -module C = Cic -module H = UriManager.UriHashtbl -let eq = UriManager.eq - -(* uri is the uri of the actual object that must be 'skipped' *) -let universes_of_obj uri t = - (* don't the same work twice *) - let visited_objs = H.create 31 in - let visited u = H.replace visited_objs u true in - let is_not_visited u = not (H.mem visited_objs u) in - visited uri; - (* the result *) - let results = ref [] in - let add_result l = results := l :: !results in - (* the iterators *) - let rec aux = function - | C.Const (u,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.Const (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Var (u,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.Var (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Const (u,exp_named_subst) -> - C.Const (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Var (u,exp_named_subst) -> - C.Var (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutInd (u,x,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.MutInd (u,x,List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutInd (u,x,exp_named_subst) -> - C.MutInd (u,x, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutConstruct (u,x,y,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.MutConstruct (u,x,y,List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutConstruct (x,y,z,exp_named_subst) -> - C.MutConstruct (x,y,z,List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Meta (n,l1) -> C.Meta (n, List.map (HExtlib.map_option aux) l1) - | C.Sort (C.Type i) -> add_result [i]; - C.Sort (C.Type (CicUniv.name_universe i uri)) - | C.Rel _ - | C.Sort _ - | C.Implicit _ as x -> x - | C.Cast (v,t) -> C.Cast (aux v, aux t) - | C.Prod (b,s,t) -> C.Prod (b,aux s, aux t) - | C.Lambda (b,s,t) -> C.Lambda (b,aux s, aux t) - | C.LetIn (b,s,t) -> C.LetIn (b,aux s, aux t) - | C.Appl li -> C.Appl (List.map aux li) - | C.MutCase (uri,n1,ty,te,patterns) -> - C.MutCase (uri,n1,aux ty,aux te, List.map aux patterns) - | C.Fix (no, funs) -> - C.Fix(no, List.map (fun (x,y,b,c) -> (x,y,aux b,aux c)) funs) - | C.CoFix (no,funs) -> - C.CoFix(no, List.map (fun (x,b,c) -> (x,aux b,aux c)) funs) - and aux_uri u = - if is_not_visited u then - let _, _, l = - CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph u in - add_result l - and aux_obj = function - | C.Constant (x,Some te,ty,v,y) -> - List.iter aux_uri v; - C.Constant (x,Some (aux te),aux ty,v,y) - | C.Variable (x,Some te,ty,v,y) -> - List.iter aux_uri v; - C.Variable (x,Some (aux te),aux ty,v,y) - | C.Constant (x,None, ty, v,y) -> - List.iter aux_uri v; - C.Constant (x,None, aux ty, v,y) - | C.Variable (x,None, ty, v,y) -> - List.iter aux_uri v; - C.Variable (x,None, aux ty, v,y) - | C.CurrentProof (_,conjs,te,ty,v,_) -> assert false - | C.InductiveDefinition (l,v,x,y) -> - List.iter aux_uri v; - C.InductiveDefinition ( - List.map - (fun (x,y,t,l') -> - (x,y,aux t, List.map (fun (x,t) -> x,aux t) l')) - l,v,x,y) - in - let o = aux_obj t in - List.flatten !results, o - -let rec list_uniq = function - | [] -> [] - | h::[] -> [h] - | h1::h2::tl when CicUniv.eq h1 h2 -> list_uniq (h2 :: tl) - | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq tl - -let list_uniq l = - list_uniq (List.fast_sort CicUniv.compare l) - -let profiler = (HExtlib.profile "clean_and_fill").HExtlib.profile - -let clean_and_fill uri obj ugraph = - (* universes of obj fills the universes of the obj with the right uri *) - let list_of_universes, obj = universes_of_obj uri obj in - let list_of_universes = list_uniq list_of_universes in -(* CicUniv.print_ugraph ugraph;*) -(* List.iter (fun u -> prerr_endline (CicUniv.string_of_universe u))*) -(* list_of_universes;*) - let ugraph = CicUniv.clean_ugraph ugraph list_of_universes in -(* CicUniv.print_ugraph ugraph;*) - let ugraph, list_of_universes = - CicUniv.fill_empty_nodes_with_uri ugraph list_of_universes uri - in - ugraph, list_of_universes, obj - -let clean_and_fill u o g = - profiler (clean_and_fill u o) g - diff --git a/helm/ocaml/cic_proof_checking/cicUnivUtils.mli b/helm/ocaml/cic_proof_checking/cicUnivUtils.mli deleted file mode 100644 index eb55a47eb..000000000 --- a/helm/ocaml/cic_proof_checking/cicUnivUtils.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* 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/. - *) - - (** cleans the universe graph for a given object and fills universes with URI. - * to be used on qed - *) -val clean_and_fill: - UriManager.uri -> Cic.obj -> CicUniv.universe_graph -> - CicUniv.universe_graph * CicUniv.universe list * Cic.obj - diff --git a/helm/ocaml/cic_proof_checking/doc/inductive.txt b/helm/ocaml/cic_proof_checking/doc/inductive.txt deleted file mode 100644 index f2e49d398..000000000 --- a/helm/ocaml/cic_proof_checking/doc/inductive.txt +++ /dev/null @@ -1,41 +0,0 @@ -Table of allowed eliminations: - - +--------------------+----------------------------------+ - | Inductive Type | Elimination to | - +--------------------+----------------------------------+ - | Sort | "Smallness" | Prop | SetI | SetP | CProp| Type | - +--------------------+----------------------------------+ - | Prop empty | yes yes yes yes yes | - | Prop unit | yes yes yes yes yes | - | Prop small | yes no2 no2 no2 no12 | - | Prop | yes no2 no2 no2 no12 | - | SetI empty | yes yes -- yes yes | - | SetI small | yes yes -- yes yes | - | SetI | yes yes -- no1 no1 | - | SetP empty | yes -- yes yes yes | - | SetP small | yes -- yes yes yes | - | SetP | na3 na3 na3 na3 na3 | - | CProp empty | yes yes yes yes yes | - | CProp small | yes yes yes yes yes | - | CProp | yes yes yes yes yes | - | Type | yes yes yes yes yes | - +--------------------+----------------------------------+ - -Legenda: - no: elimination not allowed - na: not allowed, the inductive definition is rejected - - 1 : due to paradoxes a la Hurkens - 2 : due to code extraction + proof irreleveance incompatibility - (if you define Bool in Prop, you will be able to prove true<>false) - 3 : inductive type is rejected due to universe inconsistency - - SetP : Predicative Set - SetI : Impredicative Set - - non-informative : Constructor arguments are in Prop only - small : Constructor arguments are not in Type and SetP and CProp - unit : Non (mutually) recursive /\ only one constructor /\ non-informative - empty : in Coq: no constructors and non mutually recursive - in Matita: no constructors (but eventually mutually recursive - with non-empty types) diff --git a/helm/ocaml/cic_proof_checking/freshNamesGenerator.ml b/helm/ocaml/cic_proof_checking/freshNamesGenerator.ml deleted file mode 100755 index 99c9e4d76..000000000 --- a/helm/ocaml/cic_proof_checking/freshNamesGenerator.ml +++ /dev/null @@ -1,354 +0,0 @@ -(* Copyright (C) 2004, 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/. - *) - -(* $Id$ *) - -let debug_print = fun _ -> () - -let rec higher_name arity = - function - Cic.Sort Cic.Prop - | Cic.Sort Cic.CProp -> - if arity = 0 then "A" (* propositions *) - else if arity = 1 then "P" (* predicates *) - else "R" (*relations *) - | Cic.Sort Cic.Set - -> if arity = 0 then "S" else "F" - | Cic.Sort (Cic.Type _ ) -> - if arity = 0 then "T" else "F" - | Cic.Prod (_,_,t) -> higher_name (arity+1) t - | _ -> "f" - -let get_initial s = - if String.length s = 0 then "_" - else - let head = String.sub s 0 1 in - String.lowercase head - -(* only used when the sort is not Prop or CProp *) -let rec guess_a_name context ty = - match ty with - Cic.Rel n -> - (match List.nth context (n-1) with - None -> assert false - | Some (Cic.Anonymous,_) -> "eccomi_qua" - | Some (Cic.Name s,_) -> get_initial s) - | Cic.Var (uri,_) -> get_initial (UriManager.name_of_uri uri) - | Cic.Sort _ -> higher_name 0 ty - | Cic.Implicit _ -> assert false - | Cic.Cast (t1,t2) -> guess_a_name context t1 - | Cic.Prod (na_,_,t) -> higher_name 1 t - | Cic.Lambda _ -> assert false - | Cic.LetIn (_,s,t) -> guess_a_name context (CicSubstitution.subst s t) - | Cic.Appl [] -> assert false - | Cic.Appl (he::_) -> guess_a_name context he - | Cic.Const (uri,_) - | Cic.MutInd (uri,_,_) - | Cic.MutConstruct (uri,_,_,_) -> get_initial (UriManager.name_of_uri uri) - | _ -> "x" - -(* 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 ~subst metasenv context name ~typ = - let module C = Cic in - let basename = - match name with - C.Anonymous -> - (try - let ty,_ = - CicTypeChecker.type_of_aux' ~subst metasenv context typ - CicUniv.empty_ugraph in - (match ty with - C.Sort C.Prop - | C.Sort C.CProp -> "H" - | _ -> guess_a_name context typ - ) - with CicTypeChecker.TypeCheckerFailure _ -> "H" - ) - | C.Name name -> - Str.global_replace (Str.regexp "[0-9]*$") "" name - in - let already_used name = - List.exists (function Some (n,_) -> n=name | _ -> false) context - in - if name <> C.Anonymous && not (already_used name) then - name - else if not (already_used (C.Name basename)) then - C.Name basename - else - let rec try_next n = - let name' = C.Name (basename ^ string_of_int n) in - if already_used name' then - try_next (n+1) - else - name' - in - try_next 1 -;; - -(* let mk_fresh_names ~subst metasenv context t *) -let rec mk_fresh_names ~subst metasenv context t = - match t with - Cic.Rel _ -> t - | Cic.Var (uri,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.Var (uri,ens) - | Cic.Meta (i,l) -> - let l' = - List.map - (fun t -> - match t with - None -> None - | Some t -> Some (mk_fresh_names ~subst metasenv context t)) l in - Cic.Meta(i,l') - | Cic.Sort _ - | Cic.Implicit _ -> t - | Cic.Cast (te,ty) -> - let te' = mk_fresh_names ~subst metasenv context te in - let ty' = mk_fresh_names ~subst metasenv context ty in - Cic.Cast (te', ty') - | Cic.Prod (n,s,t) -> - let s' = mk_fresh_names ~subst metasenv context s in - let n' = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name "matita_dummy" -> - mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' - | _ -> n in - let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Decl s')::context) t in - Cic.Prod (n',s',t') - | Cic.Lambda (n,s,t) -> - let s' = mk_fresh_names ~subst metasenv context s in - let n' = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name "matita_dummy" -> - mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' - | _ -> n in - let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Decl s')::context) t in - Cic.Lambda (n',s',t') - | Cic.LetIn (n,s,t) -> - let s' = mk_fresh_names ~subst metasenv context s in - let n' = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name "matita_dummy" -> - mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' - | _ -> n in - let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Def (s',None))::context) t in - Cic.LetIn (n',s',t') - | Cic.Appl l -> - Cic.Appl (List.map (mk_fresh_names ~subst metasenv context) l) - | Cic.Const (uri,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.Const(uri,ens) - | Cic.MutInd (uri,tyno,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.MutInd (uri,tyno,ens) - | Cic.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.MutConstruct (uri,tyno,consno, ens) - | Cic.MutCase (sp,i,outty,t,pl) -> - let outty' = mk_fresh_names ~subst metasenv context outty in - let t' = mk_fresh_names ~subst metasenv context t in - let pl' = List.map (mk_fresh_names ~subst metasenv context) pl in - Cic.MutCase (sp, i, outty', t', pl') - | Cic.Fix (i, fl) -> - let tys = List.map - (fun (n,_,ty,_) -> - Some (Cic.Name n,(Cic.Decl ty))) fl in - let fl' = List.map - (fun (n,i,ty,bo) -> - let ty' = mk_fresh_names ~subst metasenv context ty in - let bo' = mk_fresh_names ~subst metasenv (tys@context) bo in - (n,i,ty',bo')) fl in - Cic.Fix (i, fl') - | Cic.CoFix (i, fl) -> - let tys = List.map - (fun (n,_,ty) -> - Some (Cic.Name n,(Cic.Decl ty))) fl in - let fl' = List.map - (fun (n,ty,bo) -> - let ty' = mk_fresh_names ~subst metasenv context ty in - let bo' = mk_fresh_names ~subst metasenv (tys@context) bo in - (n,ty',bo')) fl in - Cic.CoFix (i, fl') -;; - -(* clean_dummy_dependent_types term *) -(* returns a copy of [term] where every dummy dependent product *) -(* have been replaced with a non-dependent product and where *) -(* dummy let-ins have been removed. *) -let clean_dummy_dependent_types t = - let module C = Cic in - let rec aux k = - function - C.Rel m as t -> t,[k - m] - | C.Var (uri,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.Var (uri,exp_named_subst'),rels - | C.Meta (i,l) -> - let l',rels = - List.fold_right - (fun t (l,rels) -> - let t',rels' = - match t with - None -> None,[] - | Some t -> - let t',rels' = aux k t in - Some t', rels' - in - t'::l, rels' @ rels - ) l ([],[]) - in - C.Meta(i,l'),rels - | C.Sort _ as t -> t,[] - | C.Implicit _ as t -> t,[] - | C.Cast (te,ty) -> - let te',rels1 = aux k te in - let ty',rels2 = aux k ty in - C.Cast (te', ty'), rels1@rels2 - | C.Prod (n,s,t) -> - let s',rels1 = aux k s in - let t',rels2 = aux (k+1) t in - let n' = - match n with - C.Anonymous -> - if List.mem k rels2 then -( - debug_print (lazy "If this happens often, we can do something about it (i.e. we can generate a new fresh name; problem: we need the metasenv and context ;-(. Alternative solution: mk_implicit does not generate entries for the elements in the context that have no name") ; - C.Anonymous -) - else - C.Anonymous - | C.Name _ as n -> - if List.mem k rels2 then n else C.Anonymous - in - C.Prod (n', s', t'), rels1@rels2 - | C.Lambda (n,s,t) -> - let s',rels1 = aux k s in - let t',rels2 = aux (k+1) t in - C.Lambda (n, s', t'), rels1@rels2 - | C.LetIn (n,s,t) -> - let s',rels1 = aux k s in - let t',rels2 = aux (k+1) t in - let rels = rels1 @ rels2 in - if List.mem k rels2 then - C.LetIn (n, s', t'), rels - else - (* (C.Rel 1) is just a dummy term; any term would fit *) - CicSubstitution.subst (C.Rel 1) t', rels - | C.Appl l -> - let l',rels = - List.fold_right - (fun t (exp_named_subst,rels) -> - let t',rels' = aux k t in - t'::exp_named_subst, rels' @ rels - ) l ([],[]) - in - C.Appl l', rels - | C.Const (uri,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.Const (uri,exp_named_subst'),rels - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.MutInd (uri,tyno,exp_named_subst'),rels - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.MutConstruct (uri,tyno,consno,exp_named_subst'),rels - | C.MutCase (sp,i,outty,t,pl) -> - let outty',rels1 = aux k outty in - let t',rels2 = aux k t in - let pl',rels3 = - List.fold_right - (fun t (exp_named_subst,rels) -> - let t',rels' = aux k t in - t'::exp_named_subst, rels' @ rels - ) pl ([],[]) - in - C.MutCase (sp, i, outty', t', pl'), rels1 @ rels2 @rels3 - | C.Fix (i, fl) -> - let len = List.length fl in - let fl',rels = - List.fold_right - (fun (name,i,ty,bo) (fl,rels) -> - let ty',rels1 = aux k ty in - let bo',rels2 = aux (k + len) bo in - (name,i,ty',bo')::fl, rels1 @ rels2 @ rels - ) fl ([],[]) - in - C.Fix (i, fl'),rels - | C.CoFix (i, fl) -> - let len = List.length fl in - let fl',rels = - List.fold_right - (fun (name,ty,bo) (fl,rels) -> - let ty',rels1 = aux k ty in - let bo',rels2 = aux (k + len) bo in - (name,ty',bo')::fl, rels1 @ rels2 @ rels - ) fl ([],[]) - in - C.CoFix (i, fl'),rels - in - fst (aux 0 t) -;; diff --git a/helm/ocaml/cic_proof_checking/freshNamesGenerator.mli b/helm/ocaml/cic_proof_checking/freshNamesGenerator.mli deleted file mode 100644 index b90c0f2f5..000000000 --- a/helm/ocaml/cic_proof_checking/freshNamesGenerator.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2004, 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 metasenv 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 : - subst:Cic.substitution -> - Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name - -(* mk_fresh_names metasenv context term *) -(* returns a term t' convertible with term where all *) -(* matita_dummies have been replaced by fresh names *) - -val mk_fresh_names : - subst:Cic.substitution -> - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term - -(* clean_dummy_dependent_types term *) -(* returns a copy of [term] where every dummy dependent product *) -(* have been replaced with a non-dependent product and where *) -(* dummy let-ins have been removed. *) -val clean_dummy_dependent_types : Cic.term -> Cic.term diff --git a/helm/ocaml/cic_proof_checking/utilities/Makefile b/helm/ocaml/cic_proof_checking/utilities/Makefile deleted file mode 100644 index 383391d70..000000000 --- a/helm/ocaml/cic_proof_checking/utilities/Makefile +++ /dev/null @@ -1,21 +0,0 @@ -UTILITIES = create_environment parse_library list_uris -UTILITIES_OPT = $(patsubst %,%.opt,$(UTILITIES)) -LINKOPTS = -linkpkg -thread -LIBS = helm-cic_proof_checking -OCAMLC = $(OCAMLFIND) ocamlc $(LINKOPTS) -package $(LIBS) -OCAMLOPT = $(OCAMLFIND) opt $(LINKOPTS) -package $(LIBS) -all: $(UTILITIES) - @echo -n -opt: $(UTILITIES_OPT) - @echo -n -%: %.ml - @echo " OCAMLC $<" - @$(OCAMLC) -o $@ $< -%.opt: %.ml - @echo " OCAMLOPT $<" - @$(OCAMLOPT) -o $@ $< -clean: - rm -f $(UTILITIES) $(UTILITIES_OPT) *.cm[iox] *.o - -include ../../../Makefile.defs - diff --git a/helm/ocaml/cic_proof_checking/utilities/create_environment.ml b/helm/ocaml/cic_proof_checking/utilities/create_environment.ml deleted file mode 100644 index 8a8524d24..000000000 --- a/helm/ocaml/cic_proof_checking/utilities/create_environment.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -let trust = true - -let outfname = - match Sys.argv.(1) with - | "-help" | "--help" | "-h" | "--h" -> - print_endline - ("Usage: create_environment \n" ^ - " is the file where environment will be dumped\n" ^ - " is the file containing the URIs, one per line,\n" ^ - " that will be typechecked. Could be \"-\" for\n" ^ - " standard input"); - flush stdout; - exit 0 - | f -> f -let _ = - CicEnvironment.set_trust (fun _ -> trust); - Helm_registry.set "getter.mode" "remote"; - Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/"; - Sys.catch_break true; - if Sys.file_exists outfname then begin - let ic = open_in outfname in - CicEnvironment.restore_from_channel ic; - close_in ic - end -let urifname = - try - Sys.argv.(2) - with Invalid_argument _ -> "-" -let ic = - match urifname with - | "-" -> stdin - | fname -> open_in fname -let _ = - try - while true do -(* try *) - let uri = input_line ic in - print_endline uri; - flush stdout; - let uri = UriManager.uri_of_string uri in - ignore (CicTypeChecker.typecheck uri) -(* with Sys.Break -> () *) - done - with End_of_file | Sys.Break -> - let oc = open_out outfname in - CicEnvironment.dump_to_channel oc; - close_out oc - diff --git a/helm/ocaml/cic_proof_checking/utilities/list_uris.ml b/helm/ocaml/cic_proof_checking/utilities/list_uris.ml deleted file mode 100644 index 90ea51616..000000000 --- a/helm/ocaml/cic_proof_checking/utilities/list_uris.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -let ic = open_in Sys.argv.(1) in -CicEnvironment.restore_from_channel ic; -List.iter - (fun uri -> print_endline (UriManager.string_of_uri uri)) - (CicEnvironment.list_uri ()) diff --git a/helm/ocaml/cic_proof_checking/utilities/parse_library.ml b/helm/ocaml/cic_proof_checking/utilities/parse_library.ml deleted file mode 100644 index 1d65291cb..000000000 --- a/helm/ocaml/cic_proof_checking/utilities/parse_library.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -let trust = true - -let _ = - CicEnvironment.set_trust (fun _ -> trust); - Helm_registry.set "getter.mode" "remote"; - Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/" -let urifname = - try - Sys.argv.(1) - with Invalid_argument _ -> "-" -let ic = - match urifname with - | "-" -> stdin - | fname -> open_in fname -let _ = - try - while true do - try - let uri = input_line ic in - prerr_endline uri; - let uri = UriManager.uri_of_string uri in - ignore (CicEnvironment.get_obj CicUniv.empty_ugraph uri) -(* with Sys.Break -> () *) - with - | End_of_file -> raise End_of_file - | exn -> () - done - with End_of_file -> Unix.sleep max_int - diff --git a/helm/ocaml/cic_unification/.depend b/helm/ocaml/cic_unification/.depend deleted file mode 100644 index a442c1d4d..000000000 --- a/helm/ocaml/cic_unification/.depend +++ /dev/null @@ -1,10 +0,0 @@ -cicMetaSubst.cmo: cicMetaSubst.cmi -cicMetaSubst.cmx: cicMetaSubst.cmi -cicMkImplicit.cmo: cicMkImplicit.cmi -cicMkImplicit.cmx: cicMkImplicit.cmi -cicUnification.cmo: cicMetaSubst.cmi cicUnification.cmi -cicUnification.cmx: cicMetaSubst.cmx cicUnification.cmi -cicRefine.cmo: cicUnification.cmi cicMkImplicit.cmi cicMetaSubst.cmi \ - cicRefine.cmi -cicRefine.cmx: cicUnification.cmx cicMkImplicit.cmx cicMetaSubst.cmx \ - cicRefine.cmi diff --git a/helm/ocaml/cic_unification/Makefile b/helm/ocaml/cic_unification/Makefile deleted file mode 100644 index 62be3a61c..000000000 --- a/helm/ocaml/cic_unification/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -PACKAGE = cic_unification -PREDICATES = - -INTERFACE_FILES = \ - cicMetaSubst.mli \ - cicMkImplicit.mli \ - cicUnification.mli \ - cicRefine.mli -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/cic_unification/cicMetaSubst.ml b/helm/ocaml/cic_unification/cicMetaSubst.ml deleted file mode 100644 index 5870089be..000000000 --- a/helm/ocaml/cic_unification/cicMetaSubst.ml +++ /dev/null @@ -1,898 +0,0 @@ -(* Copyright (C) 2003, 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/. - *) - -(* $Id$ *) - -open Printf - -(* PROFILING *) -(* -let deref_counter = ref 0 -let apply_subst_context_counter = ref 0 -let apply_subst_metasenv_counter = ref 0 -let lift_counter = ref 0 -let subst_counter = ref 0 -let whd_counter = ref 0 -let are_convertible_counter = ref 0 -let metasenv_length = ref 0 -let context_length = ref 0 -let reset_counters () = - apply_subst_counter := 0; - apply_subst_context_counter := 0; - apply_subst_metasenv_counter := 0; - lift_counter := 0; - subst_counter := 0; - whd_counter := 0; - are_convertible_counter := 0; - metasenv_length := 0; - context_length := 0 -let print_counters () = - debug_print (lazy (Printf.sprintf -"apply_subst: %d -apply_subst_context: %d -apply_subst_metasenv: %d -lift: %d -subst: %d -whd: %d -are_convertible: %d -metasenv length: %d (avg = %.2f) -context length: %d (avg = %.2f) -" - !apply_subst_counter !apply_subst_context_counter - !apply_subst_metasenv_counter !lift_counter !subst_counter !whd_counter - !are_convertible_counter !metasenv_length - ((float !metasenv_length) /. (float !apply_subst_metasenv_counter)) - !context_length - ((float !context_length) /. (float !apply_subst_context_counter)) - ))*) - - - -exception MetaSubstFailure of string Lazy.t -exception Uncertain of string Lazy.t -exception AssertFailure of string Lazy.t -exception DeliftingARelWouldCaptureAFreeVariable;; - -let debug_print = fun _ -> () - -type substitution = (int * (Cic.context * Cic.term)) list - -(* -let rec deref subst = - let third _,_,a = a in - function - Cic.Meta(n,l) as t -> - (try - deref subst - (CicSubstitution.subst_meta - l (third (CicUtil.lookup_subst n subst))) - with - CicUtil.Subst_not_found _ -> t) - | t -> t -;; -*) - -let lookup_subst = CicUtil.lookup_subst -;; - - -(* clean_up_meta take a metasenv and a term and make every local context -of each occurrence of a metavariable consistent with its canonical context, -with respect to the hidden hipothesis *) - -(* -let clean_up_meta subst metasenv t = - let module C = Cic in - let rec aux t = - match t with - C.Rel _ - | C.Sort _ -> t - | C.Implicit _ -> assert false - | C.Meta (n,l) as t -> - let cc = - (try - let (cc,_) = lookup_subst n subst in cc - with CicUtil.Subst_not_found _ -> - try - let (_,cc,_) = CicUtil.lookup_meta n metasenv in cc - with CicUtil.Meta_not_found _ -> assert false) in - let l' = - (try - List.map2 - (fun t1 t2 -> - match t1,t2 with - None , _ -> None - | _ , t -> t) cc l - with - Invalid_argument _ -> assert false) in - C.Meta (n, l') - | C.Cast (te,ty) -> C.Cast (aux te, aux ty) - | C.Prod (name,so,dest) -> C.Prod (name, aux so, aux dest) - | C.Lambda (name,so,dest) -> C.Lambda (name, aux so, aux dest) - | C.LetIn (name,so,dest) -> C.LetIn (name, aux so, aux dest) - | C.Appl l -> C.Appl (List.map aux l) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst - in - C.Var (uri, exp_named_subst') - | C.Const (uri, exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst - in - C.Const (uri, exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri,t) -> (uri, aux 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 (fun (uri,t) -> (uri, aux t)) exp_named_subst - in - C.MutConstruct (uri, tyno, consno, exp_named_subst') - | C.MutCase (uri,tyno,out,te,pl) -> - C.MutCase (uri, tyno, aux out, aux te, List.map aux pl) - | C.Fix (i,fl) -> - let fl' = - List.map - (fun (name,j,ty,bo) -> (name, j, aux ty, aux bo)) fl - in - C.Fix (i, fl') - | C.CoFix (i,fl) -> - let fl' = - List.map - (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl - in - C.CoFix (i, fl') - in - aux t *) - -(*** Functions to apply a substitution ***) - -let apply_subst_gen ~appl_fun subst term = - let rec um_aux = - let module C = Cic in - let module S = CicSubstitution in - function - C.Rel _ as t -> t - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst - in - C.Var (uri, exp_named_subst') - | C.Meta (i, l) -> - (try - let (_, t,_) = lookup_subst i subst in - um_aux (S.subst_meta l t) - with CicUtil.Subst_not_found _ -> - (* unconstrained variable, i.e. free in subst*) - let l' = - List.map (function None -> None | Some t -> Some (um_aux t)) l - in - C.Meta (i,l')) - | C.Sort _ - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty) - | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t) - | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t) - | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t) - | C.Appl (hd :: tl) -> appl_fun um_aux hd tl - | C.Appl _ -> assert false - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (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 (fun (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 (fun (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) -> - let pl' = List.map um_aux pl in - C.MutCase (sp, i, um_aux outty, um_aux t, pl') - | C.Fix (i, fl) -> - let fl' = - List.map (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo)) fl - in - C.Fix (i, fl') - | C.CoFix (i, fl) -> - let fl' = - List.map (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo)) fl - in - C.CoFix (i, fl') - in - LibrarySync.merge_coercions (um_aux term) -;; - -let apply_subst = - let appl_fun um_aux he tl = - let tl' = List.map um_aux tl in - let t' = - match um_aux he with - Cic.Appl l -> Cic.Appl (l@tl') - | he' -> Cic.Appl (he'::tl') - in - begin - match he with - Cic.Meta (m,_) -> CicReduction.head_beta_reduce t' - | _ -> t' - end - in - fun s t -> -(* incr apply_subst_counter; *) - apply_subst_gen ~appl_fun s t -;; - -let rec apply_subst_context subst context = -(* - incr apply_subst_context_counter; - context_length := !context_length + List.length context; -*) - List.fold_right - (fun item context -> - match item with - | Some (n, Cic.Decl t) -> - let t' = apply_subst subst t in - Some (n, Cic.Decl t') :: context - | Some (n, Cic.Def (t, ty)) -> - let ty' = - match ty with - | None -> None - | Some ty -> Some (apply_subst subst ty) - in - let t' = apply_subst subst t in - Some (n, Cic.Def (t', ty')) :: context - | None -> None :: context) - context [] - -let apply_subst_metasenv subst metasenv = -(* - incr apply_subst_metasenv_counter; - metasenv_length := !metasenv_length + List.length metasenv; -*) - List.map - (fun (n, context, ty) -> - (n, apply_subst_context subst context, apply_subst subst ty)) - (List.filter - (fun (i, _, _) -> not (List.mem_assoc i subst)) - metasenv) - -(***** Pretty printing functions ******) - -let ppterm subst term = CicPp.ppterm (apply_subst subst term) - -let ppterm_in_name_context subst term name_context = - CicPp.pp (apply_subst subst term) name_context - -let ppterm_in_context subst term context = - let name_context = - List.map (function None -> None | Some (n,_) -> Some n) context - in - ppterm_in_name_context subst term name_context - -let ppcontext' ?(sep = "\n") subst context = - let separate s = if s = "" then "" else s ^ sep in - List.fold_right - (fun context_entry (i,name_context) -> - match context_entry with - Some (n,Cic.Decl t) -> - sprintf "%s%s : %s" (separate i) (CicPp.ppname n) - (ppterm_in_name_context subst t name_context), (Some n)::name_context - | Some (n,Cic.Def (bo,ty)) -> - sprintf "%s%s : %s := %s" (separate i) (CicPp.ppname n) - (match ty with - None -> "_" - | Some ty -> ppterm_in_name_context subst ty name_context) - (ppterm_in_name_context subst bo name_context), (Some n)::name_context - | None -> - sprintf "%s_ :? _" (separate i), None::name_context - ) context ("",[]) - -let ppsubst_unfolded subst = - String.concat "\n" - (List.map - (fun (idx, (c, t,_)) -> - let context,name_context = ppcontext' ~sep:"; " subst c in - sprintf "%s |- ?%d:= %s" context idx - (ppterm_in_name_context subst t name_context)) - subst) -(* - Printf.sprintf "?%d := %s" idx (CicPp.ppterm term)) - subst) *) -;; - -let ppsubst subst = - String.concat "\n" - (List.map - (fun (idx, (c, t, _)) -> - let context,name_context = ppcontext' ~sep:"; " [] c in - sprintf "%s |- ?%d:= %s" context idx - (ppterm_in_name_context [] t name_context)) - subst) -;; - -let ppcontext ?sep subst context = fst (ppcontext' ?sep subst context) - -let ppmetasenv ?(sep = "\n") subst metasenv = - String.concat sep - (List.map - (fun (i, c, t) -> - let context,name_context = ppcontext' ~sep:"; " subst c in - sprintf "%s |- ?%d: %s" context i - (ppterm_in_name_context subst t name_context)) - (List.filter - (fun (i, _, _) -> not (List.mem_assoc i subst)) - metasenv)) - -let tempi_type_of_aux_subst = ref 0.0;; -let tempi_subst = ref 0.0;; -let tempi_type_of_aux = ref 0.0;; - -(**** DELIFT ****) -(* the delift function takes in input a metavariable index, an ordered list of - * optional terms [t1,...,tn] and a term t, and substitutes every tk = Some - * (rel(nk)) with rel(k). Typically, the list of optional terms is the explicit - * substitution that is applied to a metavariable occurrence and the result of - * the delift function is a term the implicit variable can be substituted with - * to make the term [t] unifiable with the metavariable occurrence. In general, - * the problem is undecidable if we consider equivalence in place of alpha - * convertibility. Our implementation, though, is even weaker than alpha - * convertibility, since it replace the term [tk] if and only if [tk] is a Rel - * (missing all the other cases). Does this matter in practice? - * The metavariable index is the index of the metavariable that must not occur - * in the term (for occur check). - *) - -exception NotInTheList;; - -let position n = - let rec aux k = - function - [] -> raise NotInTheList - | (Some (Cic.Rel m))::_ when m=n -> k - | _::tl -> aux (k+1) tl in - aux 1 -;; - -exception Occur;; - -let rec force_does_not_occur subst to_be_restricted t = - let module C = Cic in - let more_to_be_restricted = ref [] in - let rec aux k = function - C.Rel r when List.mem (r - k) to_be_restricted -> raise Occur - | C.Rel _ - | C.Sort _ as t -> t - | C.Implicit _ -> assert false - | C.Meta (n, l) -> - (* we do not retrieve the term associated to ?n in subst since *) - (* in this way we can restrict if something goes wrong *) - let l' = - let i = ref 0 in - List.map - (function t -> - incr i ; - match t with - None -> None - | Some t -> - try - Some (aux k t) - with Occur -> - more_to_be_restricted := (n,!i) :: !more_to_be_restricted; - None) - l - in - C.Meta (n, l') - | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) - | C.Prod (name,so,dest) -> C.Prod (name, aux k so, aux (k+1) dest) - | C.Lambda (name,so,dest) -> C.Lambda (name, aux k so, aux (k+1) dest) - | C.LetIn (name,so,dest) -> C.LetIn (name, aux k so, aux (k+1) dest) - | C.Appl l -> C.Appl (List.map (aux k) l) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst - in - C.Var (uri, exp_named_subst') - | C.Const (uri, exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri,t) -> (uri, aux 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 (fun (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 (fun (uri,t) -> (uri, aux k t)) exp_named_subst - in - C.MutConstruct (uri, tyno, consno, exp_named_subst') - | C.MutCase (uri,tyno,out,te,pl) -> - C.MutCase (uri, tyno, aux k out, aux k te, List.map (aux k) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let k_plus_len = k + len in - let fl' = - List.map - (fun (name,j,ty,bo) -> (name, j, aux k ty, aux k_plus_len bo)) fl - in - C.Fix (i, fl') - | C.CoFix (i,fl) -> - let len = List.length fl in - let k_plus_len = k + len in - let fl' = - List.map - (fun (name,ty,bo) -> (name, aux k ty, aux k_plus_len bo)) fl - in - C.CoFix (i, fl') - in - let res = aux 0 t in - (!more_to_be_restricted, res) - -let rec restrict subst to_be_restricted metasenv = - let names_of_context_indexes context indexes = - String.concat ", " - (List.map - (fun i -> - try - match List.nth context (i-1) with - | None -> assert false - | Some (n, _) -> CicPp.ppname n - with - Failure _ -> assert false - ) indexes) - in - let force_does_not_occur_in_context to_be_restricted = function - | None -> [], None - | Some (name, Cic.Decl t) -> - let (more_to_be_restricted, t') = - force_does_not_occur subst to_be_restricted t - in - more_to_be_restricted, Some (name, Cic.Decl t') - | Some (name, Cic.Def (bo, ty)) -> - let (more_to_be_restricted, bo') = - force_does_not_occur subst to_be_restricted bo - in - let more_to_be_restricted, ty' = - match ty with - | None -> more_to_be_restricted, None - | Some ty -> - let more_to_be_restricted', ty' = - force_does_not_occur subst to_be_restricted ty - in - more_to_be_restricted @ more_to_be_restricted', - Some ty' - in - more_to_be_restricted, Some (name, Cic.Def (bo', ty')) - in - let rec erase i to_be_restricted n = function - | [] -> [], to_be_restricted, [] - | hd::tl -> - let more_to_be_restricted,restricted,tl' = - erase (i+1) to_be_restricted n tl - in - let restrict_me = List.mem i restricted in - if restrict_me then - more_to_be_restricted, restricted, None:: tl' - else - (try - let more_to_be_restricted', hd' = - let delifted_restricted = - let rec aux = - function - [] -> [] - | j::tl when j > i -> (j - i)::aux tl - | _::tl -> aux tl - in - aux restricted - in - force_does_not_occur_in_context delifted_restricted hd - in - more_to_be_restricted @ more_to_be_restricted', - restricted, hd' :: tl' - with Occur -> - more_to_be_restricted, (i :: restricted), None :: tl') - in - let (more_to_be_restricted, metasenv) = (* restrict metasenv *) - List.fold_right - (fun (n, context, t) (more, metasenv) -> - let to_be_restricted = - List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted) - in - let (more_to_be_restricted, restricted, context') = - (* just an optimization *) - if to_be_restricted = [] then - [],[],context - else - erase 1 to_be_restricted n context - in - try - let more_to_be_restricted', t' = - force_does_not_occur subst restricted t - in - let metasenv' = (n, context', t') :: metasenv in - (more @ more_to_be_restricted @ more_to_be_restricted', - metasenv') - with Occur -> - raise (MetaSubstFailure (lazy (sprintf - "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since metavariable's type depends on at least one of them" - n (names_of_context_indexes context to_be_restricted))))) - metasenv ([], []) - in - let (more_to_be_restricted', subst) = (* restrict subst *) - List.fold_right - (* TODO: cambiare dopo l'aggiunta del ty *) - (fun (n, (context, term,ty)) (more, subst') -> - let to_be_restricted = - List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted) - in - (try - let (more_to_be_restricted, restricted, context') = - (* just an optimization *) - if to_be_restricted = [] then - [], [], context - else - erase 1 to_be_restricted n context - in - let more_to_be_restricted', term' = - force_does_not_occur subst restricted term - in - let more_to_be_restricted'', ty' = - force_does_not_occur subst restricted ty in - let subst' = (n, (context', term',ty')) :: subst' in - let more = - more @ more_to_be_restricted - @ more_to_be_restricted'@more_to_be_restricted'' in - (more, subst') - with Occur -> - let error_msg = lazy (sprintf - "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since ?%d is already instantiated with %s and at least one of the hypotheses occurs in the substituted term" - n (names_of_context_indexes context to_be_restricted) n - (ppterm subst term)) - in - (* DEBUG - debug_print (lazy error_msg); - debug_print (lazy ("metasenv = \n" ^ (ppmetasenv metasenv subst))); - debug_print (lazy ("subst = \n" ^ (ppsubst subst))); - debug_print (lazy ("context = \n" ^ (ppcontext subst context))); *) - raise (MetaSubstFailure error_msg))) - subst ([], []) - in - match more_to_be_restricted @ more_to_be_restricted' with - | [] -> (metasenv, subst) - | l -> restrict subst l metasenv -;; - -(*CSC: maybe we should rename delift in abstract, as I did in my dissertation *)(*Andrea: maybe not*) - -let delift n subst context metasenv l t = -(* INVARIANT: we suppose that t is not another occurrence of Meta(n,_), - otherwise the occur check does not make sense *) - -(* - debug_print (lazy ("sto deliftando il termine " ^ (CicPp.ppterm t) ^ " rispetto - al contesto locale " ^ (CicPp.ppterm (Cic.Meta(0,l))))); -*) - - let module S = CicSubstitution in - let l = - let (_, canonical_context, _) = CicUtil.lookup_meta n metasenv in - List.map2 (fun ct lt -> - match (ct, lt) with - | None, _ -> None - | Some _, _ -> lt) - canonical_context l - in - let to_be_restricted = ref [] in - let rec deliftaux k = - let module C = Cic in - function - C.Rel m -> - if m <=k then - C.Rel m (*CSC: che succede se c'e' un Def? Dovrebbe averlo gia' *) - (*CSC: deliftato la regola per il LetIn *) - (*CSC: FALSO! La regola per il LetIn non lo fa *) - else - (try - match List.nth context (m-k-1) with - Some (_,C.Def (t,_)) -> - (*CSC: Hmmm. This bit of reduction is not in the spirit of *) - (*CSC: first order unification. Does it help or does it harm? *) - deliftaux k (S.lift m t) - | Some (_,C.Decl t) -> - C.Rel ((position (m-k) l) + k) - | None -> raise (MetaSubstFailure (lazy "RelToHiddenHypothesis")) - with - Failure _ -> - raise (MetaSubstFailure (lazy "Unbound variable found in deliftaux")) - ) - | 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 -> - (try - let (_,t,_) = CicUtil.lookup_subst i subst in - deliftaux k (CicSubstitution.subst_meta l1 t) - with CicUtil.Subst_not_found _ -> - (* see the top level invariant *) - if (i = n) then - raise (MetaSubstFailure (lazy (sprintf - "Cannot unify the metavariable ?%d with a term that has as subterm %s in which the same metavariable occurs (occur check)" - i (ppterm subst t)))) - else - begin - (* I do not consider the term associated to ?i in subst since *) - (* in this way I can restrict if something goes wrong. *) - let rec deliftl j = - function - [] -> [] - | None::tl -> None::(deliftl (j+1) tl) - | (Some t)::tl -> - let l1' = (deliftl (j+1) tl) in - try - Some (deliftaux k t)::l1' - with - NotInTheList - | MetaSubstFailure _ -> - to_be_restricted := - (i,j)::!to_be_restricted ; None::l1' - in - let l' = deliftl 1 l1 in - C.Meta(i,l') - end) - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty) - | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t) - | 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 (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 - let liftedfl = - List.map - (fun (name, i, ty, bo) -> - (name, i, deliftaux k ty, deliftaux (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, deliftaux k ty, deliftaux (k+len) bo)) - fl - in - C.CoFix (i, liftedfl) - in - let res = - try - deliftaux 0 t - with - NotInTheList -> - (* This is the case where we fail even first order unification. *) - (* The reason is that our delift function is weaker than first *) - (* order (in the sense of alpha-conversion). See comment above *) - (* related to the delift function. *) -(* debug_print (lazy "First Order UnificationFailure during delift") ; -debug_print(lazy (sprintf - "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables" - (ppterm subst t) - (String.concat "; " - (List.map - (function Some t -> ppterm subst t | None -> "_") l - )))); *) - raise (Uncertain (lazy (sprintf - "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables" - (ppterm subst t) - (String.concat "; " - (List.map - (function Some t -> ppterm subst t | None -> "_") - l))))) - in - let (metasenv, subst) = restrict subst !to_be_restricted metasenv in - res, metasenv, subst -;; - -(* delifts a term t of n levels strating from k, that is changes (Rel m) - * to (Rel (m - n)) when m > (k + n). if k <= m < k + n delift fails - *) -let delift_rels_from subst metasenv k n = - let rec liftaux subst metasenv k = - let module C = Cic in - function - C.Rel m -> - if m < k then - C.Rel m, subst, metasenv - else if m < k + n then - raise DeliftingARelWouldCaptureAFreeVariable - else - C.Rel (m - n), subst, metasenv - | C.Var (uri,exp_named_subst) -> - let exp_named_subst',subst,metasenv = - List.fold_right - (fun (uri,t) (l,subst,metasenv) -> - let t',subst,metasenv = liftaux subst metasenv k t in - (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) - in - C.Var (uri,exp_named_subst'),subst,metasenv - | C.Meta (i,l) -> - (try - let (_, t,_) = lookup_subst i subst in - liftaux subst metasenv k (CicSubstitution.subst_meta l t) - with CicUtil.Subst_not_found _ -> - let l',to_be_restricted,subst,metasenv = - let rec aux con l subst metasenv = - match l with - [] -> [],[],subst,metasenv - | he::tl -> - let tl',to_be_restricted,subst,metasenv = - aux (con + 1) tl subst metasenv in - let he',more_to_be_restricted,subst,metasenv = - match he with - None -> None,[],subst,metasenv - | Some t -> - try - let t',subst,metasenv = liftaux subst metasenv k t in - Some t',[],subst,metasenv - with - DeliftingARelWouldCaptureAFreeVariable -> - None,[i,con],subst,metasenv - in - he'::tl',more_to_be_restricted@to_be_restricted,subst,metasenv - in - aux 1 l subst metasenv in - let metasenv,subst = restrict subst to_be_restricted metasenv in - C.Meta(i,l'),subst,metasenv) - | C.Sort _ as t -> t,subst,metasenv - | C.Implicit _ as t -> t,subst,metasenv - | C.Cast (te,ty) -> - let te',subst,metasenv = liftaux subst metasenv k te in - let ty',subst,metasenv = liftaux subst metasenv k ty in - C.Cast (te',ty'),subst,metasenv - | C.Prod (n,s,t) -> - let s',subst,metasenv = liftaux subst metasenv k s in - let t',subst,metasenv = liftaux subst metasenv (k+1) t in - C.Prod (n,s',t'),subst,metasenv - | C.Lambda (n,s,t) -> - let s',subst,metasenv = liftaux subst metasenv k s in - let t',subst,metasenv = liftaux subst metasenv (k+1) t in - C.Lambda (n,s',t'),subst,metasenv - | C.LetIn (n,s,t) -> - let s',subst,metasenv = liftaux subst metasenv k s in - let t',subst,metasenv = liftaux subst metasenv (k+1) t in - C.LetIn (n,s',t'),subst,metasenv - | C.Appl l -> - let l',subst,metasenv = - List.fold_right - (fun t (l,subst,metasenv) -> - let t',subst,metasenv = liftaux subst metasenv k t in - t'::l,subst,metasenv) l ([],subst,metasenv) in - C.Appl l',subst,metasenv - | C.Const (uri,exp_named_subst) -> - let exp_named_subst',subst,metasenv = - List.fold_right - (fun (uri,t) (l,subst,metasenv) -> - let t',subst,metasenv = liftaux subst metasenv k t in - (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) - in - C.Const (uri,exp_named_subst'),subst,metasenv - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst',subst,metasenv = - List.fold_right - (fun (uri,t) (l,subst,metasenv) -> - let t',subst,metasenv = liftaux subst metasenv k t in - (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) - in - C.MutInd (uri,tyno,exp_named_subst'),subst,metasenv - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst',subst,metasenv = - List.fold_right - (fun (uri,t) (l,subst,metasenv) -> - let t',subst,metasenv = liftaux subst metasenv k t in - (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) - in - C.MutConstruct (uri,tyno,consno,exp_named_subst'),subst,metasenv - | C.MutCase (sp,i,outty,t,pl) -> - let outty',subst,metasenv = liftaux subst metasenv k outty in - let t',subst,metasenv = liftaux subst metasenv k t in - let pl',subst,metasenv = - List.fold_right - (fun t (l,subst,metasenv) -> - let t',subst,metasenv = liftaux subst metasenv k t in - t'::l,subst,metasenv) pl ([],subst,metasenv) - in - C.MutCase (sp,i,outty',t',pl'),subst,metasenv - | C.Fix (i, fl) -> - let len = List.length fl in - let liftedfl,subst,metasenv = - List.fold_right - (fun (name, i, ty, bo) (l,subst,metasenv) -> - let ty',subst,metasenv = liftaux subst metasenv k ty in - let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in - (name,i,ty',bo')::l,subst,metasenv - ) fl ([],subst,metasenv) - in - C.Fix (i, liftedfl),subst,metasenv - | C.CoFix (i, fl) -> - let len = List.length fl in - let liftedfl,subst,metasenv = - List.fold_right - (fun (name, ty, bo) (l,subst,metasenv) -> - let ty',subst,metasenv = liftaux subst metasenv k ty in - let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in - (name,ty',bo')::l,subst,metasenv - ) fl ([],subst,metasenv) - in - C.CoFix (i, liftedfl),subst,metasenv - in - liftaux subst metasenv k - -let delift_rels subst metasenv n t = - delift_rels_from subst metasenv 1 n t - - -(**** END OF DELIFT ****) - - -(** {2 Format-like pretty printers} *) - -let fpp_gen ppf s = - Format.pp_print_string ppf s; - Format.pp_print_newline ppf (); - Format.pp_print_flush ppf () - -let fppsubst ppf subst = fpp_gen ppf (ppsubst subst) -let fppterm ppf term = fpp_gen ppf (CicPp.ppterm term) -let fppmetasenv ppf metasenv = fpp_gen ppf (ppmetasenv [] metasenv) - diff --git a/helm/ocaml/cic_unification/cicMetaSubst.mli b/helm/ocaml/cic_unification/cicMetaSubst.mli deleted file mode 100644 index 96f87205f..000000000 --- a/helm/ocaml/cic_unification/cicMetaSubst.mli +++ /dev/null @@ -1,92 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -exception MetaSubstFailure of string Lazy.t -exception Uncertain of string Lazy.t -exception AssertFailure of string Lazy.t -exception DeliftingARelWouldCaptureAFreeVariable;; - -(* The entry (i,t) in a substitution means that *) -(* (META i) have been instantiated with t. *) -(* type substitution = (int * (Cic.context * Cic.term)) list *) - - (** @raise SubstNotFound *) - -(* apply_subst subst t *) -(* applies the substitution [subst] to [t] *) -(* [subst] must be already unwinded *) - -val apply_subst : Cic.substitution -> Cic.term -> Cic.term -val apply_subst_context : Cic.substitution -> Cic.context -> Cic.context -val apply_subst_metasenv: Cic.substitution -> Cic.metasenv -> Cic.metasenv - -(*** delifting ***) - -val delift : - int -> Cic.substitution -> Cic.context -> Cic.metasenv -> - (Cic.term option) list -> Cic.term -> - Cic.term * Cic.metasenv * Cic.substitution -val restrict : - Cic.substitution -> (int * int) list -> Cic.metasenv -> - Cic.metasenv * Cic.substitution - -(** delifts the Rels in t of n - * @raise DeliftingARelWouldCaptureAFreeVariable - *) -val delift_rels : - Cic.substitution -> Cic.metasenv -> int -> Cic.term -> - Cic.term * Cic.substitution * Cic.metasenv - -(** {2 Pretty printers} *) - -val ppsubst_unfolded: Cic.substitution -> string -val ppsubst: Cic.substitution -> string -val ppterm: Cic.substitution -> Cic.term -> string -val ppcontext: ?sep: string -> Cic.substitution -> Cic.context -> string -val ppterm_in_name_context: - Cic.substitution -> Cic.term -> (Cic.name option) list -> string -val ppterm_in_context: - Cic.substitution -> Cic.term -> Cic.context -> string -val ppmetasenv: ?sep: string -> Cic.substitution -> Cic.metasenv -> string - -(** {2 Format-like pretty printers} - * As above with prototypes suitable for toplevel/ocamldebug printers. No - * subsitutions are applied here since such printers are required to be invoked - * with only one argument. - *) - -val fppsubst: Format.formatter -> Cic.substitution -> unit -val fppterm: Format.formatter -> Cic.term -> unit -val fppmetasenv: Format.formatter -> Cic.metasenv -> unit - -(* -(* DEBUG *) -val print_counters: unit -> unit -val reset_counters: unit -> unit -*) - -(* val clean_up_meta : - Cic.substitution -> Cic.metasenv -> Cic.term -> Cic.term -*) diff --git a/helm/ocaml/cic_unification/cicMkImplicit.ml b/helm/ocaml/cic_unification/cicMkImplicit.ml deleted file mode 100644 index 36679223c..000000000 --- a/helm/ocaml/cic_unification/cicMkImplicit.ml +++ /dev/null @@ -1,122 +0,0 @@ -(* Copyright (C) 2004, 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/. - *) - -(* $Id$ *) - -(* 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 ?(start = 1) canonical_context = - let rec aux = - function - (_,[]) -> [] - | (n,None::tl) -> None::(aux ((n+1),tl)) - | (n,_::tl) -> (Some (Cic.Rel n))::(aux ((n+1),tl)) - in - aux (start,canonical_context) - -(* Returns the first meta whose number is above the *) -(* number of the higher meta. *) -let new_meta metasenv subst = - 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 - let indexes = - (List.map (fun (i, _, _) -> i) metasenv) @ (List.map fst subst) - in - 1 + aux (None, indexes) - -(* let apply_subst_context = CicMetaSubst.apply_subst_context;; *) -(* questa o la precedente sembrano essere equivalenti come tempi *) -let apply_subst_context _ context = context ;; - -let mk_implicit metasenv subst context = - let newmeta = new_meta metasenv subst in - let newuniv = CicUniv.fresh () in - let irl = identity_relocation_list_for_metavariable context in - (* in the following mk_* functions we apply substitution to canonical - * context since we have the invariant that the metasenv has already been - * instantiated with subst *) - let context = apply_subst_context subst context in - ([ newmeta, [], Cic.Sort (Cic.Type newuniv) ; - (* TASSI: ?? *) - newmeta + 1, context, Cic.Meta (newmeta, []); - newmeta + 2, context, Cic.Meta (newmeta + 1,irl) ] @ metasenv, - newmeta + 2) - -let mk_implicit_type metasenv subst context = - let newmeta = new_meta metasenv subst in - let newuniv = CicUniv.fresh () in - let context = apply_subst_context subst context in - ([ newmeta, [], Cic.Sort (Cic.Type newuniv); - (* TASSI: ?? *) - newmeta + 1, context, Cic.Meta (newmeta, []) ] @metasenv, - newmeta + 1) - -let mk_implicit_sort metasenv subst = - let newmeta = new_meta metasenv subst in - let newuniv = CicUniv.fresh () in - ([ newmeta, [], Cic.Sort (Cic.Type newuniv)] @ metasenv, newmeta) - (* TASSI: ?? *) - -let n_fresh_metas metasenv subst context n = - if n = 0 then metasenv, [] - else - let irl = identity_relocation_list_for_metavariable context in - let context = apply_subst_context subst context in - let newmeta = new_meta metasenv subst in - let newuniv = CicUniv.fresh () in - let rec aux newmeta n = - if n = 0 then metasenv, [] - else - let metasenv', l = aux (newmeta + 3) (n-1) in - (* TASSI: ?? *) - (newmeta, context, Cic.Sort (Cic.Type newuniv)):: - (newmeta + 1, context, Cic.Meta (newmeta, irl)):: - (newmeta + 2, context, Cic.Meta (newmeta + 1,irl))::metasenv', - Cic.Meta(newmeta+2,irl)::l in - aux newmeta n - -let fresh_subst metasenv subst context uris = - let irl = identity_relocation_list_for_metavariable context in - let context = apply_subst_context subst context in - let newmeta = new_meta metasenv subst in - let newuniv = CicUniv.fresh () in - let rec aux newmeta = function - [] -> metasenv, [] - | uri::tl -> - let metasenv', l = aux (newmeta + 3) tl in - (* TASSI: ?? *) - (newmeta, context, Cic.Sort (Cic.Type newuniv)):: - (newmeta + 1, context, Cic.Meta (newmeta, irl)):: - (newmeta + 2, context, Cic.Meta (newmeta + 1,irl))::metasenv', - (uri,Cic.Meta(newmeta+2,irl))::l in - aux newmeta uris - diff --git a/helm/ocaml/cic_unification/cicMkImplicit.mli b/helm/ocaml/cic_unification/cicMkImplicit.mli deleted file mode 100644 index 476270144..000000000 --- a/helm/ocaml/cic_unification/cicMkImplicit.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - - -(* 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 : - ?start: int -> 'a option list -> Cic.term option list - -(* Returns the first meta whose number is above the *) -(* number of the higher meta. *) -val new_meta : Cic.metasenv -> Cic.substitution -> int - -(** [mk_implicit metasenv context] - * add a fresh metavariable to the given metasenv, using given context - * @return the new metasenv and the index of the added conjecture *) -val mk_implicit: Cic.metasenv -> Cic.substitution -> Cic.context -> Cic.metasenv * int - -(** as above, but the fresh metavariable represents a type *) -val mk_implicit_type: Cic.metasenv -> Cic.substitution -> Cic.context -> Cic.metasenv * int - -(** as above, but the fresh metavariable represents a sort *) -val mk_implicit_sort: Cic.metasenv -> Cic.substitution -> Cic.metasenv * int - -(** [mk_implicit metasenv context] create n fresh metavariables *) -val n_fresh_metas: - Cic.metasenv -> Cic.substitution -> Cic.context -> int -> Cic.metasenv * Cic.term list - -(** [fresh_subst metasenv context uris] takes in input a list of uri and -creates a fresh explicit substitution *) -val fresh_subst: - Cic.metasenv -> - Cic.substitution -> - Cic.context -> - UriManager.uri list -> - Cic.metasenv * (Cic.term Cic.explicit_named_substitution) - diff --git a/helm/ocaml/cic_unification/cicRefine.ml b/helm/ocaml/cic_unification/cicRefine.ml deleted file mode 100644 index 620f66f18..000000000 --- a/helm/ocaml/cic_unification/cicRefine.ml +++ /dev/null @@ -1,1395 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open Printf - -exception RefineFailure of string Lazy.t;; -exception Uncertain of string Lazy.t;; -exception AssertFailure of string Lazy.t;; - -let insert_coercions = ref true - -let debug_print = fun _ -> () - -let profiler = HExtlib.profile "CicRefine.fo_unif" - -let fo_unif_subst subst context metasenv t1 t2 ugraph = - try -let foo () = - CicUnification.fo_unif_subst subst context metasenv t1 t2 ugraph -in profiler.HExtlib.profile foo () - with - (CicUnification.UnificationFailure msg) -> raise (RefineFailure msg) - | (CicUnification.Uncertain msg) -> raise (Uncertain msg) -;; - -let enrich localization_tbl t ?(f = fun msg -> msg) exn = - let exn' = - match exn with - RefineFailure msg -> RefineFailure (f msg) - | Uncertain msg -> Uncertain (f msg) - | _ -> assert false in - let loc = - try - Cic.CicHash.find localization_tbl t - with Not_found -> - prerr_endline ("!!! NOT LOCALIZED: " ^ CicPp.ppterm t); - assert false - in - raise (HExtlib.Localized (loc,exn')) - -let relocalize localization_tbl oldt newt = - try - let infos = Cic.CicHash.find localization_tbl oldt in - Cic.CicHash.remove localization_tbl oldt; - Cic.CicHash.add localization_tbl newt infos; - with - Not_found -> () -;; - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> raise (AssertFailure (lazy "split: list too short")) -;; - -let exp_impl metasenv subst context = - function - | Some `Type -> - let (metasenv', idx) = CicMkImplicit.mk_implicit_type metasenv subst context in - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in - metasenv', Cic.Meta (idx, irl) - | Some `Closed -> - let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst [] in - metasenv', Cic.Meta (idx, []) - | None -> - let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst context in - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in - metasenv', Cic.Meta (idx, irl) - | _ -> assert false -;; - - -let rec type_of_constant uri ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let _ = CicTypeChecker.typecheck uri in - let obj,u = - try - CicEnvironment.get_cooked_obj ugraph uri - with Not_found -> assert false - in - match obj with - C.Constant (_,_,ty,_,_) -> ty,u - | C.CurrentProof (_,_,_,ty,_,_) -> ty,u - | _ -> - raise - (RefineFailure (lazy ("Unknown constant definition " ^ U.string_of_uri uri))) - -and type_of_variable uri ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let _ = CicTypeChecker.typecheck uri in - let obj,u = - try - CicEnvironment.get_cooked_obj ugraph uri - with Not_found -> assert false - in - match obj with - C.Variable (_,_,ty,_,_) -> ty,u - | _ -> - raise - (RefineFailure - (lazy ("Unknown variable definition " ^ UriManager.string_of_uri uri))) - -and type_of_mutual_inductive_defs uri i ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let _ = CicTypeChecker.typecheck uri in - let obj,u = - try - CicEnvironment.get_cooked_obj ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,arity,_) = List.nth dl i in - arity,u - | _ -> - raise - (RefineFailure - (lazy ("Unknown mutual inductive definition " ^ U.string_of_uri uri))) - -and type_of_mutual_inductive_constr uri i j ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let _ = CicTypeChecker.typecheck uri in - let obj,u = - try - CicEnvironment.get_cooked_obj ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cl) = List.nth dl i in - let (_,ty) = List.nth cl (j-1) in - ty,u - | _ -> - raise - (RefineFailure - (lazy - ("Unkown mutual inductive definition " ^ U.string_of_uri uri))) - - -(* type_of_aux' is just another name (with a different scope) for type_of_aux *) - -(* the check_branch function checks if a branch of a case is refinable. - It returns a pair (outype_instance,args), a subst and a metasenv. - outype_instance is the expected result of applying the case outtype - to args. - The problem is that outype is in general unknown, and we should - try to synthesize it from the above information, that is in general - a second order unification problem. *) - -and check_branch n context metasenv subst left_args_no actualtype term expectedtype ugraph = - let module C = Cic in - (* let module R = CicMetaSubst in *) - let module R = CicReduction in - match R.whd ~subst context expectedtype with - C.MutInd (_,_,_) -> - (n,context,actualtype, [term]), subst, metasenv, ugraph - | C.Appl (C.MutInd (_,_,_)::tl) -> - let (_,arguments) = split tl left_args_no in - (n,context,actualtype, arguments@[term]), subst, metasenv, ugraph - | C.Prod (name,so,de) -> - (* we expect that the actual type of the branch has the due - number of Prod *) - (match R.whd ~subst context actualtype with - C.Prod (name',so',de') -> - let subst, metasenv, ugraph1 = - fo_unif_subst subst context metasenv so so' ugraph in - let term' = - (match CicSubstitution.lift 1 term with - C.Appl l -> C.Appl (l@[C.Rel 1]) - | t -> C.Appl [t ; C.Rel 1]) in - (* we should also check that the name variable is anonymous in - the actual type de' ?? *) - check_branch (n+1) - ((Some (name,(C.Decl so)))::context) - metasenv subst left_args_no de' term' de ugraph1 - | _ -> raise (AssertFailure (lazy "Wrong number of arguments"))) - | _ -> raise (AssertFailure (lazy "Prod or MutInd expected")) - -and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t - ugraph -= - let rec type_of_aux subst metasenv context t ugraph = - let module C = Cic in - let module S = CicSubstitution in - let module U = UriManager in - let (t',_,_,_,_) as res = - match t with - (* function *) - C.Rel n -> - (try - match List.nth context (n - 1) with - Some (_,C.Decl ty) -> - t,S.lift n ty,subst,metasenv, ugraph - | Some (_,C.Def (_,Some ty)) -> - t,S.lift n ty,subst,metasenv, ugraph - | Some (_,C.Def (bo,None)) -> - let ty,ugraph = - (* if it is in the context it must be already well-typed*) - CicTypeChecker.type_of_aux' ~subst metasenv context - (S.lift n bo) ugraph - in - t,ty,subst,metasenv,ugraph - | None -> - enrich localization_tbl t - (RefineFailure (lazy "Rel to hidden hypothesis")) - with - _ -> - enrich localization_tbl t - (RefineFailure (lazy "Not a close term"))) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst',subst',metasenv',ugraph1 = - check_exp_named_subst - subst metasenv context exp_named_subst ugraph - in - let ty_uri,ugraph1 = type_of_variable uri ugraph in - let ty = - CicSubstitution.subst_vars exp_named_subst' ty_uri - in - C.Var (uri,exp_named_subst'),ty,subst',metasenv',ugraph1 - | C.Meta (n,l) -> - (try - let (canonical_context, term,ty) = - CicUtil.lookup_subst n subst - in - let l',subst',metasenv',ugraph1 = - check_metasenv_consistency n subst metasenv context - canonical_context l ugraph - in - (* trust or check ??? *) - C.Meta (n,l'),CicSubstitution.subst_meta l' ty, - subst', metasenv', ugraph1 - (* type_of_aux subst metasenv - context (CicSubstitution.subst_meta l term) *) - with CicUtil.Subst_not_found _ -> - let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in - let l',subst',metasenv', ugraph1 = - check_metasenv_consistency n subst metasenv context - canonical_context l ugraph - in - C.Meta (n,l'),CicSubstitution.subst_meta l' ty, - subst', metasenv',ugraph1) - | C.Sort (C.Type tno) -> - let tno' = CicUniv.fresh() in - let ugraph1 = CicUniv.add_gt tno' tno ugraph in - t,(C.Sort (C.Type tno')),subst,metasenv,ugraph1 - | C.Sort _ -> - t,C.Sort (C.Type (CicUniv.fresh())),subst,metasenv,ugraph - | C.Implicit infos -> - let metasenv',t' = exp_impl metasenv subst context infos in - type_of_aux subst metasenv' context t' ugraph - | C.Cast (te,ty) -> - let ty',_,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context ty ugraph - in - let te',inferredty,subst'',metasenv'',ugraph2 = - type_of_aux subst' metasenv' context te ugraph1 - in - (try - let subst''',metasenv''',ugraph3 = - fo_unif_subst subst'' context metasenv'' - inferredty ty' ugraph2 - in - C.Cast (te',ty'),ty',subst''',metasenv''',ugraph3 - with - exn -> - enrich localization_tbl te' - ~f:(fun _ -> - lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst'' te' - context ^ " has type " ^ - CicMetaSubst.ppterm_in_context subst'' inferredty - context ^ " but is here used with type " ^ - CicMetaSubst.ppterm_in_context subst'' ty' context)) exn - ) - | C.Prod (name,s,t) -> - let carr t subst context = CicMetaSubst.apply_subst subst t in - let coerce_to_sort in_source tgt_sort t type_to_coerce - subst context metasenv uragph - = - if not !insert_coercions then - t,type_to_coerce,subst,metasenv,ugraph - else - let coercion_src = carr type_to_coerce subst context in - match coercion_src with - | Cic.Sort _ -> - t,type_to_coerce,subst,metasenv,ugraph - | Cic.Meta _ as meta -> - t, meta, subst, metasenv, ugraph - | Cic.Cast _ as cast -> - t, cast, subst, metasenv, ugraph - | term -> - let coercion_tgt = carr (Cic.Sort tgt_sort) subst context in - let search = CoercGraph.look_for_coercion in - let boh = search coercion_src coercion_tgt in - (match boh with - | CoercGraph.NoCoercion - | CoercGraph.NotHandled _ -> - enrich localization_tbl t - (RefineFailure - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst t context ^ - " is not a type since it has type " ^ - CicMetaSubst.ppterm_in_context - subst coercion_src context ^ " that is not a sort"))) - | CoercGraph.NotMetaClosed -> - enrich localization_tbl t - (Uncertain - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst t context ^ - " is not a type since it has type " ^ - CicMetaSubst.ppterm_in_context - subst coercion_src context ^ " that is not a sort"))) - | CoercGraph.SomeCoercion c -> - let newt, tty, subst, metasenv, ugraph = - avoid_double_coercion - subst metasenv ugraph - (Cic.Appl[c;t]) coercion_tgt - in - newt, tty, subst, metasenv, ugraph) - in - let s',sort1,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context s ugraph - in - let s',sort1,subst', metasenv',ugraph1 = - coerce_to_sort true (Cic.Type(CicUniv.fresh())) - s' sort1 subst' context metasenv' ugraph1 - in - let context_for_t = ((Some (name,(C.Decl s')))::context) in - let t',sort2,subst'',metasenv'',ugraph2 = - type_of_aux subst' metasenv' - context_for_t t ugraph1 - in - let t',sort2,subst'',metasenv'',ugraph2 = - coerce_to_sort false (Cic.Type(CicUniv.fresh())) - t' sort2 subst'' context_for_t metasenv'' ugraph2 - in - let sop,subst''',metasenv''',ugraph3 = - sort_of_prod subst'' metasenv'' - context (name,s') (sort1,sort2) ugraph2 - in - C.Prod (name,s',t'),sop,subst''',metasenv''',ugraph3 - | C.Lambda (n,s,t) -> - - let s',sort1,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context s ugraph in - let s',sort1,subst',metasenv',ugraph1 = - if not !insert_coercions then - s',sort1, subst', metasenv', ugraph1 - else - match CicReduction.whd ~subst:subst' context sort1 with - | C.Meta _ | C.Sort _ -> s',sort1, subst', metasenv', ugraph1 - | coercion_src -> - let coercion_tgt = Cic.Sort (Cic.Type (CicUniv.fresh())) in - let search = CoercGraph.look_for_coercion in - let boh = search coercion_src coercion_tgt in - match boh with - | CoercGraph.SomeCoercion c -> - let newt, tty, subst', metasenv', ugraph1 = - avoid_double_coercion - subst' metasenv' ugraph1 - (Cic.Appl[c;s']) coercion_tgt - in - newt, tty, subst', metasenv', ugraph1 - | CoercGraph.NoCoercion - | CoercGraph.NotHandled _ -> - enrich localization_tbl s' - (RefineFailure - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst s' context ^ - " is not a type since it has type " ^ - CicMetaSubst.ppterm_in_context - subst coercion_src context ^ " that is not a sort"))) - | CoercGraph.NotMetaClosed -> - enrich localization_tbl s' - (Uncertain - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst s' context ^ - " is not a type since it has type " ^ - CicMetaSubst.ppterm_in_context - subst coercion_src context ^ " that is not a sort"))) - in - let context_for_t = ((Some (n,(C.Decl s')))::context) in - let t',type2,subst'',metasenv'',ugraph2 = - type_of_aux subst' metasenv' context_for_t t ugraph1 - in - C.Lambda (n,s',t'),C.Prod (n,s',type2), - subst'',metasenv'',ugraph2 - | C.LetIn (n,s,t) -> - (* only to check if s is well-typed *) - let s',ty,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context s ugraph - in - let context_for_t = ((Some (n,(C.Def (s',Some ty))))::context) in - - let t',inferredty,subst'',metasenv'',ugraph2 = - type_of_aux subst' metasenv' - context_for_t t ugraph1 - in - (* One-step LetIn reduction. - * Even faster than the previous solution. - * Moreover the inferred type is closer to the expected one. - *) - C.LetIn (n,s',t'),CicSubstitution.subst s' inferredty, - subst'',metasenv'',ugraph2 - | C.Appl (he::((_::_) as tl)) -> - let he',hetype,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context he ugraph - in - let tlbody_and_type,subst'',metasenv'',ugraph2 = - List.fold_right - (fun x (res,subst,metasenv,ugraph) -> - let x',ty,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context x ugraph - in - (x', ty)::res,subst',metasenv',ugraph1 - ) tl ([],subst',metasenv',ugraph1) - in - let tl',applty,subst''',metasenv''',ugraph3 = - eat_prods true subst'' metasenv'' context - hetype tlbody_and_type ugraph2 - in - avoid_double_coercion - subst''' metasenv''' ugraph3 (C.Appl (he'::tl')) applty - | C.Appl _ -> assert false - | C.Const (uri,exp_named_subst) -> - let exp_named_subst',subst',metasenv',ugraph1 = - check_exp_named_subst subst metasenv context - exp_named_subst ugraph in - let ty_uri,ugraph2 = type_of_constant uri ugraph1 in - let cty = - CicSubstitution.subst_vars exp_named_subst' ty_uri - in - C.Const (uri,exp_named_subst'),cty,subst',metasenv',ugraph2 - | C.MutInd (uri,i,exp_named_subst) -> - let exp_named_subst',subst',metasenv',ugraph1 = - check_exp_named_subst subst metasenv context - exp_named_subst ugraph - in - let ty_uri,ugraph2 = type_of_mutual_inductive_defs uri i ugraph1 in - let cty = - CicSubstitution.subst_vars exp_named_subst' ty_uri in - C.MutInd (uri,i,exp_named_subst'),cty,subst',metasenv',ugraph2 - | C.MutConstruct (uri,i,j,exp_named_subst) -> - let exp_named_subst',subst',metasenv',ugraph1 = - check_exp_named_subst subst metasenv context - exp_named_subst ugraph - in - let ty_uri,ugraph2 = - type_of_mutual_inductive_constr uri i j ugraph1 - in - let cty = - CicSubstitution.subst_vars exp_named_subst' ty_uri - in - C.MutConstruct (uri,i,j,exp_named_subst'),cty,subst', - metasenv',ugraph2 - | C.MutCase (uri, i, outtype, term, pl) -> - (* first, get the inductive type (and noparams) - * in the environment *) - let (_,b,arity,constructors), expl_params, no_left_params,ugraph = - let _ = CicTypeChecker.typecheck uri in - let obj,u = CicEnvironment.get_cooked_obj ugraph uri in - match obj with - C.InductiveDefinition (l,expl_params,parsno,_) -> - List.nth l i , expl_params, parsno, u - | _ -> - enrich localization_tbl t - (RefineFailure - (lazy ("Unkown mutual inductive definition " ^ - U.string_of_uri uri))) - in - let rec count_prod t = - match CicReduction.whd ~subst context t with - C.Prod (_, _, t) -> 1 + (count_prod t) - | _ -> 0 - in - let no_args = count_prod arity in - (* now, create a "generic" MutInd *) - let metasenv,left_args = - CicMkImplicit.n_fresh_metas metasenv subst context no_left_params - in - let metasenv,right_args = - let no_right_params = no_args - no_left_params in - if no_right_params < 0 then assert false - else CicMkImplicit.n_fresh_metas - metasenv subst context no_right_params - in - let metasenv,exp_named_subst = - CicMkImplicit.fresh_subst metasenv subst context expl_params in - let expected_type = - if no_args = 0 then - C.MutInd (uri,i,exp_named_subst) - else - C.Appl - (C.MutInd (uri,i,exp_named_subst)::(left_args @ right_args)) - in - (* check consistency with the actual type of term *) - let term',actual_type,subst,metasenv,ugraph1 = - type_of_aux subst metasenv context term ugraph in - let expected_type',_, subst, metasenv,ugraph2 = - type_of_aux subst metasenv context expected_type ugraph1 - in - let actual_type = CicReduction.whd ~subst context actual_type in - let subst,metasenv,ugraph3 = - try - fo_unif_subst subst context metasenv - expected_type' actual_type ugraph2 - with - exn -> - enrich localization_tbl term' exn - ~f:(function _ -> - lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst term' - context ^ " has type " ^ - CicMetaSubst.ppterm_in_context subst actual_type - context ^ " but is here used with type " ^ - CicMetaSubst.ppterm_in_context subst expected_type' context)) - in - let rec instantiate_prod t = - function - [] -> t - | he::tl -> - match CicReduction.whd ~subst context t with - C.Prod (_,_,t') -> - instantiate_prod (CicSubstitution.subst he t') tl - | _ -> assert false - in - let arity_instantiated_with_left_args = - instantiate_prod arity left_args in - (* TODO: check if the sort elimination - * is allowed: [(I q1 ... qr)|B] *) - let (pl',_,outtypeinstances,subst,metasenv,ugraph4) = - List.fold_left - (fun (pl,j,outtypeinstances,subst,metasenv,ugraph) p -> - let constructor = - if left_args = [] then - (C.MutConstruct (uri,i,j,exp_named_subst)) - else - (C.Appl - (C.MutConstruct (uri,i,j,exp_named_subst)::left_args)) - in - let p',actual_type,subst,metasenv,ugraph1 = - type_of_aux subst metasenv context p ugraph - in - let constructor',expected_type, subst, metasenv,ugraph2 = - type_of_aux subst metasenv context constructor ugraph1 - in - let outtypeinstance,subst,metasenv,ugraph3 = - check_branch 0 context metasenv subst no_left_params - actual_type constructor' expected_type ugraph2 - in - (pl @ [p'],j+1, - outtypeinstance::outtypeinstances,subst,metasenv,ugraph3)) - ([],1,[],subst,metasenv,ugraph3) pl - in - - (* we are left to check that the outype matches his instances. - The easy case is when the outype is specified, that amount - to a trivial check. Otherwise, we should guess a type from - its instances - *) - - let outtype,outtypety, subst, metasenv,ugraph4 = - type_of_aux subst metasenv context outtype ugraph4 in - (match outtype with - | C.Meta (n,l) -> - (let candidate,ugraph5,metasenv,subst = - let exp_name_subst, metasenv = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - let uris = CicUtil.params_of_obj o in - List.fold_right ( - fun uri (acc,metasenv) -> - let metasenv',new_meta = - CicMkImplicit.mk_implicit metasenv subst context - in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable - context - in - (uri, Cic.Meta(new_meta,irl))::acc, metasenv' - ) uris ([],metasenv) - in - let ty = - match left_args,right_args with - [],[] -> Cic.MutInd(uri, i, exp_name_subst) - | _,_ -> - let rec mk_right_args = - function - 0 -> [] - | n -> (Cic.Rel n)::(mk_right_args (n - 1)) - in - let right_args_no = List.length right_args in - let lifted_left_args = - List.map (CicSubstitution.lift right_args_no) left_args - in - Cic.Appl (Cic.MutInd(uri,i,exp_name_subst):: - (lifted_left_args @ mk_right_args right_args_no)) - in - let fresh_name = - FreshNamesGenerator.mk_fresh_name ~subst metasenv - context Cic.Anonymous ~typ:ty - in - match outtypeinstances with - | [] -> - let extended_context = - let rec add_right_args = - function - Cic.Prod (name,ty,t) -> - Some (name,Cic.Decl ty)::(add_right_args t) - | _ -> [] - in - (Some (fresh_name,Cic.Decl ty)):: - (List.rev - (add_right_args arity_instantiated_with_left_args))@ - context - in - let metasenv,new_meta = - CicMkImplicit.mk_implicit metasenv subst extended_context - in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable - extended_context - in - let rec add_lambdas b = - function - Cic.Prod (name,ty,t) -> - Cic.Lambda (name,ty,(add_lambdas b t)) - | _ -> Cic.Lambda (fresh_name, ty, b) - in - let candidate = - add_lambdas (Cic.Meta (new_meta,irl)) - arity_instantiated_with_left_args - in - (Some candidate),ugraph4,metasenv,subst - | (constructor_args_no,_,instance,_)::tl -> - try - let instance',subst,metasenv = - CicMetaSubst.delift_rels subst metasenv - constructor_args_no instance - in - let candidate,ugraph,metasenv,subst = - List.fold_left ( - fun (candidate_oty,ugraph,metasenv,subst) - (constructor_args_no,_,instance,_) -> - match candidate_oty with - | None -> None,ugraph,metasenv,subst - | Some ty -> - try - let instance',subst,metasenv = - CicMetaSubst.delift_rels subst metasenv - constructor_args_no instance - in - let subst,metasenv,ugraph = - fo_unif_subst subst context metasenv - instance' ty ugraph - in - candidate_oty,ugraph,metasenv,subst - with - CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - None,ugraph,metasenv,subst - ) (Some instance',ugraph4,metasenv,subst) tl - in - match candidate with - | None -> None, ugraph,metasenv,subst - | Some t -> - let rec add_lambdas n b = - function - Cic.Prod (name,ty,t) -> - Cic.Lambda (name,ty,(add_lambdas (n + 1) b t)) - | _ -> - Cic.Lambda (fresh_name, ty, - CicSubstitution.lift (n + 1) t) - in - Some - (add_lambdas 0 t arity_instantiated_with_left_args), - ugraph,metasenv,subst - with CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> - None,ugraph4,metasenv,subst - in - match candidate with - | None -> raise (Uncertain (lazy "can't solve an higher order unification problem")) - | Some candidate -> - let subst,metasenv,ugraph = - fo_unif_subst subst context metasenv - candidate outtype ugraph5 - in - C.MutCase (uri, i, outtype, term', pl'), - CicReduction.head_beta_reduce - (CicMetaSubst.apply_subst subst - (Cic.Appl (outtype::right_args@[term']))), - subst,metasenv,ugraph) - | _ -> (* easy case *) - let tlbody_and_type,subst,metasenv,ugraph4 = - List.fold_right - (fun x (res,subst,metasenv,ugraph) -> - let x',ty,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context x ugraph - in - (x', ty)::res,subst',metasenv',ugraph1 - ) (right_args @ [term']) ([],subst,metasenv,ugraph4) - in - let _,_,subst,metasenv,ugraph4 = - eat_prods false subst metasenv context - outtypety tlbody_and_type ugraph4 - in - let _,_, subst, metasenv,ugraph5 = - type_of_aux subst metasenv context - (C.Appl ((outtype :: right_args) @ [term'])) ugraph4 - in - let (subst,metasenv,ugraph6) = - List.fold_left - (fun (subst,metasenv,ugraph) - (constructor_args_no,context,instance,args) -> - let instance' = - let appl = - let outtype' = - CicSubstitution.lift constructor_args_no outtype - in - C.Appl (outtype'::args) - in - CicReduction.whd ~subst context appl - in - fo_unif_subst subst context metasenv - instance instance' ugraph) - (subst,metasenv,ugraph5) outtypeinstances - in - C.MutCase (uri, i, outtype, term', pl'), - CicReduction.head_beta_reduce - (CicMetaSubst.apply_subst subst - (C.Appl(outtype::right_args@[term]))), - subst,metasenv,ugraph6) - | C.Fix (i,fl) -> - let fl_ty',subst,metasenv,types,ugraph1 = - List.fold_left - (fun (fl,subst,metasenv,types,ugraph) (n,_,ty,_) -> - let ty',_,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context ty ugraph - in - fl @ [ty'],subst',metasenv', - Some (C.Name n,(C.Decl ty')) :: types, ugraph - ) ([],subst,metasenv,[],ugraph) fl - in - let len = List.length types in - let context' = types@context in - let fl_bo',subst,metasenv,ugraph2 = - List.fold_left - (fun (fl,subst,metasenv,ugraph) ((name,x,_,bo),ty) -> - let bo',ty_of_bo,subst,metasenv,ugraph1 = - type_of_aux subst metasenv context' bo ugraph - in - let subst',metasenv',ugraph' = - fo_unif_subst subst context' metasenv - ty_of_bo (CicSubstitution.lift len ty) ugraph1 - in - fl @ [bo'] , subst',metasenv',ugraph' - ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty') - in - let ty = List.nth fl_ty' i in - (* now we have the new ty in fl_ty', the new bo in fl_bo', - * and we want the new fl with bo' and ty' injected in the right - * place. - *) - let rec map3 f l1 l2 l3 = - match l1,l2,l3 with - | [],[],[] -> [] - | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3) - | _ -> assert false - in - let fl'' = map3 (fun ty' bo' (name,x,ty,bo) -> (name,x,ty',bo') ) - fl_ty' fl_bo' fl - in - C.Fix (i,fl''),ty,subst,metasenv,ugraph2 - | C.CoFix (i,fl) -> - let fl_ty',subst,metasenv,types,ugraph1 = - List.fold_left - (fun (fl,subst,metasenv,types,ugraph) (n,ty,_) -> - let ty',_,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context ty ugraph - in - fl @ [ty'],subst',metasenv', - Some (C.Name n,(C.Decl ty')) :: types, ugraph1 - ) ([],subst,metasenv,[],ugraph) fl - in - let len = List.length types in - let context' = types@context in - let fl_bo',subst,metasenv,ugraph2 = - List.fold_left - (fun (fl,subst,metasenv,ugraph) ((name,_,bo),ty) -> - let bo',ty_of_bo,subst,metasenv,ugraph1 = - type_of_aux subst metasenv context' bo ugraph - in - let subst',metasenv',ugraph' = - fo_unif_subst subst context' metasenv - ty_of_bo (CicSubstitution.lift len ty) ugraph1 - in - fl @ [bo'],subst',metasenv',ugraph' - ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty') - in - let ty = List.nth fl_ty' i in - (* now we have the new ty in fl_ty', the new bo in fl_bo', - * and we want the new fl with bo' and ty' injected in the right - * place. - *) - let rec map3 f l1 l2 l3 = - match l1,l2,l3 with - | [],[],[] -> [] - | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3) - | _ -> assert false - in - let fl'' = map3 (fun ty' bo' (name,ty,bo) -> (name,ty',bo') ) - fl_ty' fl_bo' fl - in - C.CoFix (i,fl''),ty,subst,metasenv,ugraph2 - in - relocalize localization_tbl t t'; - res - - and avoid_double_coercion subst metasenv ugraph t ty = - match t with - | (Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ]) when - CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 -> - let source_carr = CoercGraph.source_of c2 in - let tgt_carr = CicMetaSubst.apply_subst subst ty in - (match CoercGraph.look_for_coercion source_carr tgt_carr - with - | CoercGraph.SomeCoercion c -> - Cic.Appl [ c ; head ], ty, subst,metasenv,ugraph - | _ -> assert false) (* the composite coercion must exist *) - | _ -> t, ty, subst, metasenv, ugraph - - (* 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 - metano subst metasenv context canonical_context l ugraph - = - 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.subst_meta l (S.lift i t))))::(aux (i+1) tl) - | (Some (n,C.Def (t,None)))::tl -> - (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl) - | None::tl -> None::(aux (i+1) tl) - | (Some (n,C.Def (t,Some ty)))::tl -> - (Some (n, - C.Def ((S.subst_meta l (S.lift i t)), - Some (S.subst_meta l (S.lift i ty))))) :: (aux (i+1) tl) - in - aux 1 canonical_context - in - try - List.fold_left2 - (fun (l,subst,metasenv,ugraph) t ct -> - match (t,ct) with - _,None -> - l @ [None],subst,metasenv,ugraph - | Some t,Some (_,C.Def (ct,_)) -> - let subst',metasenv',ugraph' = - (try - fo_unif_subst subst context metasenv t ct ugraph - with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since %s cannot be unified with %s. Reason: %s" (CicMetaSubst.ppterm subst t) (CicMetaSubst.ppterm subst ct) (match e with AssertFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e)))))) - in - l @ [Some t],subst',metasenv',ugraph' - | Some t,Some (_,C.Decl ct) -> - let t',inferredty,subst',metasenv',ugraph1 = - type_of_aux subst metasenv context t ugraph - in - let subst'',metasenv'',ugraph2 = - (try - fo_unif_subst - subst' context metasenv' inferredty ct ugraph1 - with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since the type %s of %s cannot be unified with the expected type %s. Reason: %s" (CicMetaSubst.ppterm subst' inferredty) (CicMetaSubst.ppterm subst' t) (CicMetaSubst.ppterm subst' ct) (match e with AssertFailure msg -> Lazy.force msg | RefineFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e)))))) - in - l @ [Some t'], subst'',metasenv'',ugraph2 - | None, Some _ -> - raise (RefineFailure (lazy (sprintf "Not well typed metavariable instance %s: the local context does not instantiate an hypothesis even if the hypothesis is not restricted in the canonical context %s" (CicMetaSubst.ppterm subst (Cic.Meta (metano, l))) (CicMetaSubst.ppcontext subst canonical_context))))) ([],subst,metasenv,ugraph) l lifted_canonical_context - with - Invalid_argument _ -> - raise - (RefineFailure - (lazy (sprintf - "Not well typed metavariable instance %s: the length of the local context does not match the length of the canonical context %s" - (CicMetaSubst.ppterm subst (Cic.Meta (metano, l))) - (CicMetaSubst.ppcontext subst canonical_context)))) - - and check_exp_named_subst metasubst metasenv context tl ugraph = - let rec check_exp_named_subst_aux metasubst metasenv substs tl ugraph = - match tl with - [] -> [],metasubst,metasenv,ugraph - | (uri,t)::tl -> - let ty_uri,ugraph1 = type_of_variable uri ugraph in - let typeofvar = - CicSubstitution.subst_vars substs ty_uri in - (* CSC: why was this code here? it is wrong - (match CicEnvironment.get_cooked_obj ~trust:false uri with - Cic.Variable (_,Some bo,_,_) -> - raise - (RefineFailure (lazy - "A variable with a body can not be explicit substituted")) - | Cic.Variable (_,None,_,_) -> () - | _ -> - raise - (RefineFailure (lazy - ("Unkown variable definition " ^ UriManager.string_of_uri uri))) - ) ; - *) - let t',typeoft,metasubst',metasenv',ugraph2 = - type_of_aux metasubst metasenv context t ugraph1 in - let subst = uri,t' in - let metasubst'',metasenv'',ugraph3 = - try - fo_unif_subst - metasubst' context metasenv' typeoft typeofvar ugraph2 - with _ -> - raise (RefineFailure (lazy - ("Wrong Explicit Named Substitution: " ^ - CicMetaSubst.ppterm metasubst' typeoft ^ - " not unifiable with " ^ - CicMetaSubst.ppterm metasubst' typeofvar))) - in - (* FIXME: no mere tail recursive! *) - let exp_name_subst, metasubst''', metasenv''', ugraph4 = - check_exp_named_subst_aux - metasubst'' metasenv'' (substs@[subst]) tl ugraph3 - in - ((uri,t')::exp_name_subst), metasubst''', metasenv''', ugraph4 - in - check_exp_named_subst_aux metasubst metasenv [] tl ugraph - - - and sort_of_prod subst metasenv context (name,s) (t1, t2) ugraph = - let module C = Cic in - let context_for_t2 = (Some (name,C.Decl s))::context in - let t1'' = CicReduction.whd ~subst context t1 in - let t2'' = CicReduction.whd ~subst context_for_t2 t2 in - match (t1'', t2'') with - (C.Sort s1, C.Sort s2) - when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) -> - (* different than Coq manual!!! *) - C.Sort s2,subst,metasenv,ugraph - | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> - let t' = CicUniv.fresh() in - let ugraph1 = CicUniv.add_ge t' t1 ugraph in - let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in - C.Sort (C.Type t'),subst,metasenv,ugraph2 - | (C.Sort _,C.Sort (C.Type t1)) -> - C.Sort (C.Type t1),subst,metasenv,ugraph - | (C.Meta _, C.Sort _) -> t2'',subst,metasenv,ugraph - | (C.Sort _,C.Meta _) | (C.Meta _,C.Meta _) -> - (* TODO how can we force the meta to become a sort? If we don't we - * brake the invariant that refine produce only well typed terms *) - (* TODO if we check the non meta term and if it is a sort then we - * are likely to know the exact value of the result e.g. if the rhs - * is a Sort (Prop | Set | CProp) then the result is the rhs *) - let (metasenv,idx) = - CicMkImplicit.mk_implicit_sort metasenv subst in - let (subst, metasenv,ugraph1) = - fo_unif_subst subst context_for_t2 metasenv - (C.Meta (idx,[])) t2'' ugraph - in - t2'',subst,metasenv,ugraph1 - | _,_ -> - raise - (RefineFailure - (lazy - (sprintf - ("Two sorts were expected, found %s " ^^ - "(that reduces to %s) and %s (that reduces to %s)") - (CicPp.ppterm t1) (CicPp.ppterm t1'') (CicPp.ppterm t2) - (CicPp.ppterm t2'')))) - - and eat_prods - allow_coercions subst metasenv context hetype tlbody_and_type ugraph - = - let rec mk_prod metasenv context' = - function - [] -> - let (metasenv, idx) = - CicMkImplicit.mk_implicit_type metasenv subst context' - in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context' - in - metasenv,Cic.Meta (idx, irl) - | (_,argty)::tl -> - let (metasenv, idx) = - CicMkImplicit.mk_implicit_type metasenv subst context' - in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context' - in - let meta = Cic.Meta (idx,irl) in - let name = - (* The name must be fresh for context. *) - (* Nevertheless, argty is well-typed only in context. *) - (* Thus I generate a name (name_hint) in context and *) - (* then I generate a name --- using the hint name_hint *) - (* --- that is fresh in context'. *) - let name_hint = - (* Cic.Name "pippo" *) - FreshNamesGenerator.mk_fresh_name ~subst metasenv - (* (CicMetaSubst.apply_subst_metasenv subst metasenv) *) - (CicMetaSubst.apply_subst_context subst context) - Cic.Anonymous - ~typ:(CicMetaSubst.apply_subst subst argty) - in - (* [] and (Cic.Sort Cic.prop) are dummy: they will not be used *) - FreshNamesGenerator.mk_fresh_name ~subst - [] context' name_hint ~typ:(Cic.Sort Cic.Prop) - in - let metasenv,target = - mk_prod metasenv ((Some (name, Cic.Decl meta))::context') tl - in - metasenv,Cic.Prod (name,meta,target) - in - let metasenv,hetype' = mk_prod metasenv context tlbody_and_type in - let (subst, metasenv,ugraph1) = - try - fo_unif_subst subst context metasenv hetype hetype' ugraph - with exn -> - debug_print (lazy (Printf.sprintf "hetype=%s\nhetype'=%s\nmetasenv=%s\nsubst=%s" - (CicPp.ppterm hetype) - (CicPp.ppterm hetype') - (CicMetaSubst.ppmetasenv [] metasenv) - (CicMetaSubst.ppsubst subst))); - raise exn - - in - let rec eat_prods metasenv subst context hetype ugraph = - function - | [] -> [],metasenv,subst,hetype,ugraph - | (hete, hety)::tl -> - (match hetype with - Cic.Prod (n,s,t) -> - let arg,subst,metasenv,ugraph1 = - try - let subst,metasenv,ugraph1 = - fo_unif_subst subst context metasenv hety s ugraph - in - hete,subst,metasenv,ugraph1 - with exn when allow_coercions && !insert_coercions -> - (* we search a coercion from hety to s *) - let coer, tgt_carr = - let carr t subst context = - CicMetaSubst.apply_subst subst t - in - let c_hety = carr hety subst context in - let c_s = carr s subst context in - CoercGraph.look_for_coercion c_hety c_s, c_s - in - (match coer with - | CoercGraph.NoCoercion - | CoercGraph.NotHandled _ -> - enrich localization_tbl hete - (RefineFailure - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst hete - context ^ " has type " ^ - CicMetaSubst.ppterm_in_context subst hety - context ^ " but is here used with type " ^ - CicMetaSubst.ppterm_in_context subst s context - (* "\nReason: " ^ Lazy.force e*)))) - | CoercGraph.NotMetaClosed -> - enrich localization_tbl hete - (Uncertain - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst hete - context ^ " has type " ^ - CicMetaSubst.ppterm_in_context subst hety - context ^ " but is here used with type " ^ - CicMetaSubst.ppterm_in_context subst s context - (* "\nReason: " ^ Lazy.force e*)))) - | CoercGraph.SomeCoercion c -> - let newt, _, subst, metasenv, ugraph = - avoid_double_coercion - subst metasenv ugraph - (Cic.Appl[c;hete]) tgt_carr in - try - let newty,newhety,subst,metasenv,ugraph = - type_of_aux subst metasenv context newt ugraph in - let subst,metasenv,ugraph1 = - fo_unif_subst subst context metasenv - newhety s ugraph - in - newt, subst, metasenv, ugraph - with exn -> - enrich localization_tbl hete - ~f:(fun _ -> - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst hete - context ^ " has type " ^ - CicMetaSubst.ppterm_in_context subst hety - context ^ " but is here used with type " ^ - CicMetaSubst.ppterm_in_context subst s context - (* "\nReason: " ^ Lazy.force e*)))) exn) - | exn -> - enrich localization_tbl hete - ~f:(fun _ -> - (lazy ("The term " ^ - CicMetaSubst.ppterm_in_context subst hete - context ^ " has type " ^ - CicMetaSubst.ppterm_in_context subst hety - context ^ " but is here used with type " ^ - CicMetaSubst.ppterm_in_context subst s context - (* "\nReason: " ^ Lazy.force e*)))) exn - in - let coerced_args,metasenv',subst',t',ugraph2 = - eat_prods metasenv subst context - (CicSubstitution.subst arg t) ugraph1 tl - in - arg::coerced_args,metasenv',subst',t',ugraph2 - | _ -> assert false - ) - in - let coerced_args,metasenv,subst,t,ugraph2 = - eat_prods metasenv subst context hetype' ugraph1 tlbody_and_type - in - coerced_args,t,subst,metasenv,ugraph2 - in - - (* eat prods ends here! *) - - let t',ty,subst',metasenv',ugraph1 = - type_of_aux [] metasenv context t ugraph - in - let substituted_t = CicMetaSubst.apply_subst subst' t' in - let substituted_ty = CicMetaSubst.apply_subst subst' ty in - (* Andrea: ho rimesso qui l'applicazione della subst al - metasenv dopo che ho droppato l'invariante che il metsaenv - e' sempre istanziato *) - let substituted_metasenv = - CicMetaSubst.apply_subst_metasenv subst' metasenv' in - (* metasenv' *) - (* substituted_t,substituted_ty,substituted_metasenv *) - (* ANDREA: spostare tutta questa robaccia da un altra parte *) - let cleaned_t = - FreshNamesGenerator.clean_dummy_dependent_types substituted_t in - let cleaned_ty = - FreshNamesGenerator.clean_dummy_dependent_types substituted_ty in - let cleaned_metasenv = - List.map - (function (n,context,ty) -> - let ty' = FreshNamesGenerator.clean_dummy_dependent_types ty in - let context' = - List.map - (function - None -> None - | Some (n, Cic.Decl t) -> - Some (n, - Cic.Decl (FreshNamesGenerator.clean_dummy_dependent_types t)) - | Some (n, Cic.Def (bo,ty)) -> - let bo' = FreshNamesGenerator.clean_dummy_dependent_types bo in - let ty' = - match ty with - None -> None - | Some ty -> - Some (FreshNamesGenerator.clean_dummy_dependent_types ty) - in - Some (n, Cic.Def (bo',ty')) - ) context - in - (n,context',ty') - ) substituted_metasenv - in - (cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1) -;; - -let type_of_aux' ?localization_tbl metasenv context term ugraph = - try - type_of_aux' ?localization_tbl metasenv context term ugraph - with - CicUniv.UniverseInconsistency msg -> raise (RefineFailure (lazy msg)) - -let undebrujin uri typesno tys t = - snd - (List.fold_right - (fun (name,_,_,_) (i,t) -> - (* here the explicit_named_substituion is assumed to be *) - (* of length 0 *) - let t' = Cic.MutInd (uri,i,[]) in - let t = CicSubstitution.subst t' t in - i - 1,t - ) tys (typesno - 1,t)) - -let map_first_n n start f g l = - let rec aux acc k l = - if k < n then - match l with - | [] -> raise (Invalid_argument "map_first_n") - | hd :: tl -> f hd k (aux acc (k+1) tl) - else - g acc l - in - aux start 0 l - -(*CSC: this is a very rough approximation; to be finished *) -let are_all_occurrences_positive metasenv ugraph uri tys leftno = - let subst,metasenv,ugraph,tys = - List.fold_right - (fun (name,ind,arity,cl) (subst,metasenv,ugraph,acc) -> - let subst,metasenv,ugraph,cl = - List.fold_right - (fun (name,ty) (subst,metasenv,ugraph,acc) -> - let rec aux ctx k subst = function - | Cic.Appl((Cic.MutInd (uri',_,_)as hd)::tl) when uri = uri'-> - let subst,metasenv,ugraph,tl = - map_first_n leftno - (subst,metasenv,ugraph,[]) - (fun t n (subst,metasenv,ugraph,acc) -> - let subst,metasenv,ugraph = - fo_unif_subst - subst ctx metasenv t (Cic.Rel (k-n)) ugraph - in - subst,metasenv,ugraph,(t::acc)) - (fun (s,m,g,acc) tl -> assert(acc=[]);(s,m,g,tl)) - tl - in - subst,metasenv,ugraph,(Cic.Appl (hd::tl)) - | Cic.MutInd(uri',_,_) as t when uri = uri'-> - subst,metasenv,ugraph,t - | Cic.Prod (name,s,t) -> - let ctx = (Some (name,Cic.Decl s))::ctx in - let subst,metasenv,ugraph,t = aux ctx (k+1) subst t in - subst,metasenv,ugraph,Cic.Prod (name,s,t) - | _ -> - raise - (RefineFailure - (lazy "not well formed constructor type")) - in - let subst,metasenv,ugraph,ty = aux [] 0 subst ty in - subst,metasenv,ugraph,(name,ty) :: acc) - cl (subst,metasenv,ugraph,[]) - in - subst,metasenv,ugraph,(name,ind,arity,cl)::acc) - tys ([],metasenv,ugraph,[]) - in - let substituted_tys = - List.map - (fun (name,ind,arity,cl) -> - let cl = - List.map (fun (name, ty) -> name,CicMetaSubst.apply_subst subst ty) cl - in - name,ind,CicMetaSubst.apply_subst subst arity,cl) - tys - in - metasenv,ugraph,substituted_tys - -let typecheck metasenv uri obj ~localization_tbl = - let ugraph = CicUniv.empty_ugraph in - match obj with - Cic.Constant (name,Some bo,ty,args,attrs) -> - let bo',boty,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv [] bo ugraph in - let ty',_,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv [] ty ugraph in - let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in - let bo' = CicMetaSubst.apply_subst subst bo' in - let ty' = CicMetaSubst.apply_subst subst ty' in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - Cic.Constant (name,Some bo',ty',args,attrs),metasenv,ugraph - | Cic.Constant (name,None,ty,args,attrs) -> - let ty',_,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv [] ty ugraph - in - Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph - | Cic.CurrentProof (name,metasenv',bo,ty,args,attrs) -> - assert (metasenv' = metasenv); - (* Here we do not check the metasenv for correctness *) - let bo',boty,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv [] bo ugraph in - let ty',sort,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv [] ty ugraph in - begin - match sort with - Cic.Sort _ - (* instead of raising Uncertain, let's hope that the meta will become - a sort *) - | Cic.Meta _ -> () - | _ -> raise (RefineFailure (lazy "The term provided is not a type")) - end; - let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in - let bo' = CicMetaSubst.apply_subst subst bo' in - let ty' = CicMetaSubst.apply_subst subst ty' in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - Cic.CurrentProof (name,metasenv,bo',ty',args,attrs),metasenv,ugraph - | Cic.Variable _ -> assert false (* not implemented *) - | Cic.InductiveDefinition (tys,args,paramsno,attrs) -> - (*CSC: this code is greately simplified and many many checks are missing *) - (*CSC: e.g. the constructors are not required to build their own types, *) - (*CSC: the arities are not required to have as type a sort, etc. *) - let uri = match uri with Some uri -> uri | None -> assert false in - let typesno = List.length tys in - (* first phase: we fix only the types *) - let metasenv,ugraph,tys = - List.fold_right - (fun (name,b,ty,cl) (metasenv,ugraph,res) -> - let ty',_,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv [] ty ugraph - in - metasenv,ugraph,(name,b,ty',cl)::res - ) tys (metasenv,ugraph,[]) in - let con_context = - List.rev_map (fun (name,_,ty,_)-> Some (Cic.Name name,Cic.Decl ty)) tys in - (* second phase: we fix only the constructors *) - let metasenv,ugraph,tys = - List.fold_right - (fun (name,b,ty,cl) (metasenv,ugraph,res) -> - let metasenv,ugraph,cl' = - List.fold_right - (fun (name,ty) (metasenv,ugraph,res) -> - let ty = - CicTypeChecker.debrujin_constructor - ~cb:(relocalize localization_tbl) uri typesno ty in - let ty',_,metasenv,ugraph = - type_of_aux' ~localization_tbl metasenv con_context ty ugraph in - let ty' = undebrujin uri typesno tys ty' in - metasenv,ugraph,(name,ty')::res - ) cl (metasenv,ugraph,[]) - in - metasenv,ugraph,(name,b,ty,cl')::res - ) tys (metasenv,ugraph,[]) in - (* third phase: we check the positivity condition *) - let metasenv,ugraph,tys = - are_all_occurrences_positive metasenv ugraph uri tys paramsno - in - Cic.InductiveDefinition (tys,args,paramsno,attrs),metasenv,ugraph - -(* DEBUGGING ONLY -let type_of_aux' metasenv context term = - try - let (t,ty,m) = - type_of_aux' metasenv context term in - debug_print (lazy - ("@@@ REFINE SUCCESSFUL: " ^ CicPp.ppterm t ^ " : " ^ CicPp.ppterm ty)); - debug_print (lazy - ("@@@ REFINE SUCCESSFUL (metasenv):\n" ^ CicMetaSubst.ppmetasenv ~sep:";" m [])); - (t,ty,m) - with - | RefineFailure msg as e -> - debug_print (lazy ("@@@ REFINE FAILED: " ^ msg)); - raise e - | Uncertain msg as e -> - debug_print (lazy ("@@@ REFINE UNCERTAIN: " ^ msg)); - raise e -;; *) - -let profiler2 = HExtlib.profile "CicRefine" - -let type_of_aux' ?localization_tbl metasenv context term ugraph = - profiler2.HExtlib.profile - (type_of_aux' ?localization_tbl metasenv context term) ugraph - -let typecheck ~localization_tbl metasenv uri obj = - profiler2.HExtlib.profile (typecheck ~localization_tbl metasenv uri) obj diff --git a/helm/ocaml/cic_unification/cicRefine.mli b/helm/ocaml/cic_unification/cicRefine.mli deleted file mode 100644 index 224a7586c..000000000 --- a/helm/ocaml/cic_unification/cicRefine.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* 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 RefineFailure of string Lazy.t;; -exception Uncertain of string Lazy.t;; -exception AssertFailure of string Lazy.t;; - -(* type_of_aux' metasenv context term graph *) -(* refines [term] and returns the refined form of [term], *) -(* its type, the new metasenv and universe graph. *) -val type_of_aux': - ?localization_tbl:Token.flocation Cic.CicHash.t -> - Cic.metasenv -> Cic.context -> Cic.term -> CicUniv.universe_graph -> - Cic.term * Cic.term * Cic.metasenv * CicUniv.universe_graph - -(* typecheck metasenv uri obj graph *) -(* refines [obj] and returns the refined form of [obj], *) -(* the new metasenv and universe graph. *) -(* the [uri] is required only for inductive definitions *) -val typecheck : - localization_tbl:Token.flocation Cic.CicHash.t -> - Cic.metasenv -> UriManager.uri option -> Cic.obj -> - Cic.obj * Cic.metasenv * CicUniv.universe_graph - -val insert_coercions: bool ref (* initially true *) - diff --git a/helm/ocaml/cic_unification/cicUnification.ml b/helm/ocaml/cic_unification/cicUnification.ml deleted file mode 100644 index d1e010ca6..000000000 --- a/helm/ocaml/cic_unification/cicUnification.ml +++ /dev/null @@ -1,800 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open Printf - -exception UnificationFailure of string Lazy.t;; -exception Uncertain of string Lazy.t;; -exception AssertFailure of string Lazy.t;; - -let verbose = false;; -let debug_print = fun _ -> () - -let profiler_toa = HExtlib.profile "fo_unif_subst.type_of_aux'" -let profiler_beta_expand = HExtlib.profile "fo_unif_subst.beta_expand" -let profiler_deref = HExtlib.profile "fo_unif_subst.deref'" -let profiler_are_convertible = HExtlib.profile "fo_unif_subst.are_convertible" - -let type_of_aux' metasenv subst context term ugraph = -let foo () = - try - CicTypeChecker.type_of_aux' ~subst metasenv context term ugraph - with - CicTypeChecker.TypeCheckerFailure msg -> - let msg = - lazy - (sprintf - "Kernel Type checking error: -%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad." - (CicMetaSubst.ppterm subst term) - (CicMetaSubst.ppterm [] term) - (CicMetaSubst.ppcontext subst context) - (CicMetaSubst.ppmetasenv subst metasenv) - (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in - raise (AssertFailure msg) - | CicTypeChecker.AssertFailure msg -> - let msg = lazy - (sprintf - "Kernel Type checking assertion failure: -%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad." - (CicMetaSubst.ppterm subst term) - (CicMetaSubst.ppterm [] term) - (CicMetaSubst.ppcontext subst context) - (CicMetaSubst.ppmetasenv subst metasenv) - (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in - raise (AssertFailure msg) -in profiler_toa.HExtlib.profile foo () -;; - -let exists_a_meta l = - List.exists (function Cic.Meta _ -> true | _ -> false) l - -let rec deref subst t = - let snd (_,a,_) = a in - match t with - Cic.Meta(n,l) -> - (try - deref subst - (CicSubstitution.subst_meta - l (snd (CicUtil.lookup_subst n subst))) - with - CicUtil.Subst_not_found _ -> t) - | Cic.Appl(Cic.Meta(n,l)::args) -> - (match deref subst (Cic.Meta(n,l)) with - | Cic.Lambda _ as t -> - deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args))) - | r -> Cic.Appl(r::args)) - | Cic.Appl(((Cic.Lambda _) as t)::args) -> - deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args))) - | t -> t -;; - -let deref subst t = - let foo () = deref subst t - in profiler_deref.HExtlib.profile foo () - -exception WrongShape;; -let eta_reduce after_beta_expansion after_beta_expansion_body - before_beta_expansion - = - try - match before_beta_expansion,after_beta_expansion_body with - Cic.Appl l, Cic.Appl l' -> - let rec all_but_last check_last = - function - [] -> assert false - | [Cic.Rel 1] -> [] - | [_] -> if check_last then raise WrongShape else [] - | he::tl -> he::(all_but_last check_last tl) - in - let all_but_last check_last l = - match all_but_last check_last l with - [] -> assert false - | [he] -> he - | l -> Cic.Appl l - in - let t = CicSubstitution.subst (Cic.Rel (-1)) (all_but_last true l') in - let all_but_last = all_but_last false l in - (* here we should test alpha-equivalence; however we know by - construction that here alpha_equivalence is equivalent to = *) - if t = all_but_last then - all_but_last - else - after_beta_expansion - | _,_ -> after_beta_expansion - with - WrongShape -> after_beta_expansion - -let rec beta_expand test_equality_only metasenv subst context t arg ugraph = - let module S = CicSubstitution in - let module C = Cic in -let foo () = - let rec aux metasenv subst n context t' ugraph = - try - - let subst,metasenv,ugraph1 = - fo_unif_subst test_equality_only subst context metasenv - (CicSubstitution.lift n arg) t' ugraph - - in - subst,metasenv,C.Rel (1 + n),ugraph1 - with - Uncertain _ - | UnificationFailure _ -> - match t' with - | C.Rel m -> subst,metasenv, - (if m <= n then C.Rel m else C.Rel (m+1)),ugraph - | C.Var (uri,exp_named_subst) -> - let subst,metasenv,exp_named_subst',ugraph1 = - aux_exp_named_subst metasenv subst n context exp_named_subst ugraph - in - subst,metasenv,C.Var (uri,exp_named_subst'),ugraph1 - | C.Meta (i,l) -> - (* andrea: in general, beta_expand can create badly typed - terms. This happens quite seldom in practice, UNLESS we - iterate on the local context. For this reason, we renounce - to iterate and just lift *) - let l = - List.map - (function - Some t -> Some (CicSubstitution.lift 1 t) - | None -> None) l in - subst, metasenv, C.Meta (i,l), ugraph - | C.Sort _ - | C.Implicit _ as t -> subst,metasenv,t,ugraph - | C.Cast (te,ty) -> - let subst,metasenv,te',ugraph1 = - aux metasenv subst n context te ugraph in - let subst,metasenv,ty',ugraph2 = - aux metasenv subst n context ty ugraph1 in - (* TASSI: sure this is in serial? *) - subst,metasenv,(C.Cast (te', ty')),ugraph2 - | C.Prod (nn,s,t) -> - let subst,metasenv,s',ugraph1 = - aux metasenv subst n context s ugraph in - let subst,metasenv,t',ugraph2 = - aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t - ugraph1 - in - (* TASSI: sure this is in serial? *) - subst,metasenv,(C.Prod (nn, s', t')),ugraph2 - | C.Lambda (nn,s,t) -> - let subst,metasenv,s',ugraph1 = - aux metasenv subst n context s ugraph in - let subst,metasenv,t',ugraph2 = - aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t ugraph1 - in - (* TASSI: sure this is in serial? *) - subst,metasenv,(C.Lambda (nn, s', t')),ugraph2 - | C.LetIn (nn,s,t) -> - let subst,metasenv,s',ugraph1 = - aux metasenv subst n context s ugraph in - let subst,metasenv,t',ugraph2 = - aux metasenv subst (n+1) ((Some (nn, C.Def (s,None)))::context) t - ugraph1 - in - (* TASSI: sure this is in serial? *) - subst,metasenv,(C.LetIn (nn, s', t')),ugraph2 - | C.Appl l -> - let subst,metasenv,revl',ugraph1 = - List.fold_left - (fun (subst,metasenv,appl,ugraph) t -> - let subst,metasenv,t',ugraph1 = - aux metasenv subst n context t ugraph in - subst,metasenv,(t'::appl),ugraph1 - ) (subst,metasenv,[],ugraph) l - in - subst,metasenv,(C.Appl (List.rev revl')),ugraph1 - | C.Const (uri,exp_named_subst) -> - let subst,metasenv,exp_named_subst',ugraph1 = - aux_exp_named_subst metasenv subst n context exp_named_subst ugraph - in - subst,metasenv,(C.Const (uri,exp_named_subst')),ugraph1 - | C.MutInd (uri,i,exp_named_subst) -> - let subst,metasenv,exp_named_subst',ugraph1 = - aux_exp_named_subst metasenv subst n context exp_named_subst ugraph - in - subst,metasenv,(C.MutInd (uri,i,exp_named_subst')),ugraph1 - | C.MutConstruct (uri,i,j,exp_named_subst) -> - let subst,metasenv,exp_named_subst',ugraph1 = - aux_exp_named_subst metasenv subst n context exp_named_subst ugraph - in - subst,metasenv,(C.MutConstruct (uri,i,j,exp_named_subst')),ugraph1 - | C.MutCase (sp,i,outt,t,pl) -> - let subst,metasenv,outt',ugraph1 = - aux metasenv subst n context outt ugraph in - let subst,metasenv,t',ugraph2 = - aux metasenv subst n context t ugraph1 in - let subst,metasenv,revpl',ugraph3 = - List.fold_left - (fun (subst,metasenv,pl,ugraph) t -> - let subst,metasenv,t',ugraph1 = - aux metasenv subst n context t ugraph in - subst,metasenv,(t'::pl),ugraph1 - ) (subst,metasenv,[],ugraph2) pl - in - subst,metasenv,(C.MutCase (sp,i,outt', t', List.rev revpl')),ugraph3 - (* TASSI: not sure this is serial *) - | C.Fix (i,fl) -> -(*CSC: not implemented - 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) -*) - subst,metasenv,(CicSubstitution.lift 1 t' ),ugraph - | C.CoFix (i,fl) -> -(*CSC: not implemented - 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) - -*) - subst,metasenv,(CicSubstitution.lift 1 t'), ugraph - - and aux_exp_named_subst metasenv subst n context ens ugraph = - List.fold_right - (fun (uri,t) (subst,metasenv,l,ugraph) -> - let subst,metasenv,t',ugraph1 = aux metasenv subst n context t ugraph in - subst,metasenv,((uri,t')::l),ugraph1) ens (subst,metasenv,[],ugraph) - in - let argty,ugraph1 = type_of_aux' metasenv subst context arg ugraph in - let fresh_name = - FreshNamesGenerator.mk_fresh_name ~subst - metasenv context (Cic.Name "Hbeta") ~typ:argty - in - let subst,metasenv,t',ugraph2 = aux metasenv subst 0 context t ugraph1 in - let t'' = eta_reduce (C.Lambda (fresh_name,argty,t')) t' t in - subst, metasenv, t'', ugraph2 -in profiler_beta_expand.HExtlib.profile foo () - - -and beta_expand_many test_equality_only metasenv subst context t args ugraph = - let subst,metasenv,hd,ugraph = - List.fold_right - (fun arg (subst,metasenv,t,ugraph) -> - let subst,metasenv,t,ugraph1 = - beta_expand test_equality_only - metasenv subst context t arg ugraph - in - subst,metasenv,t,ugraph1 - ) args (subst,metasenv,t,ugraph) - in - subst,metasenv,hd,ugraph - - -(* NUOVA UNIFICAZIONE *) -(* A substitution is a (int * Cic.term) list that associates a - metavariable i with its body. - A metaenv is a (int * Cic.term) list that associate a metavariable - i with is type. - fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back - a new substitution which is _NOT_ unwinded. It must be unwinded before - applying it. *) - -and fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph = - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let t1 = deref subst t1 in - let t2 = deref subst t2 in - let b,ugraph = -let foo () = - R.are_convertible ~subst ~metasenv context t1 t2 ugraph -in profiler_are_convertible.HExtlib.profile foo () - in - if b then - subst, metasenv, ugraph - else - match (t1, t2) with - | (C.Meta (n,ln), C.Meta (m,lm)) when n=m -> - let _,subst,metasenv,ugraph1 = - (try - List.fold_left2 - (fun (j,subst,metasenv,ugraph) t1 t2 -> - match t1,t2 with - None,_ - | _,None -> j+1,subst,metasenv,ugraph - | Some t1', Some t2' -> - (* First possibility: restriction *) - (* Second possibility: unification *) - (* Third possibility: convertibility *) - let b, ugraph1 = - R.are_convertible - ~subst ~metasenv context t1' t2' ugraph - in - if b then - j+1,subst,metasenv, ugraph1 - else - (try - let subst,metasenv,ugraph2 = - fo_unif_subst - test_equality_only - subst context metasenv t1' t2' ugraph - in - j+1,subst,metasenv,ugraph2 - with - Uncertain _ - | UnificationFailure _ -> -debug_print (lazy ("restringo Meta n." ^ (string_of_int n) ^ "on variable n." ^ (string_of_int j))); - let metasenv, subst = - CicMetaSubst.restrict - subst [(n,j)] metasenv in - j+1,subst,metasenv,ugraph1) - ) (1,subst,metasenv,ugraph) ln lm - with - Exit -> - raise - (UnificationFailure (lazy "1")) - (* - (sprintf - "Error trying to unify %s with %s: the algorithm tried to check whether the two substitutions are convertible; if they are not, it tried to unify the two substitutions. No restriction was attempted." - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2))) *) - | Invalid_argument _ -> - raise - (UnificationFailure (lazy "2"))) - (* - (sprintf - "Error trying to unify %s with %s: the lengths of the two local contexts do not match." - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2)))) *) - in subst,metasenv,ugraph1 - | (C.Meta (n,_), C.Meta (m,_)) when n>m -> - fo_unif_subst test_equality_only subst context metasenv t2 t1 ugraph - | (C.Meta (n,l), t) - | (t, C.Meta (n,l)) -> - let swap = - match t1,t2 with - C.Meta (n,_), C.Meta (m,_) when n < m -> false - | _, C.Meta _ -> false - | _,_ -> true - in - let lower = fun x y -> if swap then y else x in - let upper = fun x y -> if swap then x else y in - let fo_unif_subst_ordered - test_equality_only subst context metasenv m1 m2 ugraph = - fo_unif_subst test_equality_only subst context metasenv - (lower m1 m2) (upper m1 m2) ugraph - in - begin - let subst,metasenv,ugraph1 = - let (_,_,meta_type) = CicUtil.lookup_meta n metasenv in - (try - let tyt,ugraph1 = - type_of_aux' metasenv subst context t ugraph - in - fo_unif_subst - test_equality_only - subst context metasenv tyt (S.subst_meta l meta_type) ugraph1 - with - UnificationFailure _ as e -> raise e - | Uncertain msg -> raise (UnificationFailure msg) - | AssertFailure _ -> - debug_print (lazy "siamo allo huge hack"); - (* TODO huge hack!!!! - * we keep on unifying/refining in the hope that - * the problem will be eventually solved. - * In the meantime we're breaking a big invariant: - * the terms that we are unifying are no longer well - * typed in the current context (in the worst case - * we could even diverge) *) - (subst, metasenv,ugraph)) in - let t',metasenv,subst = - try - CicMetaSubst.delift n subst context metasenv l t - with - (CicMetaSubst.MetaSubstFailure msg)-> - raise (UnificationFailure msg) - | (CicMetaSubst.Uncertain msg) -> raise (Uncertain msg) - in - let t'',ugraph2 = - match t' with - C.Sort (C.Type u) when not test_equality_only -> - let u' = CicUniv.fresh () in - let s = C.Sort (C.Type u') in - let ugraph2 = - CicUniv.add_ge (upper u u') (lower u u') ugraph1 - in - s,ugraph2 - | _ -> t',ugraph1 - in - (* Unifying the types may have already instantiated n. Let's check *) - try - let (_, oldt,_) = CicUtil.lookup_subst n subst in - let lifted_oldt = S.subst_meta l oldt in - fo_unif_subst_ordered - test_equality_only subst context metasenv t lifted_oldt ugraph2 - with - CicUtil.Subst_not_found _ -> - let (_, context, ty) = CicUtil.lookup_meta n metasenv in - let subst = (n, (context, t'',ty)) :: subst in - let metasenv = - List.filter (fun (m,_,_) -> not (n = m)) metasenv in - subst, metasenv, ugraph2 - end - | (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 test_equality_only subst context metasenv - exp_named_subst1 exp_named_subst2 ugraph - else - raise (UnificationFailure (lazy - (sprintf - "Can't unify %s with %s due to different constants" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2)))) - | 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 - test_equality_only - subst context metasenv exp_named_subst1 exp_named_subst2 ugraph - else - raise (UnificationFailure (lazy "4")) - (* (sprintf - "Can't unify %s with %s due to different inductive principles" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2))) *) - | 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 - test_equality_only - subst context metasenv exp_named_subst1 exp_named_subst2 ugraph - else - raise (UnificationFailure (lazy "5")) - (* (sprintf - "Can't unify %s with %s due to different inductive constructors" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2))) *) - | (C.Implicit _, _) | (_, C.Implicit _) -> assert false - | (C.Cast (te,ty), t2) -> fo_unif_subst test_equality_only - subst context metasenv te t2 ugraph - | (t1, C.Cast (te,ty)) -> fo_unif_subst test_equality_only - subst context metasenv t1 te ugraph - | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) -> - let subst',metasenv',ugraph1 = - fo_unif_subst true subst context metasenv s1 s2 ugraph - in - fo_unif_subst test_equality_only - subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1 - | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) -> - let subst',metasenv',ugraph1 = - fo_unif_subst test_equality_only subst context metasenv s1 s2 ugraph - in - fo_unif_subst test_equality_only - subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1 - | (C.LetIn (_,s1,t1), t2) - | (t2, C.LetIn (_,s1,t1)) -> - fo_unif_subst - test_equality_only subst context metasenv t2 (S.subst s1 t1) ugraph - | (C.Appl l1, C.Appl l2) -> - (* andrea: this case should be probably rewritten in the - spirit of deref *) - (match l1,l2 with - | C.Meta (i,_)::args1, C.Meta (j,_)::args2 when i = j -> - (try - List.fold_left2 - (fun (subst,metasenv,ugraph) t1 t2 -> - fo_unif_subst - test_equality_only subst context metasenv t1 t2 ugraph) - (subst,metasenv,ugraph) l1 l2 - with (Invalid_argument msg) -> - raise (UnificationFailure (lazy msg))) - | C.Meta (i,l)::args, _ when not(exists_a_meta args) -> - (* we verify that none of the args is a Meta, - since beta expanding with respoect to a metavariable - makes no sense *) - (* - (try - let (_,t,_) = CicUtil.lookup_subst i subst in - let lifted = S.subst_meta l t in - let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in - fo_unif_subst - test_equality_only - subst context metasenv reduced t2 ugraph - with CicUtil.Subst_not_found _ -> *) - let subst,metasenv,beta_expanded,ugraph1 = - beta_expand_many - test_equality_only metasenv subst context t2 args ugraph - in - fo_unif_subst test_equality_only subst context metasenv - (C.Meta (i,l)) beta_expanded ugraph1 - | _, C.Meta (i,l)::args when not(exists_a_meta args) -> - (* (try - let (_,t,_) = CicUtil.lookup_subst i subst in - let lifted = S.subst_meta l t in - let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in - fo_unif_subst - test_equality_only - subst context metasenv t1 reduced ugraph - with CicUtil.Subst_not_found _ -> *) - let subst,metasenv,beta_expanded,ugraph1 = - beta_expand_many - test_equality_only - metasenv subst context t1 args ugraph - in - fo_unif_subst test_equality_only subst context metasenv - (C.Meta (i,l)) beta_expanded ugraph1 - | _,_ -> - let lr1 = List.rev l1 in - let lr2 = List.rev l2 in - let rec - fo_unif_l test_equality_only subst metasenv (l1,l2) ugraph = - match (l1,l2) with - [],_ - | _,[] -> assert false - | ([h1],[h2]) -> - fo_unif_subst - test_equality_only subst context metasenv h1 h2 ugraph - | ([h],l) - | (l,[h]) -> - fo_unif_subst test_equality_only subst context metasenv - h (C.Appl (List.rev l)) ugraph - | ((h1::l1),(h2::l2)) -> - let subst', metasenv',ugraph1 = - fo_unif_subst - test_equality_only - subst context metasenv h1 h2 ugraph - in - fo_unif_l - test_equality_only subst' metasenv' (l1,l2) ugraph1 - in - (try - fo_unif_l - test_equality_only subst metasenv (lr1, lr2) ugraph - with - | UnificationFailure _ - | Uncertain _ as exn -> - (match l1, l2 with - | (((Cic.Const (uri1, ens1)) as c1) :: tl1), - (((Cic.Const (uri2, ens2)) as c2) :: tl2) when - CoercGraph.is_a_coercion c1 && - CoercGraph.is_a_coercion c2 -> - let body1, attrs1, ugraph = - match CicEnvironment.get_obj ugraph uri1 with - | Cic.Constant (_,Some bo, _, _, attrs),u -> bo,attrs,u - | _ -> assert false - in - let body2, attrs2, ugraph = - match CicEnvironment.get_obj ugraph uri2 with - | Cic.Constant (_,Some bo, _, _, attrs),u -> bo, attrs,u - | _ -> assert false - in - let is_composite1 = - List.exists ((=) (`Class `Coercion)) attrs1 in - let is_composite2 = - List.exists ((=) (`Class `Coercion)) attrs2 in - (match is_composite1, is_composite2 with - | false, false -> raise exn - | true, false -> - let body1 = CicSubstitution.subst_vars ens1 body1 in - let appl = Cic.Appl (body1::tl1) in - let redappl = CicReduction.head_beta_reduce appl in - fo_unif_subst - test_equality_only subst context metasenv - redappl t2 ugraph - | false, true -> - let body2 = CicSubstitution.subst_vars ens2 body2 in - let appl = Cic.Appl (body2::tl2) in - let redappl = CicReduction.head_beta_reduce appl in - fo_unif_subst - test_equality_only subst context metasenv - t1 redappl ugraph - | true, true -> - let body1 = CicSubstitution.subst_vars ens1 body1 in - let appl1 = Cic.Appl (body1::tl1) in - let redappl1 = CicReduction.head_beta_reduce appl1 in - let body2 = CicSubstitution.subst_vars ens2 body2 in - let appl2 = Cic.Appl (body2::tl2) in - let redappl2 = CicReduction.head_beta_reduce appl2 in - fo_unif_subst - test_equality_only subst context metasenv - redappl1 redappl2 ugraph) - | _ -> raise exn))) - | (C.MutCase (_,_,outt1,t1',pl1), C.MutCase (_,_,outt2,t2',pl2))-> - let subst', metasenv',ugraph1 = - fo_unif_subst test_equality_only subst context metasenv outt1 outt2 - ugraph in - let subst'',metasenv'',ugraph2 = - fo_unif_subst test_equality_only subst' context metasenv' t1' t2' - ugraph1 in - (try - List.fold_left2 - (fun (subst,metasenv,ugraph) t1 t2 -> - fo_unif_subst - test_equality_only subst context metasenv t1 t2 ugraph - ) (subst'',metasenv'',ugraph2) pl1 pl2 - with - Invalid_argument _ -> - raise (UnificationFailure (lazy "6.1"))) - (* (sprintf - "Error trying to unify %s with %s: the number of branches is not the same." - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2)))) *) - | (C.Rel _, _) | (_, C.Rel _) -> - if t1 = t2 then - subst, metasenv,ugraph - else - raise (UnificationFailure (lazy - (sprintf - "Can't unify %s with %s because they are not convertible" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2)))) - | (C.Appl (C.Meta(i,l)::args),t2) when not(exists_a_meta args) -> - let subst,metasenv,beta_expanded,ugraph1 = - beta_expand_many - test_equality_only metasenv subst context t2 args ugraph - in - fo_unif_subst test_equality_only subst context metasenv - (C.Meta (i,l)) beta_expanded ugraph1 - | (t1,C.Appl (C.Meta(i,l)::args)) when not(exists_a_meta args) -> - let subst,metasenv,beta_expanded,ugraph1 = - beta_expand_many - test_equality_only metasenv subst context t1 args ugraph - in - fo_unif_subst test_equality_only subst context metasenv - beta_expanded (C.Meta (i,l)) ugraph1 - | (C.Sort _ ,_) | (_, C.Sort _) - | (C.Const _, _) | (_, C.Const _) - | (C.MutInd _, _) | (_, C.MutInd _) - | (C.MutConstruct _, _) | (_, C.MutConstruct _) - | (C.Fix _, _) | (_, C.Fix _) - | (C.CoFix _, _) | (_, C.CoFix _) -> - if t1 = t2 then - subst, metasenv, ugraph - else - let b,ugraph1 = - R.are_convertible ~subst ~metasenv context t1 t2 ugraph - in - if b then - subst, metasenv, ugraph1 - else - raise - (UnificationFailure (lazy (sprintf - "Can't unify %s with %s because they are not convertible" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2)))) - | (C.Prod _, t2) -> - let t2' = R.whd ~subst context t2 in - (match t2' with - C.Prod _ -> - fo_unif_subst test_equality_only - subst context metasenv t1 t2' ugraph - | _ -> raise (UnificationFailure (lazy "8"))) - | (t1, C.Prod _) -> - let t1' = R.whd ~subst context t1 in - (match t1' with - C.Prod _ -> - fo_unif_subst test_equality_only - subst context metasenv t1' t2 ugraph - | _ -> (* raise (UnificationFailure "9")) *) - raise - (UnificationFailure (lazy (sprintf - "Can't unify %s with %s because they are not convertible" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2))))) - | (_,_) -> - raise (UnificationFailure (lazy "10")) - (* (sprintf - "Can't unify %s with %s because they are not convertible" - (CicMetaSubst.ppterm subst t1) - (CicMetaSubst.ppterm subst t2))) *) - -and fo_unif_subst_exp_named_subst test_equality_only subst context metasenv - exp_named_subst1 exp_named_subst2 ugraph -= - try - List.fold_left2 - (fun (subst,metasenv,ugraph) (uri1,t1) (uri2,t2) -> - assert (uri1=uri2) ; - fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph - ) (subst,metasenv,ugraph) exp_named_subst1 exp_named_subst2 - with - Invalid_argument _ -> - let print_ens ens = - String.concat " ; " - (List.map - (fun (uri,t) -> - UriManager.string_of_uri uri ^ " := " ^ (CicMetaSubst.ppterm subst t) - ) ens) - in - raise (UnificationFailure (lazy (sprintf - "Error trying to unify the two explicit named substitutions (local contexts) %s and %s: their lengths is different." (print_ens exp_named_subst1) (print_ens exp_named_subst2)))) - -(* A substitution is a (int * Cic.term) list that associates a *) -(* metavariable i with its body. *) -(* metasenv is of type Cic.metasenv *) -(* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back *) -(* a new substitution which is already unwinded and ready to be applied and *) -(* a new metasenv in which some hypothesis in the contexts of the *) -(* metavariables may have been restricted. *) -let fo_unif metasenv context t1 t2 ugraph = - fo_unif_subst false [] context metasenv t1 t2 ugraph ;; - -let enrich_msg msg subst context metasenv t1 t2 ugraph = - lazy ( - if verbose then - sprintf "[Verbose] Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nand substitution\n%s\nbecause %s" - (CicMetaSubst.ppterm subst t1) - (try - let ty_t1,_ = type_of_aux' metasenv subst context t1 ugraph in - CicPp.ppterm ty_t1 - with - | UnificationFailure s - | Uncertain s - | AssertFailure s -> sprintf "MALFORMED(t1): \n%s\n" (Lazy.force s)) - (CicMetaSubst.ppterm subst t2) - (try - let ty_t2,_ = type_of_aux' metasenv subst context t2 ugraph in - CicPp.ppterm ty_t2 - with - | UnificationFailure s - | Uncertain s - | AssertFailure s -> sprintf "MALFORMED(t2): \n%s\n" (Lazy.force s)) - (CicMetaSubst.ppcontext subst context) - (CicMetaSubst.ppmetasenv subst metasenv) - (CicMetaSubst.ppsubst subst) (Lazy.force msg) - else - sprintf "Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nbecause %s" - (CicMetaSubst.ppterm_in_context subst t1 context) - (try - let ty_t1,_ = type_of_aux' metasenv subst context t1 ugraph in - CicMetaSubst.ppterm_in_context subst ty_t1 context - with - | UnificationFailure s - | Uncertain s - | AssertFailure s -> sprintf "MALFORMED(t1): \n%s\n" (Lazy.force s)) - (CicMetaSubst.ppterm_in_context subst t2 context) - (try - let ty_t2,_ = type_of_aux' metasenv subst context t2 ugraph in - CicMetaSubst.ppterm_in_context subst ty_t2 context - with - | UnificationFailure s - | Uncertain s - | AssertFailure s -> sprintf "MALFORMED(t2): \n%s\n" (Lazy.force s)) - (CicMetaSubst.ppcontext subst context) - (CicMetaSubst.ppmetasenv subst metasenv) - (Lazy.force msg) - ) - -let fo_unif_subst subst context metasenv t1 t2 ugraph = - try - fo_unif_subst false subst context metasenv t1 t2 ugraph - with - | AssertFailure msg -> - raise (AssertFailure (enrich_msg msg subst context metasenv t1 t2 ugraph)) - | UnificationFailure msg -> - raise (UnificationFailure (enrich_msg msg subst context metasenv t1 t2 ugraph)) -;; diff --git a/helm/ocaml/cic_unification/cicUnification.mli b/helm/ocaml/cic_unification/cicUnification.mli deleted file mode 100644 index e1a6c2899..000000000 --- a/helm/ocaml/cic_unification/cicUnification.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* 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 UnificationFailure of string Lazy.t;; -exception Uncertain of string Lazy.t;; -exception AssertFailure of string Lazy.t;; - -(* fo_unif metasenv context t1 t2 *) -(* 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 -> CicUniv.universe_graph -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph - -(* 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 : - Cic.substitution -> Cic.context -> Cic.metasenv -> - Cic.term -> Cic.term -> CicUniv.universe_graph -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph - diff --git a/helm/ocaml/content_pres/.depend b/helm/ocaml/content_pres/.depend deleted file mode 100644 index 60e25ecd8..000000000 --- a/helm/ocaml/content_pres/.depend +++ /dev/null @@ -1,36 +0,0 @@ -cicNotationPres.cmi: mpresentation.cmi box.cmi -boxPp.cmi: cicNotationPres.cmi -content2pres.cmi: cicNotationPres.cmi -sequent2pres.cmi: cicNotationPres.cmi -renderingAttrs.cmo: renderingAttrs.cmi -renderingAttrs.cmx: renderingAttrs.cmi -cicNotationLexer.cmo: cicNotationLexer.cmi -cicNotationLexer.cmx: cicNotationLexer.cmi -cicNotationParser.cmo: cicNotationLexer.cmi cicNotationParser.cmi -cicNotationParser.cmx: cicNotationLexer.cmx cicNotationParser.cmi -mpresentation.cmo: mpresentation.cmi -mpresentation.cmx: mpresentation.cmi -box.cmo: renderingAttrs.cmi box.cmi -box.cmx: renderingAttrs.cmx box.cmi -content2presMatcher.cmo: content2presMatcher.cmi -content2presMatcher.cmx: content2presMatcher.cmi -termContentPres.cmo: renderingAttrs.cmi content2presMatcher.cmi \ - termContentPres.cmi -termContentPres.cmx: renderingAttrs.cmx content2presMatcher.cmx \ - termContentPres.cmi -cicNotationPres.cmo: renderingAttrs.cmi mpresentation.cmi box.cmi \ - cicNotationPres.cmi -cicNotationPres.cmx: renderingAttrs.cmx mpresentation.cmx box.cmx \ - cicNotationPres.cmi -boxPp.cmo: renderingAttrs.cmi mpresentation.cmi cicNotationPres.cmi box.cmi \ - boxPp.cmi -boxPp.cmx: renderingAttrs.cmx mpresentation.cmx cicNotationPres.cmx box.cmx \ - boxPp.cmi -content2pres.cmo: termContentPres.cmi renderingAttrs.cmi mpresentation.cmi \ - cicNotationPres.cmi box.cmi content2pres.cmi -content2pres.cmx: termContentPres.cmx renderingAttrs.cmx mpresentation.cmx \ - cicNotationPres.cmx box.cmx content2pres.cmi -sequent2pres.cmo: termContentPres.cmi mpresentation.cmi cicNotationPres.cmi \ - box.cmi sequent2pres.cmi -sequent2pres.cmx: termContentPres.cmx mpresentation.cmx cicNotationPres.cmx \ - box.cmx sequent2pres.cmi diff --git a/helm/ocaml/content_pres/Makefile b/helm/ocaml/content_pres/Makefile deleted file mode 100644 index 0cd8b4226..000000000 --- a/helm/ocaml/content_pres/Makefile +++ /dev/null @@ -1,60 +0,0 @@ -PACKAGE = content_pres -PREDICATES = - -INTERFACE_FILES = \ - renderingAttrs.mli \ - cicNotationLexer.mli \ - cicNotationParser.mli \ - mpresentation.mli \ - box.mli \ - content2presMatcher.mli \ - termContentPres.mli \ - cicNotationPres.mli \ - boxPp.mli \ - content2pres.mli \ - sequent2pres.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - $(INTERFACE_FILES:%.mli=%.ml) - -cicNotationPres.cmi: OCAMLOPTIONS += -rectypes -cicNotationPres.cmo: OCAMLOPTIONS += -rectypes -cicNotationPres.cmx: OCAMLOPTIONS += -rectypes - -all: test_lexer -clean: clean_tests - -LOCAL_LINKOPTS = -package helm-content_pres -linkpkg -test: test_lexer -test_lexer: test_lexer.ml $(PACKAGE).cma - @echo " OCAMLC $<" - @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< - -clean_tests: - rm -f test_lexer{,.opt} - -cicNotationLexer.cmo: OCAMLC = $(OCAMLC_P4) -cicNotationParser.cmo: OCAMLC = $(OCAMLC_P4) -cicNotationLexer.cmx: OCAMLOPT = $(OCAMLOPT_P4) -cicNotationParser.cmx: OCAMLOPT = $(OCAMLOPT_P4) -cicNotationLexer.ml.annot: OCAMLC = $(OCAMLC_P4) -cicNotationParser.ml.annot: OCAMLC = $(OCAMLC_P4) - -include ../../Makefile.defs -include ../Makefile.common - -# cross compatibility among ocaml 3.09 and ocaml 3.08, to be removed as -# soon as we have ocaml 3.09 everywhere and "loc" occurrences are replaced by -# "_loc" occurrences -UTF8DIR := $(shell $(OCAMLFIND) query helm-utf8_macros) -ULEXDIR := $(shell $(OCAMLFIND) query ulex) -MY_SYNTAXOPTIONS = -pp "camlp4o -I $(UTF8DIR) -I $(ULEXDIR) pa_extend.cmo pa_ulex.cma pa_unicode_macro.cma -loc loc" -cicNotationLexer.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -cicNotationParser.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -cicNotationLexer.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -cicNotationParser.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -cicNotationLexer.ml.annot: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -cicNotationParser.ml.annot: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -depend: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -# - diff --git a/helm/ocaml/content_pres/box.ml b/helm/ocaml/content_pres/box.ml deleted file mode 100644 index 7c5069262..000000000 --- a/helm/ocaml/content_pres/box.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* Copyright (C) 2000-2005, 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 *) -(* *) -(* Andrea Asperti *) -(* 13/2/2004 *) -(* *) -(*************************************************************************) - -(* $Id$ *) - -type - 'expr box = - Text of attr * string - | Space of attr - | Ink of attr - | H of attr * ('expr box) list - | V of attr * ('expr box) list - | HV of attr * ('expr box) list - | HOV of attr * ('expr box) list - | Object of attr * 'expr - | Action of attr * ('expr box) list - -and attr = (string option * string * string) list - -let smallskip = Space([None,"width","0.5em"]);; -let skip = Space([None,"width","1em"]);; - -let indent t = H([],[skip;t]);; - -(* BoxML prefix *) -let prefix = "b";; - -let tag_of_box = function - | H _ -> "h" - | V _ -> "v" - | HV _ -> "hv" - | HOV _ -> "hov" - | _ -> assert false - -let box2xml ~obj2xml box = - let rec aux = - let module X = Xml in - function - Text (attr,s) -> X.xml_nempty ~prefix "text" attr (X.xml_cdata s) - | Space attr -> X.xml_empty ~prefix "space" attr - | Ink attr -> X.xml_empty ~prefix "ink" attr - | H (attr,l) - | V (attr,l) - | HV (attr,l) - | HOV (attr,l) as box -> - X.xml_nempty ~prefix (tag_of_box box) attr - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) - >] - | Object (attr,m) -> - X.xml_nempty ~prefix "obj" attr [< obj2xml m >] - | Action (attr,l) -> - X.xml_nempty ~prefix "action" attr - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >] - in - aux box -;; - -let rec map f = function - | (Text _) as box -> box - | (Space _) as box -> box - | (Ink _) as box -> box - | H (attr, l) -> H (attr, List.map (map f) l) - | V (attr, l) -> V (attr, List.map (map f) l) - | HV (attr, l) -> HV (attr, List.map (map f) l) - | HOV (attr, l) -> HOV (attr, List.map (map f) l) - | Action (attr, l) -> Action (attr, List.map (map f) l) - | Object (attr, obj) -> Object (attr, f obj) -;; - -(* -let document_of_box ~obj2xml pres = - [< Xml.xml_cdata "\n" ; - Xml.xml_cdata "\n"; - Xml.xml_nempty ~prefix "box" - [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ; - Some "xmlns","b","http://helm.cs.unibo.it/2003/BoxML" ; - Some "xmlns","helm","http://www.cs.unibo.it/helm" ; - Some "xmlns","xlink","http://www.w3.org/1999/xlink" - ] (print_box pres) - >] -*) - -let b_h a b = H(a,b) -let b_v a b = V(a,b) -let b_hv a b = HV(a,b) -let b_hov a b = HOV(a,b) -let b_text a b = Text(a,b) -let b_object b = Object ([],b) -let b_indent = indent -let b_space = Space [None, "width", "0.5em"] -let b_kw = b_text (RenderingAttrs.object_keyword_attributes `BoxML) -let b_toggle items = Action ([ None, "type", "toggle"], items) - -let pp_attr attr = - let pp (ns, n, v) = - Printf.sprintf "%s%s=%s" (match ns with None -> "" | Some s -> s ^ ":") n v - in - String.concat " " (List.map pp attr) - -let get_attr = function - | Text (attr, _) - | Space attr - | Ink attr - | H (attr, _) - | V (attr, _) - | HV (attr, _) - | HOV (attr, _) - | Object (attr, _) - | Action (attr, _) -> - attr - -let set_attr attr = function - | Text (_, x) -> Text (attr, x) - | Space _ -> Space attr - | Ink _ -> Ink attr - | H (_, x) -> H (attr, x) - | V (_, x) -> V (attr, x) - | HV (_, x) -> HV (attr, x) - | HOV (_, x) -> HOV (attr, x) - | Object (_, x) -> Object (attr, x) - | Action (_, x) -> Action (attr, x) - diff --git a/helm/ocaml/content_pres/box.mli b/helm/ocaml/content_pres/box.mli deleted file mode 100644 index d2ca17bdd..000000000 --- a/helm/ocaml/content_pres/box.mli +++ /dev/null @@ -1,79 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 13/2/2004 *) -(* *) -(*************************************************************************) - -type - 'expr box = - Text of attr * string - | Space of attr - | Ink of attr - | H of attr * ('expr box) list - | V of attr * ('expr box) list - | HV of attr * ('expr box) list - | HOV of attr * ('expr box) list - | Object of attr * 'expr - | Action of attr * ('expr box) list - -and attr = (string option * string * string) list - -val get_attr: 'a box -> attr -val set_attr: attr -> 'a box -> 'a box - -val smallskip : 'expr box -val skip: 'expr box -val indent : 'expr box -> 'expr box - -val box2xml: - obj2xml:('a -> Xml.token Stream.t) -> 'a box -> - Xml.token Stream.t - -val map: ('a -> 'b) -> 'a box -> 'b box - -(* -val document_of_box : - ~obj2xml:('a -> Xml.token Stream.t) -> 'a box -> Xml.token Stream.t -*) - -val b_h: attr -> 'expr box list -> 'expr box -val b_v: attr -> 'expr box list -> 'expr box -val b_hv: attr -> 'expr box list -> 'expr box (** default indent and spacing *) -val b_hov: attr -> 'expr box list -> 'expr box (** default indent and spacing *) -val b_text: attr -> string -> 'expr box -val b_object: 'expr -> 'expr box -val b_indent: 'expr box -> 'expr box -val b_space: 'expr box -val b_kw: string -> 'expr box -val b_toggle: 'expr box list -> 'expr box (** action which toggle among items *) - -val pp_attr: attr -> string - diff --git a/helm/ocaml/content_pres/boxPp.ml b/helm/ocaml/content_pres/boxPp.ml deleted file mode 100644 index 7a2fa9912..000000000 --- a/helm/ocaml/content_pres/boxPp.ml +++ /dev/null @@ -1,241 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module Pres = Mpresentation - -(** {2 Pretty printing from BoxML to strings} *) - -let string_space = " " -let string_space_len = String.length string_space -let string_indent = string_space -let string_indent_len = String.length string_indent -let string_ink = "##" -let string_ink_len = String.length string_ink - -let contains_attrs contained container = - List.for_all (fun attr -> List.mem attr container) contained - -let want_indent = contains_attrs (RenderingAttrs.indent_attributes `BoxML) -let want_spacing = contains_attrs (RenderingAttrs.spacing_attributes `BoxML) - -let indent_string s = string_indent ^ s -let indent_children (size, children) = - let children' = List.map indent_string children in - size + string_space_len, children' - -let choose_rendering size (best, other) = - let best_size, _ = best in - if size >= best_size then best else other - -let merge_columns sep cols = - let sep_len = String.length sep in - let indent = ref 0 in - let res_rows = ref [] in - let add_row ~continue row = - match !res_rows with - | last :: prev when continue -> - res_rows := (String.concat sep [last; row]) :: prev; - indent := !indent + String.length last + sep_len - | _ -> res_rows := (String.make !indent ' ' ^ row) :: !res_rows; - in - List.iter - (fun rows -> - match rows with - | hd :: tl -> - add_row ~continue:true hd; - List.iter (add_row ~continue:false) tl - | [] -> ()) - cols; - List.rev !res_rows - -let max_len = - List.fold_left (fun max_size s -> max (String.length s) max_size) 0 - -let render_row available_space spacing children = - let spacing_bonus = if spacing then string_space_len else 0 in - let rem_space = ref available_space in - let renderings = ref [] in - List.iter - (fun f -> - let occupied_space, rendering = f !rem_space in - renderings := rendering :: !renderings; - rem_space := !rem_space - (occupied_space + spacing_bonus)) - children; - let sep = if spacing then string_space else "" in - let rendering = merge_columns sep (List.rev !renderings) in - max_len rendering, rendering - -let fixed_rendering s = - let s_len = String.length s in - (fun _ -> s_len, [s]) - -let render_to_strings size markup = - let max_size = max_int in - let rec aux_box = - function - | Box.Text (_, t) -> fixed_rendering t - | Box.Space _ -> fixed_rendering string_space - | Box.Ink _ -> fixed_rendering string_ink - | Box.Action (_, []) -> assert false - | Box.Action (_, hd :: _) -> aux_box hd - | Box.Object (_, o) -> aux_mpres o - | Box.H (attrs, children) -> - let spacing = want_spacing attrs in - let children' = List.map aux_box children in - (fun size -> render_row size spacing children') - | Box.HV (attrs, children) -> - let spacing = want_spacing attrs in - let children' = List.map aux_box children in - (fun size -> - let (size', renderings) as res = - render_row max_size spacing children' - in - if size' <= size then (* children fit in a row *) - res - else (* break needed, re-render using a Box.V *) - aux_box (Box.V (attrs, children)) size) - | Box.V (attrs, []) -> assert false - | Box.V (attrs, [child]) -> aux_box child - | Box.V (attrs, hd :: tl) -> - let indent = want_indent attrs in - let hd_f = aux_box hd in - let tl_fs = List.map aux_box tl in - (fun size -> - let _, hd_rendering = hd_f size in - let children_size = - max 0 (if indent then size - string_indent_len else size) - in - let tl_renderings = - List.map - (fun f -> -(* let indent_header = if indent then string_indent else "" in *) - snd (indent_children (f children_size))) - tl_fs - in - let rows = hd_rendering @ List.concat tl_renderings in - max_len rows, rows) - | Box.HOV (attrs, []) -> assert false - | Box.HOV (attrs, [child]) -> aux_box child - | Box.HOV (attrs, children) -> - let spacing = want_spacing attrs in - let indent = want_indent attrs in - let spacing_bonus = if spacing then string_space_len else 0 in - let indent_bonus = if indent then string_indent_len else 0 in - let sep = if spacing then string_space else "" in - let fs = List.map aux_box children in - (fun size -> - let rows = ref [] in - let renderings = ref [] in - let rem_space = ref size in - let first_row = ref true in - let use_rendering (space, rendering) = - let use_indent = !renderings = [] && not !first_row in - let rendering' = - if use_indent then List.map indent_string rendering - else rendering - in - renderings := rendering' :: !renderings; - let bonus = if use_indent then indent_bonus else spacing_bonus in - rem_space := !rem_space - (space + bonus) - in - let end_cluster () = - let new_rows = merge_columns sep (List.rev !renderings) in - rows := List.rev_append new_rows !rows; - rem_space := size - indent_bonus; - renderings := []; - first_row := false - in - List.iter - (fun f -> - let (best_space, _) as best = f max_size in - if best_space <= !rem_space then - use_rendering best - else begin - end_cluster (); - if best_space <= !rem_space then use_rendering best - else use_rendering (f size) - end) - fs; - if !renderings <> [] then end_cluster (); - max_len !rows, List.rev !rows) - and aux_mpres = - let text s = Pres.Mtext ([], s) in - let mrow c = Pres.Mrow ([], c) in - function - | Pres.Mi (_, s) - | Pres.Mn (_, s) - | Pres.Mtext (_, s) - | Pres.Ms (_, s) - | Pres.Mgliph (_, s) -> fixed_rendering s - | Pres.Mo (_, s) -> - let s = - if String.length s > 1 then - (* heuristic to guess which operators need to be expanded in their - * TeX like format *) - Utf8Macro.tex_of_unicode s ^ " " - else s - in - fixed_rendering s - | Pres.Mspace _ -> fixed_rendering string_space - | Pres.Mrow (attrs, children) -> - let children' = List.map aux_mpres children in - (fun size -> render_row size false children') - | Pres.Mfrac (_, m, n) -> - aux_mpres (mrow [ text "\\frac("; text ")"; text "("; n; text ")" ]) - | Pres.Msqrt (_, m) -> aux_mpres (mrow [ text "\\sqrt("; m; text ")" ]) - | Pres.Mroot (_, r, i) -> - aux_mpres (mrow [ - text "\\root("; i; text ")"; text "\\of("; r; text ")" ]) - | Pres.Mstyle (_, m) - | Pres.Merror (_, m) - | Pres.Mpadded (_, m) - | Pres.Mphantom (_, m) - | Pres.Menclose (_, m) -> aux_mpres m - | Pres.Mfenced (_, children) -> aux_mpres (mrow children) - | Pres.Maction (_, []) -> assert false - | Pres.Msub (_, m, n) -> - aux_mpres (mrow [ text "("; m; text ")\\sub("; n; text ")" ]) - | Pres.Msup (_, m, n) -> - aux_mpres (mrow [ text "("; m; text ")\\sup("; n; text ")" ]) - | Pres.Munder (_, m, n) -> - aux_mpres (mrow [ text "("; m; text ")\\below("; n; text ")" ]) - | Pres.Mover (_, m, n) -> - aux_mpres (mrow [ text "("; m; text ")\\above("; n; text ")" ]) - | Pres.Msubsup _ - | Pres.Munderover _ - | Pres.Mtable _ -> - prerr_endline - "MathML presentation element not yet available in concrete syntax"; - assert false - | Pres.Maction (_, hd :: _) -> aux_mpres hd - | Pres.Mobject (_, o) -> aux_box (o: CicNotationPres.boxml_markup) - in - snd (aux_mpres markup size) - -let render_to_string size markup = - String.concat "\n" (render_to_strings size markup) - diff --git a/helm/ocaml/content_pres/boxPp.mli b/helm/ocaml/content_pres/boxPp.mli deleted file mode 100644 index 6b7c3cec8..000000000 --- a/helm/ocaml/content_pres/boxPp.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - - (** @return rows list of rows *) -val render_to_strings: int -> CicNotationPres.markup -> string list - - (** helper function - * @return s, concatenation of the return value of render_to_strings above - * with newlines as separators *) -val render_to_string: int -> CicNotationPres.markup -> string - diff --git a/helm/ocaml/content_pres/cicNotationLexer.ml b/helm/ocaml/content_pres/cicNotationLexer.ml deleted file mode 100644 index 8848a3ce5..000000000 --- a/helm/ocaml/content_pres/cicNotationLexer.ml +++ /dev/null @@ -1,353 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -exception Error of int * int * string - -let regexp number = xml_digit+ - - (* ZACK: breaks unicode's binder followed by an ascii letter without blank *) -(* let regexp ident_letter = xml_letter *) - -let regexp ident_letter = [ 'a' - 'z' 'A' - 'Z' ] - - (* must be in sync with "is_ligature_char" below *) -let regexp ligature_char = [ "'`~!?@*()[]<>-+=|:;.,/\"" ] -let regexp ligature = ligature_char ligature_char+ - -let is_ligature_char = - (* must be in sync with "regexp ligature_char" above *) - let chars = "'`~!?@*()[]<>-+=|:;.,/\"" in - (fun char -> - (try - ignore (String.index chars char); - true - with Not_found -> false)) - -let regexp ident_decoration = '\'' | '?' | '`' -let regexp ident_cont = ident_letter | xml_digit | '_' -let regexp ident = ident_letter ident_cont* ident_decoration* - -let regexp tex_token = '\\' ident - -let regexp delim_begin = "\\[" -let regexp delim_end = "\\]" - -let regexp qkeyword = "'" ident "'" - -let regexp implicit = '?' -let regexp placeholder = '%' -let regexp meta = implicit number - -let regexp csymbol = '\'' ident - -let regexp begin_group = "@{" | "${" -let regexp end_group = '}' -let regexp wildcard = "$_" -let regexp ast_ident = "@" ident -let regexp ast_csymbol = "@" csymbol -let regexp meta_ident = "$" ident -let regexp meta_anonymous = "$_" -let regexp qstring = '"' [^ '"']* '"' - -let regexp begincomment = "(**" xml_blank -let regexp beginnote = "(*" -let regexp endcomment = "*)" -(* let regexp comment_char = [^'*'] | '*'[^')'] -let regexp note = "|+" ([^'*'] | "**") comment_char* "+|" *) - -let level1_layouts = - [ "sub"; "sup"; - "below"; "above"; - "over"; "atop"; "frac"; - "sqrt"; "root" - ] - -let level1_keywords = - [ "hbox"; "hvbox"; "hovbox"; "vbox"; - "break"; - "list0"; "list1"; "sep"; - "opt"; - "term"; "ident"; "number" - ] @ level1_layouts - -let level2_meta_keywords = - [ "if"; "then"; "else"; - "fold"; "left"; "right"; "rec"; - "fail"; - "default"; - "anonymous"; "ident"; "number"; "term"; "fresh" - ] - - (* (string, unit) Hashtbl.t, to exploit multiple bindings *) -let level2_ast_keywords = Hashtbl.create 23 -let _ = - List.iter (fun k -> Hashtbl.add level2_ast_keywords k ()) - [ "CProp"; "Prop"; "Type"; "Set"; "let"; "rec"; "corec"; "match"; - "with"; "in"; "and"; "to"; "as"; "on"; "return" ] - -let add_level2_ast_keyword k = Hashtbl.add level2_ast_keywords k () -let remove_level2_ast_keyword k = Hashtbl.remove level2_ast_keywords k - - (* (string, int) Hashtbl.t, with multiple bindings. - * int is the unicode codepoint *) -let ligatures = Hashtbl.create 23 -let _ = - List.iter - (fun (ligature, symbol) -> Hashtbl.add ligatures ligature symbol) - [ ("->", <:unicode>); ("=>", <:unicode>); - ("<=", <:unicode>); (">=", <:unicode>); - ("<>", <:unicode>); (":=", <:unicode>); - ] - -let regexp uri_step = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '_' '-' ]+ - -let regexp uri = - ("cic:/" | "theory:/") (* schema *) -(* ident ('/' ident)* |+ path +| *) - uri_step ('/' uri_step)* (* path *) - ('.' ident)+ (* ext *) - ("#xpointer(" number ('/' number)+ ")")? (* xpointer *) - -let error lexbuf msg = - let begin_cnum, end_cnum = Ulexing.loc lexbuf in - raise (Error (begin_cnum, end_cnum, msg)) -let error_at_end lexbuf msg = - let begin_cnum, end_cnum = Ulexing.loc lexbuf in - raise (Error (begin_cnum, end_cnum, msg)) - -let return_with_loc token begin_cnum end_cnum = - (* TODO handle line/column numbers *) - let flocation_begin = - { Lexing.pos_fname = ""; - Lexing.pos_lnum = -1; Lexing.pos_bol = -1; - Lexing.pos_cnum = begin_cnum } - in - let flocation_end = { flocation_begin with Lexing.pos_cnum = end_cnum } in - (token, (flocation_begin, flocation_end)) - -let return lexbuf token = - let begin_cnum, end_cnum = Ulexing.loc lexbuf in - return_with_loc token begin_cnum end_cnum - -let return_lexeme lexbuf name = return lexbuf (name, Ulexing.utf8_lexeme lexbuf) - -let return_symbol lexbuf s = return lexbuf ("SYMBOL", s) -let return_eoi lexbuf = return lexbuf ("EOI", "") - -let remove_quotes s = String.sub s 1 (String.length s - 2) - -let mk_lexer token = - let tok_func stream = -(* let lexbuf = Ulexing.from_utf8_stream stream in *) -(** XXX Obj.magic rationale. - * The problem. - * camlp4 constraints the tok_func field of Token.glexer to have type: - * Stream.t char -> (Stream.t 'te * flocation_function) - * In order to use ulex we have (in theory) to instantiate a new lexbuf each - * time a char Stream.t is passed, destroying the previous lexbuf which may - * have consumed a character from the old stream which is lost forever :-( - * The "solution". - * Instead of passing to camlp4 a char Stream.t we pass a lexbuf, casting it to - * char Stream.t with Obj.magic where needed. - *) - let lexbuf = Obj.magic stream in - Token.make_stream_and_flocation - (fun () -> - try - token lexbuf - with - | Ulexing.Error -> error_at_end lexbuf "Unexpected character" - | Ulexing.InvalidCodepoint p -> - error_at_end lexbuf (sprintf "Invalid code point: %d" p)) - in - { - Token.tok_func = tok_func; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text; - Token.tok_comm = None; - } - -let expand_macro lexbuf = - let macro = - Ulexing.utf8_sub_lexeme lexbuf 1 (Ulexing.lexeme_length lexbuf - 1) - in - try - ("SYMBOL", Utf8Macro.expand macro) - with Utf8Macro.Macro_not_found _ -> "SYMBOL", Ulexing.utf8_lexeme lexbuf - -let remove_quotes s = String.sub s 1 (String.length s - 2) -let remove_left_quote s = String.sub s 1 (String.length s - 1) - -let rec level2_pattern_token_group counter buffer = - lexer - | end_group -> - if (counter > 0) then - Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ; - snd (Ulexing.loc lexbuf) - | begin_group -> - Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ; - ignore (level2_pattern_token_group (counter + 1) buffer lexbuf) ; - level2_pattern_token_group counter buffer lexbuf - | _ -> - Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ; - level2_pattern_token_group counter buffer lexbuf - -let read_unparsed_group token_name lexbuf = - let buffer = Buffer.create 16 in - let begin_cnum, _ = Ulexing.loc lexbuf in - let end_cnum = level2_pattern_token_group 0 buffer lexbuf in - return_with_loc (token_name, Buffer.contents buffer) begin_cnum end_cnum - -let rec level2_meta_token = - lexer - | xml_blank+ -> level2_meta_token lexbuf - | ident -> - let s = Ulexing.utf8_lexeme lexbuf in - begin - if List.mem s level2_meta_keywords then - return lexbuf ("", s) - else - return lexbuf ("IDENT", s) - end - | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf - | ast_ident -> - return lexbuf ("UNPARSED_AST", - remove_left_quote (Ulexing.utf8_lexeme lexbuf)) - | ast_csymbol -> - return lexbuf ("UNPARSED_AST", - remove_left_quote (Ulexing.utf8_lexeme lexbuf)) - | eof -> return_eoi lexbuf - -let rec comment_token acc depth = - lexer - | beginnote -> - let acc = acc ^ Ulexing.utf8_lexeme lexbuf in - comment_token acc (depth + 1) lexbuf - | endcomment -> - let acc = acc ^ Ulexing.utf8_lexeme lexbuf in - if depth = 0 - then acc - else comment_token acc (depth - 1) lexbuf - | _ -> - let acc = acc ^ Ulexing.utf8_lexeme lexbuf in - comment_token acc depth lexbuf - - (** @param k continuation to be invoked when no ligature has been found *) -let rec ligatures_token k = - lexer - | ligature -> - let lexeme = Ulexing.utf8_lexeme lexbuf in - (match List.rev (Hashtbl.find_all ligatures lexeme) with - | [] -> (* ligature not found, rollback and try default lexer *) - Ulexing.rollback lexbuf; - k lexbuf - | default_lig :: _ -> (* ligatures found, use the default one *) - return_symbol lexbuf default_lig) - | eof -> return_eoi lexbuf - | _ -> (* not a ligature, rollback and try default lexer *) - Ulexing.rollback lexbuf; - k lexbuf - -and level2_ast_token = - lexer - | xml_blank+ -> ligatures_token level2_ast_token lexbuf - | meta -> return lexbuf ("META", Ulexing.utf8_lexeme lexbuf) - | implicit -> return lexbuf ("IMPLICIT", "") - | placeholder -> return lexbuf ("PLACEHOLDER", "") - | ident -> - let lexeme = Ulexing.utf8_lexeme lexbuf in - if Hashtbl.mem level2_ast_keywords lexeme then - return lexbuf ("", lexeme) - else - return lexbuf ("IDENT", lexeme) - | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf) - | tex_token -> return lexbuf (expand_macro lexbuf) - | uri -> return lexbuf ("URI", Ulexing.utf8_lexeme lexbuf) - | qstring -> - return lexbuf ("QSTRING", remove_quotes (Ulexing.utf8_lexeme lexbuf)) - | csymbol -> - return lexbuf ("CSYMBOL", remove_left_quote (Ulexing.utf8_lexeme lexbuf)) - | "${" -> read_unparsed_group "UNPARSED_META" lexbuf - | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf - | '(' -> return lexbuf ("LPAREN", "") - | ')' -> return lexbuf ("RPAREN", "") - | meta_ident -> - return lexbuf ("UNPARSED_META", - remove_left_quote (Ulexing.utf8_lexeme lexbuf)) - | meta_anonymous -> return lexbuf ("UNPARSED_META", "anonymous") - | beginnote -> - let _comment = comment_token (Ulexing.utf8_lexeme lexbuf) 0 lexbuf in -(* let comment = - Ulexing.utf8_sub_lexeme lexbuf 2 (Ulexing.lexeme_length lexbuf - 4) - in - return lexbuf ("NOTE", comment) *) - ligatures_token level2_ast_token lexbuf - | begincomment -> return lexbuf ("BEGINCOMMENT","") - | endcomment -> return lexbuf ("ENDCOMMENT","") - | eof -> return_eoi lexbuf - | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf) - -and level1_pattern_token = - lexer - | xml_blank+ -> ligatures_token level1_pattern_token lexbuf - | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf) - | ident -> - let s = Ulexing.utf8_lexeme lexbuf in - begin - if List.mem s level1_keywords then - return lexbuf ("", s) - else - return lexbuf ("IDENT", s) - end - | tex_token -> return lexbuf (expand_macro lexbuf) - | qkeyword -> - return lexbuf ("QKEYWORD", remove_quotes (Ulexing.utf8_lexeme lexbuf)) - | '(' -> return lexbuf ("LPAREN", "") - | ')' -> return lexbuf ("RPAREN", "") - | eof -> return_eoi lexbuf - | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf) - -let level1_pattern_token = ligatures_token level1_pattern_token -let level2_ast_token = ligatures_token level2_ast_token - -(* API implementation *) - -let level1_pattern_lexer = mk_lexer level1_pattern_token -let level2_ast_lexer = mk_lexer level2_ast_token -let level2_meta_lexer = mk_lexer level2_meta_token - -let lookup_ligatures lexeme = - try - if lexeme.[0] = '\\' - then [ Utf8Macro.expand (String.sub lexeme 1 (String.length lexeme - 1)) ] - else List.rev (Hashtbl.find_all ligatures lexeme) - with Invalid_argument _ | Utf8Macro.Macro_not_found _ -> [] - diff --git a/helm/ocaml/content_pres/cicNotationLexer.mli b/helm/ocaml/content_pres/cicNotationLexer.mli deleted file mode 100644 index cd5f0876d..000000000 --- a/helm/ocaml/content_pres/cicNotationLexer.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - - (** begin of error offset (counted in unicode codepoint) - * end of error offset (counted as above) - * error message *) -exception Error of int * int * string - - (** XXX ZACK DEFCON 4 BEGIN: never use the tok_func field of the glexers below - * passing values of type char Stream.t, they should be in fact Ulexing.lexbuf - * casted with Obj.magic :-/ Read the comment in the .ml for the rationale *) - -val level1_pattern_lexer: (string * string) Token.glexer -val level2_ast_lexer: (string * string) Token.glexer -val level2_meta_lexer: (string * string) Token.glexer - - (** XXX ZACK DEFCON 4 END *) - -val add_level2_ast_keyword: string -> unit (** non idempotent *) -val remove_level2_ast_keyword: string -> unit (** non idempotent *) - -(** {2 Ligatures} *) - -val is_ligature_char: char -> bool -val lookup_ligatures: string -> string list - diff --git a/helm/ocaml/content_pres/cicNotationParser.ml b/helm/ocaml/content_pres/cicNotationParser.ml deleted file mode 100644 index 5750ad816..000000000 --- a/helm/ocaml/content_pres/cicNotationParser.ml +++ /dev/null @@ -1,647 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt -module Env = CicNotationEnv - -exception Parse_error of string -exception Level_not_found of int - -let level1_pattern_grammar = - Grammar.gcreate CicNotationLexer.level1_pattern_lexer -let level2_ast_grammar = Grammar.gcreate CicNotationLexer.level2_ast_lexer -let level2_meta_grammar = Grammar.gcreate CicNotationLexer.level2_meta_lexer - -let min_precedence = 0 -let max_precedence = 100 - -let level1_pattern = - Grammar.Entry.create level1_pattern_grammar "level1_pattern" -let level2_ast = Grammar.Entry.create level2_ast_grammar "level2_ast" -let term = Grammar.Entry.create level2_ast_grammar "term" -let let_defs = Grammar.Entry.create level2_ast_grammar "let_defs" -let level2_meta = Grammar.Entry.create level2_meta_grammar "level2_meta" - -let int_of_string s = - try - Pervasives.int_of_string s - with Failure _ -> - failwith (sprintf "Lexer failure: string_of_int \"%s\" failed" s) - -(** {2 Grammar extension} *) - -let gram_symbol s = Gramext.Stoken ("SYMBOL", s) -let gram_ident s = Gramext.Stoken ("IDENT", s) -let gram_number s = Gramext.Stoken ("NUMBER", s) -let gram_keyword s = Gramext.Stoken ("", s) -let gram_term = Gramext.Sself - -let gram_of_literal = - function - | `Symbol s -> gram_symbol s - | `Keyword s -> gram_keyword s - | `Number s -> gram_number s - -type binding = - | NoBinding - | Binding of string * Env.value_type - | Env of (string * Env.value_type) list - -let make_action action bindings = - let rec aux (vl : CicNotationEnv.t) = - function - [] -> Gramext.action (fun (loc: Ast.location) -> action vl loc) - | NoBinding :: tl -> Gramext.action (fun _ -> aux vl tl) - (* LUCA: DEFCON 3 BEGIN *) - | Binding (name, Env.TermType) :: tl -> - Gramext.action - (fun (v:Ast.term) -> - aux ((name, (Env.TermType, Env.TermValue v))::vl) tl) - | Binding (name, Env.StringType) :: tl -> - Gramext.action - (fun (v:string) -> - aux ((name, (Env.StringType, Env.StringValue v)) :: vl) tl) - | Binding (name, Env.NumType) :: tl -> - Gramext.action - (fun (v:string) -> - aux ((name, (Env.NumType, Env.NumValue v)) :: vl) tl) - | Binding (name, Env.OptType t) :: tl -> - Gramext.action - (fun (v:'a option) -> - aux ((name, (Env.OptType t, Env.OptValue v)) :: vl) tl) - | Binding (name, Env.ListType t) :: tl -> - Gramext.action - (fun (v:'a list) -> - aux ((name, (Env.ListType t, Env.ListValue v)) :: vl) tl) - | Env _ :: tl -> - Gramext.action (fun (v:CicNotationEnv.t) -> aux (v @ vl) tl) - (* LUCA: DEFCON 3 END *) - in - aux [] (List.rev bindings) - -let flatten_opt = - let rec aux acc = - function - [] -> List.rev acc - | NoBinding :: tl -> aux acc tl - | Env names :: tl -> aux (List.rev names @ acc) tl - | Binding (name, ty) :: tl -> aux ((name, ty) :: acc) tl - in - aux [] - - (* given a level 1 pattern computes the new RHS of "term" grammar entry *) -let extract_term_production pattern = - let rec aux = function - | Ast.AttributedTerm (_, t) -> aux t - | Ast.Literal l -> aux_literal l - | Ast.Layout l -> aux_layout l - | Ast.Magic m -> aux_magic m - | Ast.Variable v -> aux_variable v - | t -> - prerr_endline (CicNotationPp.pp_term t); - assert false - and aux_literal = - function - | `Symbol s -> [NoBinding, gram_symbol s] - | `Keyword s -> - (* assumption: s will be registered as a keyword with the lexer *) - [NoBinding, gram_keyword s] - | `Number s -> [NoBinding, gram_number s] - and aux_layout = function - | Ast.Sub (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sub"] @ aux p2 - | Ast.Sup (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sup"] @ aux p2 - | Ast.Below (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\below"] @ aux p2 - | Ast.Above (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\above"] @ aux p2 - | Ast.Frac (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\frac"] @ aux p2 - | Ast.Atop (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\atop"] @ aux p2 - | Ast.Over (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\over"] @ aux p2 - | Ast.Root (p1, p2) -> - [NoBinding, gram_symbol "\\root"] @ aux p2 - @ [NoBinding, gram_symbol "\\of"] @ aux p1 - | Ast.Sqrt p -> [NoBinding, gram_symbol "\\sqrt"] @ aux p - | Ast.Break -> [] - | Ast.Box (_, pl) -> List.flatten (List.map aux pl) - | Ast.Group pl -> List.flatten (List.map aux pl) - and aux_magic magic = - match magic with - | Ast.Opt p -> - let p_bindings, p_atoms, p_names, p_action = inner_pattern p in - let action (env_opt : CicNotationEnv.t option) (loc : Ast.location) = - match env_opt with - | Some env -> List.map Env.opt_binding_some env - | None -> List.map Env.opt_binding_of_name p_names - in - [ Env (List.map Env.opt_declaration p_names), - Gramext.srules - [ [ Gramext.Sopt (Gramext.srules [ p_atoms, p_action ]) ], - Gramext.action action ] ] - | Ast.List0 (p, _) - | Ast.List1 (p, _) -> - let p_bindings, p_atoms, p_names, p_action = inner_pattern p in -(* let env0 = List.map list_binding_of_name p_names in - let grow_env_entry env n v = - List.map - (function - | (n', (ty, ListValue vl)) as entry -> - if n' = n then n', (ty, ListValue (v :: vl)) else entry - | _ -> assert false) - env - in - let grow_env env_i env = - List.fold_left - (fun env (n, (_, v)) -> grow_env_entry env n v) - env env_i - in *) - let action (env_list : CicNotationEnv.t list) (loc : Ast.location) = - CicNotationEnv.coalesce_env p_names env_list - in - let gram_of_list s = - match magic with - | Ast.List0 (_, None) -> Gramext.Slist0 s - | Ast.List1 (_, None) -> Gramext.Slist1 s - | Ast.List0 (_, Some l) -> Gramext.Slist0sep (s, gram_of_literal l) - | Ast.List1 (_, Some l) -> Gramext.Slist1sep (s, gram_of_literal l) - | _ -> assert false - in - [ Env (List.map Env.list_declaration p_names), - Gramext.srules - [ [ gram_of_list (Gramext.srules [ p_atoms, p_action ]) ], - Gramext.action action ] ] - | _ -> assert false - and aux_variable = - function - | Ast.NumVar s -> [Binding (s, Env.NumType), gram_number ""] - | Ast.TermVar s -> [Binding (s, Env.TermType), gram_term] - | Ast.IdentVar s -> [Binding (s, Env.StringType), gram_ident ""] - | Ast.Ascription (p, s) -> assert false (* TODO *) - | Ast.FreshVar _ -> assert false - and inner_pattern p = - let p_bindings, p_atoms = List.split (aux p) in - let p_names = flatten_opt p_bindings in - let action = - make_action (fun (env : CicNotationEnv.t) (loc : Ast.location) -> env) - p_bindings - in - p_bindings, p_atoms, p_names, action - in - aux pattern - -let level_of precedence associativity = - if precedence < min_precedence || precedence > max_precedence then - raise (Level_not_found precedence); - let assoc_string = - match associativity with - | Gramext.NonA -> "N" - | Gramext.LeftA -> "L" - | Gramext.RightA -> "R" - in - string_of_int precedence ^ assoc_string - -type rule_id = Token.t Gramext.g_symbol list - - (* mapping: rule_id -> owned keywords. (rule_id, string list) Hashtbl.t *) -let owned_keywords = Hashtbl.create 23 - -let extend level1_pattern ~precedence ~associativity action = - let p_bindings, p_atoms = - List.split (extract_term_production level1_pattern) - in - let level = level_of precedence associativity in -(* let p_names = flatten_opt p_bindings in *) - let _ = - Grammar.extend - [ Grammar.Entry.obj (term: 'a Grammar.Entry.e), - Some (Gramext.Level level), - [ None, - Some associativity, - [ p_atoms, - (make_action - (fun (env: CicNotationEnv.t) (loc: Ast.location) -> - (action env loc)) - p_bindings) ]]] - in - let keywords = CicNotationUtil.keywords_of_term level1_pattern in - let rule_id = p_atoms in - List.iter CicNotationLexer.add_level2_ast_keyword keywords; - Hashtbl.add owned_keywords rule_id keywords; (* keywords may be [] *) - rule_id - -let delete rule_id = - let atoms = rule_id in - (try - let keywords = Hashtbl.find owned_keywords rule_id in - List.iter CicNotationLexer.remove_level2_ast_keyword keywords - with Not_found -> assert false); - Grammar.delete_rule term atoms - -(** {2 Grammar} *) - -let parse_level1_pattern_ref = ref (fun _ -> assert false) -let parse_level2_ast_ref = ref (fun _ -> assert false) -let parse_level2_meta_ref = ref (fun _ -> assert false) - -let fold_cluster binder terms ty body = - List.fold_right - (fun term body -> Ast.Binder (binder, (term, ty), body)) - terms body (* terms are names: either Ident or FreshVar *) - -let fold_exists terms ty body = - List.fold_right - (fun term body -> - let lambda = Ast.Binder (`Lambda, (term, ty), body) in - Ast.Appl [ Ast.Symbol ("exists", 0); lambda ]) - terms body - -let fold_binder binder pt_names body = - List.fold_right - (fun (names, ty) body -> fold_cluster binder names ty body) - pt_names body - -let return_term loc term = Ast.AttributedTerm (`Loc loc, term) - - (* create empty precedence level for "term" *) -let _ = - let dummy_action = - Gramext.action (fun _ -> - failwith "internal error, lexer generated a dummy token") - in - (* Needed since campl4 on "delete_rule" remove the precedence level if it gets - * empty after the deletion. The lexer never generate the Stoken below. *) - let dummy_prod = [ [ Gramext.Stoken ("DUMMY", "") ], dummy_action ] in - let mk_level_list first last = - let rec aux acc = function - | i when i < first -> acc - | i -> - aux - ((Some (string_of_int i ^ "N"), Some Gramext.NonA, dummy_prod) - :: (Some (string_of_int i ^ "L"), Some Gramext.LeftA, dummy_prod) - :: (Some (string_of_int i ^ "R"), Some Gramext.RightA, dummy_prod) - :: acc) - (i - 1) - in - aux [] last - in - Grammar.extend - [ Grammar.Entry.obj (term: 'a Grammar.Entry.e), - None, - mk_level_list min_precedence max_precedence ] - -(* {{{ Grammar for concrete syntax patterns, notation level 1 *) -EXTEND - GLOBAL: level1_pattern; - - level1_pattern: [ [ p = l1_pattern; EOI -> CicNotationUtil.boxify p ] ]; - l1_pattern: [ [ p = LIST1 l1_simple_pattern -> p ] ]; - literal: [ - [ s = SYMBOL -> `Symbol s - | k = QKEYWORD -> `Keyword k - | n = NUMBER -> `Number n - ] - ]; - sep: [ [ "sep"; sep = literal -> sep ] ]; -(* row_sep: [ [ "rowsep"; sep = literal -> sep ] ]; - field_sep: [ [ "fieldsep"; sep = literal -> sep ] ]; *) - l1_magic_pattern: [ - [ "list0"; p = l1_simple_pattern; sep = OPT sep -> Ast.List0 (p, sep) - | "list1"; p = l1_simple_pattern; sep = OPT sep -> Ast.List1 (p, sep) - | "opt"; p = l1_simple_pattern -> Ast.Opt p - ] - ]; - l1_pattern_variable: [ - [ "term"; id = IDENT -> Ast.TermVar id - | "number"; id = IDENT -> Ast.NumVar id - | "ident"; id = IDENT -> Ast.IdentVar id - ] - ]; - l1_simple_pattern: - [ "layout" LEFTA - [ p1 = SELF; SYMBOL "\\sub"; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Sub (p1, p2))) - | p1 = SELF; SYMBOL "\\sup"; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Sup (p1, p2))) - | p1 = SELF; SYMBOL "\\below"; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Below (p1, p2))) - | p1 = SELF; SYMBOL "\\above"; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Above (p1, p2))) - | p1 = SELF; SYMBOL "\\over"; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Over (p1, p2))) - | p1 = SELF; SYMBOL "\\atop"; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Atop (p1, p2))) -(* | "array"; p = SELF; csep = OPT field_sep; rsep = OPT row_sep -> - return_term loc (Array (p, csep, rsep)) *) - | SYMBOL "\\frac"; p1 = SELF; p2 = SELF -> - return_term loc (Ast.Layout (Ast.Frac (p1, p2))) - | SYMBOL "\\sqrt"; p = SELF -> return_term loc (Ast.Layout (Ast.Sqrt p)) - | SYMBOL "\\root"; index = SELF; SYMBOL "\\of"; arg = SELF -> - return_term loc (Ast.Layout (Ast.Root (arg, index))) - | "hbox"; LPAREN; p = l1_pattern; RPAREN -> - return_term loc (Ast.Layout (Ast.Box ((Ast.H, false, false), p))) - | "vbox"; LPAREN; p = l1_pattern; RPAREN -> - return_term loc (Ast.Layout (Ast.Box ((Ast.V, false, false), p))) - | "hvbox"; LPAREN; p = l1_pattern; RPAREN -> - return_term loc (Ast.Layout (Ast.Box ((Ast.HV, false, false), p))) - | "hovbox"; LPAREN; p = l1_pattern; RPAREN -> - return_term loc (Ast.Layout (Ast.Box ((Ast.HOV, false, false), p))) - | "break" -> return_term loc (Ast.Layout Ast.Break) -(* | SYMBOL "\\SPACE" -> return_term loc (Layout Space) *) - | LPAREN; p = l1_pattern; RPAREN -> - return_term loc (CicNotationUtil.group p) - ] - | "simple" NONA - [ i = IDENT -> return_term loc (Ast.Variable (Ast.TermVar i)) - | m = l1_magic_pattern -> return_term loc (Ast.Magic m) - | v = l1_pattern_variable -> return_term loc (Ast.Variable v) - | l = literal -> return_term loc (Ast.Literal l) - ] - ]; - END -(* }}} *) - -(* {{{ Grammar for ast magics, notation level 2 *) -EXTEND - GLOBAL: level2_meta; - l2_variable: [ - [ "term"; id = IDENT -> Ast.TermVar id - | "number"; id = IDENT -> Ast.NumVar id - | "ident"; id = IDENT -> Ast.IdentVar id - | "fresh"; id = IDENT -> Ast.FreshVar id - | "anonymous" -> Ast.TermVar "_" - | id = IDENT -> Ast.TermVar id - ] - ]; - l2_magic: [ - [ "fold"; kind = [ "left" -> `Left | "right" -> `Right ]; - base = level2_meta; "rec"; id = IDENT; recursive = level2_meta -> - Ast.Fold (kind, base, [id], recursive) - | "default"; some = level2_meta; none = level2_meta -> - Ast.Default (some, none) - | "if"; p_test = level2_meta; - "then"; p_true = level2_meta; - "else"; p_false = level2_meta -> - Ast.If (p_test, p_true, p_false) - | "fail" -> Ast.Fail - ] - ]; - level2_meta: [ - [ magic = l2_magic -> Ast.Magic magic - | var = l2_variable -> Ast.Variable var - | blob = UNPARSED_AST -> - !parse_level2_ast_ref (Ulexing.from_utf8_string blob) - ] - ]; -END -(* }}} *) - -(* {{{ Grammar for ast patterns, notation level 2 *) -EXTEND - GLOBAL: level2_ast term let_defs; - level2_ast: [ [ p = term -> p ] ]; - sort: [ - [ "Prop" -> `Prop - | "Set" -> `Set - | "Type" -> `Type (CicUniv.fresh ()) - | "CProp" -> `CProp - ] - ]; - explicit_subst: [ - [ SYMBOL "\\subst"; (* to avoid catching frequent "a [1]" cases *) - SYMBOL "["; - substs = LIST1 [ - i = IDENT; SYMBOL <:unicode> (* ≔ *); t = term -> (i, t) - ] SEP SYMBOL ";"; - SYMBOL "]" -> - substs - ] - ]; - meta_subst: [ - [ s = SYMBOL "_" -> None - | p = term -> Some p ] - ]; - meta_substs: [ - [ SYMBOL "["; substs = LIST0 meta_subst; SYMBOL "]" -> substs ] - ]; - possibly_typed_name: [ - [ LPAREN; id = single_arg; SYMBOL ":"; typ = term; RPAREN -> - id, Some typ - | arg = single_arg -> arg, None - ] - ]; - match_pattern: [ - [ id = IDENT -> id, None, [] - | LPAREN; id = IDENT; vars = LIST1 possibly_typed_name; RPAREN -> - id, None, vars - ] - ]; - binder: [ - [ SYMBOL <:unicode> (* Π *) -> `Pi -(* | SYMBOL <:unicode> |+ ∃ +| -> `Exists *) - | SYMBOL <:unicode> (* ∀ *) -> `Forall - | SYMBOL <:unicode> (* λ *) -> `Lambda - ] - ]; - arg: [ - [ LPAREN; names = LIST1 IDENT SEP SYMBOL ","; - SYMBOL ":"; ty = term; RPAREN -> - List.map (fun n -> Ast.Ident (n, None)) names, Some ty - | name = IDENT -> [Ast.Ident (name, None)], None - | blob = UNPARSED_META -> - let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in - match meta with - | Ast.Variable (Ast.FreshVar _) -> [meta], None - | Ast.Variable (Ast.TermVar "_") -> [Ast.Ident ("_", None)], None - | _ -> failwith "Invalid bound name." - ] - ]; - single_arg: [ - [ name = IDENT -> Ast.Ident (name, None) - | blob = UNPARSED_META -> - let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in - match meta with - | Ast.Variable (Ast.FreshVar _) - | Ast.Variable (Ast.IdentVar _) -> meta - | Ast.Variable (Ast.TermVar "_") -> Ast.Ident ("_", None) - | _ -> failwith "Invalid index name." - ] - ]; - induction_kind: [ - [ "rec" -> `Inductive - | "corec" -> `CoInductive - ] - ]; - let_defs: [ - [ defs = LIST1 [ - name = single_arg; - args = LIST1 arg; - index_name = OPT [ "on"; id = single_arg -> id ]; - ty = OPT [ SYMBOL ":" ; p = term -> p ]; - SYMBOL <:unicode> (* ≝ *); body = term -> - let body = fold_binder `Lambda args body in - let ty = - match ty with - | None -> None - | Some ty -> Some (fold_binder `Pi args ty) - in - let rec position_of name p = function - | [] -> None, p - | n :: _ when n = name -> Some p, p - | _ :: tl -> position_of name (p + 1) tl - in - let rec find_arg name n = function - | [] -> - Ast.fail loc (sprintf "Argument %s not found" - (CicNotationPp.pp_term name)) - | (l,_) :: tl -> - (match position_of name 0 l with - | None, len -> find_arg name (n + len) tl - | Some where, len -> n + where) - in - let index = - match index_name with - | None -> 0 - | Some index_name -> find_arg index_name 0 args - in - (name, ty), body, index - ] SEP "and" -> - defs - ] - ]; - binder_vars: [ - [ vars = [ - l = LIST1 single_arg SEP SYMBOL "," -> l - | SYMBOL "_" -> [Ast.Ident ("_", None)] ]; - typ = OPT [ SYMBOL ":"; t = term -> t ] -> (vars, typ) - | LPAREN; - vars = [ - l = LIST1 single_arg SEP SYMBOL "," -> l - | SYMBOL "_" -> [Ast.Ident ("_", None)] ]; - typ = OPT [ SYMBOL ":"; t = term -> t ]; - RPAREN -> (vars, typ) - ] - ]; - term: LEVEL "10N" [ (* let in *) - [ "let"; var = possibly_typed_name; SYMBOL <:unicode> (* ≝ *); - p1 = term; "in"; p2 = term -> - return_term loc (Ast.LetIn (var, p1, p2)) - | "let"; k = induction_kind; defs = let_defs; "in"; - body = term -> - return_term loc (Ast.LetRec (k, defs, body)) - ] - ]; - term: LEVEL "20R" (* binder *) - [ - [ b = binder; (vars, typ) = binder_vars; SYMBOL "."; body = term -> - return_term loc (fold_cluster b vars typ body) - | SYMBOL <:unicode> (* ∃ *); - (vars, typ) = binder_vars; SYMBOL "."; body = term -> - return_term loc (fold_exists vars typ body) - ] - ]; - term: LEVEL "70L" (* apply *) - [ - [ p1 = term; p2 = term -> - let rec aux = function - | Ast.Appl (hd :: tl) - | Ast.AttributedTerm (_, Ast.Appl (hd :: tl)) -> - aux hd @ tl - | term -> [term] - in - return_term loc (Ast.Appl (aux p1 @ [p2])) - ] - ]; - term: LEVEL "90N" (* simple *) - [ - [ id = IDENT -> return_term loc (Ast.Ident (id, None)) - | id = IDENT; s = explicit_subst -> - return_term loc (Ast.Ident (id, Some s)) - | s = CSYMBOL -> return_term loc (Ast.Symbol (s, 0)) - | u = URI -> return_term loc (Ast.Uri (u, None)) - | n = NUMBER -> return_term loc (Ast.Num (n, 0)) - | IMPLICIT -> return_term loc (Ast.Implicit) - | PLACEHOLDER -> return_term loc Ast.UserInput - | m = META -> return_term loc (Ast.Meta (int_of_string m, [])) - | m = META; s = meta_substs -> - return_term loc (Ast.Meta (int_of_string m, s)) - | s = sort -> return_term loc (Ast.Sort s) - | "match"; t = term; - indty_ident = OPT [ "in"; id = IDENT -> id, None ]; - outtyp = OPT [ "return"; ty = term -> ty ]; - "with"; SYMBOL "["; - patterns = LIST0 [ - lhs = match_pattern; SYMBOL <:unicode> (* ⇒ *); - rhs = term -> - lhs, rhs - ] SEP SYMBOL "|"; - SYMBOL "]" -> - return_term loc (Ast.Case (t, indty_ident, outtyp, patterns)) - | LPAREN; p1 = term; SYMBOL ":"; p2 = term; RPAREN -> - return_term loc (Ast.Cast (p1, p2)) - | LPAREN; p = term; RPAREN -> p - | blob = UNPARSED_META -> - !parse_level2_meta_ref (Ulexing.from_utf8_string blob) - ] - ]; -END -(* }}} *) - -(** {2 API implementation} *) - -let exc_located_wrapper f = - try - f () - with - | Stdpp.Exc_located (floc, Stream.Error msg) -> - raise (HExtlib.Localized (floc, Parse_error msg)) - | Stdpp.Exc_located (floc, exn) -> - raise (HExtlib.Localized (floc, (Parse_error (Printexc.to_string exn)))) - -let parse_level1_pattern lexbuf = - exc_located_wrapper - (fun () -> Grammar.Entry.parse level1_pattern (Obj.magic lexbuf)) - -let parse_level2_ast lexbuf = - exc_located_wrapper - (fun () -> Grammar.Entry.parse level2_ast (Obj.magic lexbuf)) - -let parse_level2_meta lexbuf = - exc_located_wrapper - (fun () -> Grammar.Entry.parse level2_meta (Obj.magic lexbuf)) - -let _ = - parse_level1_pattern_ref := parse_level1_pattern; - parse_level2_ast_ref := parse_level2_ast; - parse_level2_meta_ref := parse_level2_meta - -(** {2 Debugging} *) - -let print_l2_pattern () = - Grammar.print_entry Format.std_formatter (Grammar.Entry.obj term); - Format.pp_print_flush Format.std_formatter (); - flush stdout - -(* vim:set encoding=utf8 foldmethod=marker: *) diff --git a/helm/ocaml/content_pres/cicNotationParser.mli b/helm/ocaml/content_pres/cicNotationParser.mli deleted file mode 100644 index e25968bbb..000000000 --- a/helm/ocaml/content_pres/cicNotationParser.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -exception Parse_error of string -exception Level_not_found of int - -(** {2 Parsing functions} *) - - (** concrete syntax pattern: notation level 1 *) -val parse_level1_pattern: Ulexing.lexbuf -> CicNotationPt.term - - (** AST pattern: notation level 2 *) -val parse_level2_ast: Ulexing.lexbuf -> CicNotationPt.term -val parse_level2_meta: Ulexing.lexbuf -> CicNotationPt.term - -(** {2 Grammar extension} *) - -type rule_id - -val extend: - CicNotationPt.term -> (* level 1 pattern *) - precedence:int -> - associativity:Gramext.g_assoc -> - (CicNotationEnv.t -> CicNotationPt.location -> CicNotationPt.term) -> - rule_id - -val delete: rule_id -> unit - -(** {2 Grammar entries} - * needed by grafite parser *) - -val level2_ast_grammar: Grammar.g - -val term : CicNotationPt.term Grammar.Entry.e - -val let_defs : - (CicNotationPt.capture_variable * CicNotationPt.term * int) list - Grammar.Entry.e - -(** {2 Debugging} *) - - (** print "level2_pattern" entry on stdout, flushing afterwards *) -val print_l2_pattern: unit -> unit - diff --git a/helm/ocaml/content_pres/cicNotationPres.ml b/helm/ocaml/content_pres/cicNotationPres.ml deleted file mode 100644 index 308f23d22..000000000 --- a/helm/ocaml/content_pres/cicNotationPres.ml +++ /dev/null @@ -1,433 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt -module Mpres = Mpresentation - -type mathml_markup = boxml_markup Mpres.mpres -and boxml_markup = mathml_markup Box.box - -type markup = mathml_markup - -let atop_attributes = [None, "linethickness", "0pt"] - -let to_unicode = Utf8Macro.unicode_of_tex - -let rec make_attributes l1 = function - | [] -> [] - | hd :: tl -> - (match hd with - | None -> make_attributes (List.tl l1) tl - | Some s -> - let p,n = List.hd l1 in - (p,n,s) :: make_attributes (List.tl l1) tl) - -let box_of_mpres = - function - | Mpresentation.Mobject (attrs, box) -> - assert (attrs = []); - box - | mpres -> Box.Object ([], mpres) - -let mpres_of_box = - function - | Box.Object (attrs, mpres) -> - assert (attrs = []); - mpres - | box -> Mpresentation.Mobject ([], box) - -let rec genuine_math = - function - | Mpresentation.Mobject ([], obj) -> not (genuine_box obj) - | _ -> true -and genuine_box = - function - | Box.Object ([], mpres) -> not (genuine_math mpres) - | _ -> true - -let rec eligible_math = - function - | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> eligible_math mpres - | Mpresentation.Mobject ([], _) -> false - | _ -> true - -let rec promote_to_math = - function - | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres - | math -> math - -let small_skip = - Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML) - -let rec add_mpres_attributes new_attr = function - | Mpresentation.Mobject (attr, box) -> - Mpresentation.Mobject (attr, add_box_attributes new_attr box) - | mpres -> - Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres -and add_box_attributes new_attr = function - | Box.Object (attr, mpres) -> - Box.Object (attr, add_mpres_attributes new_attr mpres) - | box -> Box.set_attr (new_attr @ Box.get_attr box) box - -let box_of mathonly spec attrs children = - match children with - | [t] -> add_mpres_attributes attrs t - | _ -> - let kind, spacing, indent = spec in - let dress children = - if spacing then - CicNotationUtil.dress small_skip children - else - children - in - if mathonly then Mpresentation.Mrow (attrs, dress children) - else - let attrs' = - (if spacing then RenderingAttrs.spacing_attributes `BoxML else []) - @ (if indent then RenderingAttrs.indent_attributes `BoxML else []) - @ attrs - in - match kind with - | Ast.H -> - if List.for_all eligible_math children then - Mpresentation.Mrow (attrs', - dress (List.map promote_to_math children)) - else - mpres_of_box (Box.H (attrs', - List.map box_of_mpres children)) -(* | Ast.H when List.for_all genuine_math children -> - Mpresentation.Mrow (attrs', dress children) *) - | Ast.V -> - mpres_of_box (Box.V (attrs', - List.map box_of_mpres children)) - | Ast.HV -> - mpres_of_box (Box.HV (attrs', - List.map box_of_mpres children)) - | Ast.HOV -> - mpres_of_box (Box.HOV (attrs', - List.map box_of_mpres children)) - -let open_paren = Mpresentation.Mo ([], "(") -let closed_paren = Mpresentation.Mo ([], ")") -let open_brace = Mpresentation.Mo ([], "{") -let closed_brace = Mpresentation.Mo ([], "}") -let hidden_substs = Mpresentation.Mtext ([], "{...}") -let open_box_paren = Box.Text ([], "(") -let closed_box_paren = Box.Text ([], ")") -let semicolon = Mpresentation.Mo ([], ";") -let toggle_action children = - Mpresentation.Maction ([None, "actiontype", "toggle"], children) - -type child_pos = [ `Left | `Right | `Inner ] - -let pp_assoc = - function - | Gramext.LeftA -> "LeftA" - | Gramext.RightA -> "RightA" - | Gramext.NonA -> "NonA" - -let is_atomic t = - let rec aux_mpres = function - | Mpres.Mi _ - | Mpres.Mo _ - | Mpres.Mn _ - | Mpres.Ms _ - | Mpres.Mtext _ - | Mpres.Mspace _ -> true - | Mpres.Mobject (_, box) -> aux_box box - | Mpres.Maction (_, [mpres]) - | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres - | _ -> false - and aux_box = function - | Box.Space _ - | Box.Ink _ - | Box.Text _ -> true - | Box.Object (_, mpres) -> aux_mpres mpres - | Box.H (_, [box]) - | Box.V (_, [box]) - | Box.HV (_, [box]) - | Box.HOV (_, [box]) - | Box.Action (_, [box]) -> aux_box box - | _ -> false - in - aux_mpres t - -let add_parens child_prec child_assoc child_pos curr_prec t = -(* eprintf - ("add_parens: " ^^ - "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d\n\n%!") - child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos child_pos) - curr_prec; *) - if is_atomic t then t - else if child_prec >= 0 - && (child_prec < curr_prec - || (child_prec = curr_prec && - child_assoc = Gramext.LeftA && - child_pos <> `Left) - || (child_prec = curr_prec && - child_assoc = Gramext.RightA && - child_pos <> `Right)) - then begin (* parens should be added *) -(* prerr_endline "adding parens!"; *) - match t with - | Mpresentation.Mobject (_, box) -> - mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ])) - | mpres -> Mpresentation.Mrow ([], [open_paren; t; closed_paren]) - end else - t - -let render ids_to_uris = - let module A = Ast in - let module P = Mpresentation in -(* let use_unicode = true in *) - let lookup_uri id = - (try - let uri = Hashtbl.find ids_to_uris id in - Some (UriManager.string_of_uri uri) - with Not_found -> None) - in - let make_href xmlattrs xref = - let xref_uris = - List.fold_right - (fun xref uris -> - match lookup_uri xref with - | None -> uris - | Some uri -> uri :: uris) - !xref [] - in - let xmlattrs_uris, xmlattrs = - let xref_attrs, other_attrs = - List.partition - (function Some "xlink", "href", _ -> true | _ -> false) - xmlattrs - in - List.map (fun (_, _, uri) -> uri) xref_attrs, - other_attrs - in - let uris = - match xmlattrs_uris @ xref_uris with - | [] -> None - | uris -> - Some (String.concat " " - (HExtlib.list_uniq (List.sort String.compare uris))) - in - let xrefs = - match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs) - in - xref := []; - xmlattrs - @ make_attributes [Some "helm", "xref"; Some "xlink", "href"] - [xrefs; uris] - in - let make_xref xref = - let xrefs = - match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs) - in - xref := []; - make_attributes [Some "helm","xref"] [xrefs] - in - (* when mathonly is true no boxes should be generated, only mrows *) - (* "xref" is *) - let rec aux xmlattrs mathonly xref pos prec t = - match t with - | A.AttributedTerm _ -> - aux_attributes xmlattrs mathonly xref pos prec t - | A.Num (literal, _) -> - let attrs = - (RenderingAttrs.number_attributes `MathML) - @ make_href xmlattrs xref - in - Mpres.Mn (attrs, literal) - | A.Symbol (literal, _) -> - let attrs = - (RenderingAttrs.symbol_attributes `MathML) - @ make_href xmlattrs xref - in - Mpres.Mo (attrs, to_unicode literal) - | A.Ident (literal, subst) - | A.Uri (literal, subst) -> - let attrs = - (RenderingAttrs.ident_attributes `MathML) - @ make_href xmlattrs xref - in - let name = Mpres.Mi (attrs, to_unicode literal) in - (match subst with - | Some [] - | None -> name - | Some substs -> - let substs' = - box_of mathonly (A.H, false, false) [] - (open_brace - :: (CicNotationUtil.dress semicolon - (List.map - (fun (name, t) -> - box_of mathonly (A.H, false, false) [] [ - Mpres.Mi ([], name); - Mpres.Mo ([], to_unicode "\\def"); - aux [] mathonly xref pos prec t ]) - substs)) - @ [ closed_brace ]) - in - let substs_maction = toggle_action [ hidden_substs; substs' ] in - box_of mathonly (A.H, false, false) [] [ name; substs_maction ]) - | A.Literal l -> aux_literal xmlattrs xref prec l - | A.UserInput -> Mpres.Mtext ([], "%") - | A.Layout l -> aux_layout mathonly xref pos prec l - | A.Magic _ - | A.Variable _ -> assert false (* should have been instantiated *) - | t -> - prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t); - assert false - and aux_attributes xmlattrs mathonly xref pos prec t = - let reset = ref false in - let new_level = ref None in - let new_xref = ref [] in - let new_xmlattrs = ref [] in - let new_pos = ref pos in -(* let reinit = ref false in *) - let rec aux_attribute = - function - | A.AttributedTerm (attr, t) -> - (match attr with - | `Loc _ - | `Raw _ -> () - | `Level (-1, _) -> reset := true - | `Level (child_prec, child_assoc) -> - new_level := Some (child_prec, child_assoc) - | `IdRef xref -> new_xref := xref :: !new_xref - | `ChildPos pos -> new_pos := pos - | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs); - aux_attribute t - | t -> - (match !new_level with - | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t - | Some (child_prec, child_assoc) -> - let t' = - aux !new_xmlattrs mathonly new_xref !new_pos child_prec t in - if !reset - then t' - else add_parens child_prec child_assoc !new_pos prec t') - in - aux_attribute t - and aux_literal xmlattrs xref prec l = - let attrs = make_href xmlattrs xref in - (match l with - | `Symbol s -> Mpres.Mo (attrs, to_unicode s) - | `Keyword s -> Mpres.Mo (attrs, to_unicode s) - | `Number s -> Mpres.Mn (attrs, to_unicode s)) - and aux_layout mathonly xref pos prec l = - let attrs = make_xref xref in - let invoke' t = aux [] true (ref []) pos prec t in - (* use the one below to reset precedence and associativity *) - let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in - match l with - | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2) - | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2) - | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2) - | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2) - | A.Frac (t1, t2) - | A.Over (t1, t2) -> - Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2) - | A.Atop (t1, t2) -> - Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1, - invoke_reinit t2) - | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t) - | A.Root (t1, t2) -> - Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2) - | A.Box ((_, spacing, _) as kind, terms) -> - let children = - aux_children mathonly spacing xref pos prec - (CicNotationUtil.ungroup terms) - in - box_of mathonly kind attrs children - | A.Group terms -> - let children = - aux_children mathonly false xref pos prec - (CicNotationUtil.ungroup terms) - in - box_of mathonly (A.H, false, false) attrs children - | A.Break -> assert false (* TODO? *) - and aux_children mathonly spacing xref pos prec terms = - let find_clusters = - let rec aux_list first clusters acc = - function - [] when acc = [] -> List.rev clusters - | [] -> aux_list first (List.rev acc :: clusters) [] [] - | (A.Layout A.Break) :: tl when acc = [] -> - aux_list first clusters [] tl - | (A.Layout A.Break) :: tl -> - aux_list first (List.rev acc :: clusters) [] tl - | [hd] -> -(* let pos' = - if first then - pos - else - match pos with - `None -> `Right - | `Inner -> `Inner - | `Right -> `Right - | `Left -> `Inner - in *) - aux_list false clusters - (aux [] mathonly xref pos prec hd :: acc) [] - | hd :: tl -> -(* let pos' = - match pos, first with - `None, true -> `Left - | `None, false -> `Inner - | `Left, true -> `Left - | `Left, false -> `Inner - | `Right, _ -> `Inner - | `Inner, _ -> `Inner - in *) - aux_list false clusters - (aux [] mathonly xref pos prec hd :: acc) tl - in - aux_list true [] [] - in - let boxify_pres = - function - [t] -> t - | tl -> box_of mathonly (A.H, spacing, false) [] tl - in - List.map boxify_pres (find_clusters terms) - in - aux [] false (ref []) `Inner ~-1 - -let rec print_box (t: boxml_markup) = - Box.box2xml print_mpres t -and print_mpres (t: mathml_markup) = - Mpresentation.print_mpres print_box t - -let print_xml = print_mpres - -(* let render_to_boxml id_to_uri t = - let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in - Xml.add_xml_declaration xml_stream *) - diff --git a/helm/ocaml/content_pres/cicNotationPres.mli b/helm/ocaml/content_pres/cicNotationPres.mli deleted file mode 100644 index 04411df2b..000000000 --- a/helm/ocaml/content_pres/cicNotationPres.mli +++ /dev/null @@ -1,52 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -type mathml_markup = boxml_markup Mpresentation.mpres -and boxml_markup = mathml_markup Box.box - -type markup = mathml_markup - -(** {2 Markup conversions} *) - -val mpres_of_box: boxml_markup -> mathml_markup -val box_of_mpres: mathml_markup -> boxml_markup - -(** {2 Rendering} *) - -(** level 1 -> level 0 - * @param ids_to_uris mapping id -> uri for hyperlinking *) -val render: (Cic.id, UriManager.uri) Hashtbl.t -> CicNotationPt.term -> markup - -(** level 0 -> xml stream *) -val print_xml: markup -> Xml.token Stream.t - -(* |+* level 1 -> xml stream - * @param ids_to_uris +| -val render_to_boxml: - (Cic.id, string) Hashtbl.t -> CicNotationPt.term -> Xml.token Stream.t *) - -val print_box: boxml_markup -> Xml.token Stream.t -val print_mpres: mathml_markup -> Xml.token Stream.t - diff --git a/helm/ocaml/content_pres/content2pres.ml b/helm/ocaml/content_pres/content2pres.ml deleted file mode 100644 index abac7cb5d..000000000 --- a/helm/ocaml/content_pres/content2pres.ml +++ /dev/null @@ -1,821 +0,0 @@ -(* Copyright (C) 2003-2005, 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 *) -(* *) -(* Andrea Asperti *) -(* 17/06/2003 *) -(* *) -(***************************************************************************) - -(* $Id$ *) - -module P = Mpresentation -module B = Box -module Con = Content - -let p_mtr a b = Mpresentation.Mtr(a,b) -let p_mtd a b = Mpresentation.Mtd(a,b) -let p_mtable a b = Mpresentation.Mtable(a,b) -let p_mtext a b = Mpresentation.Mtext(a,b) -let p_mi a b = Mpresentation.Mi(a,b) -let p_mo a b = Mpresentation.Mo(a,b) -let p_mrow a b = Mpresentation.Mrow(a,b) -let p_mphantom a b = Mpresentation.Mphantom(a,b) - -let rec split n l = - if n = 0 then [],l - else let l1,l2 = - split (n-1) (List.tl l) in - (List.hd l)::l1,l2 - -let get_xref = function - | `Declaration d - | `Hypothesis d -> d.Con.dec_id - | `Proof p -> p.Con.proof_id - | `Definition d -> d.Con.def_id - | `Joint jo -> jo.Con.joint_id - -let hv_attrs = - RenderingAttrs.spacing_attributes `BoxML - @ RenderingAttrs.indent_attributes `BoxML - -let make_row items concl = - B.b_hv hv_attrs (items @ [ concl ]) -(* match concl with - B.V _ -> |+ big! +| - B.b_v attrs [B.b_h [] items; B.b_indent concl] - | _ -> |+ small +| - B.b_h attrs (items@[B.b_space; concl]) *) - -let make_concl ?(attrs=[]) verb concl = - B.b_hv (hv_attrs @ attrs) [ B.b_kw verb; concl ] -(* match concl with - B.V _ -> |+ big! +| - B.b_v attrs [ B.b_kw verb; B.b_indent concl] - | _ -> |+ small +| - B.b_h attrs [ B.b_kw verb; B.b_space; concl ] *) - -let make_args_for_apply term2pres args = - let make_arg_for_apply is_first arg row = - let res = - match arg with - Con.Aux n -> assert false - | Con.Premise prem -> - let name = - (match prem.Con.premise_binder with - None -> "previous" - | Some s -> s) in - (B.b_object (P.Mi ([], name)))::row - | Con.Lemma lemma -> - let lemma_attrs = [ - Some "helm", "xref", lemma.Con.lemma_id; - Some "xlink", "href", lemma.Con.lemma_uri ] - in - (B.b_object (P.Mi(lemma_attrs,lemma.Con.lemma_name)))::row - | Con.Term t -> - if is_first then - (term2pres t)::row - else (B.b_object (P.Mi([],"_")))::row - | Con.ArgProof _ - | Con.ArgMethod _ -> - (B.b_object (P.Mi([],"_")))::row - in - if is_first then res else B.skip::res - in - match args with - hd::tl -> - make_arg_for_apply true hd - (List.fold_right (make_arg_for_apply false) tl []) - | _ -> assert false - -let get_name = function - | Some s -> s - | None -> "_" - -let add_xref id = function - | B.Text (attrs, t) -> B.Text (((Some "helm", "xref", id) :: attrs), t) - | _ -> assert false (* TODO, add_xref is meaningful for all boxes *) - -let rec justification term2pres p = - if ((p.Con.proof_conclude.Con.conclude_method = "Exact") or - ((p.Con.proof_context = []) & - (p.Con.proof_apply_context = []) & - (p.Con.proof_conclude.Con.conclude_method = "Apply"))) then - let pres_args = - make_args_for_apply term2pres p.Con.proof_conclude.Con.conclude_args in - B.H([], - (B.b_kw "by")::B.b_space:: - B.Text([],"(")::pres_args@[B.Text([],")")]) - else proof2pres term2pres p - -and proof2pres term2pres p = - let rec proof2pres p = - let indent = - let is_decl e = - (match e with - `Declaration _ - | `Hypothesis _ -> true - | _ -> false) in - ((List.filter is_decl p.Con.proof_context) != []) in - let omit_conclusion = (not indent) && (p.Con.proof_context != []) in - let concl = - (match p.Con.proof_conclude.Con.conclude_conclusion with - None -> None - | Some t -> Some (term2pres t)) in - let body = - let presconclude = - conclude2pres p.Con.proof_conclude indent omit_conclusion in - let presacontext = - acontext2pres p.Con.proof_apply_context presconclude indent in - context2pres p.Con.proof_context presacontext in - match p.Con.proof_name with - None -> body - | Some name -> - let action = - match concl with - None -> body - | Some ac -> - let concl = - make_concl ~attrs:[ Some "helm", "xref", p.Con.proof_id ] - "proof of" ac in - B.b_toggle [ concl; body ] - in - B.V ([], - [B.Text ([],"(" ^ name ^ ")"); - B.indent action]) - - and context2pres c continuation = - (* we generate a subtable for each context element, for selection - purposes - The table generated by the head-element does not have an xref; - the whole context-proof is already selectable *) - match c with - [] -> continuation - | hd::tl -> - let continuation' = - List.fold_right - (fun ce continuation -> - let xref = get_xref ce in - B.V([Some "helm", "xref", xref ], - [B.H([Some "helm", "xref", "ce_"^xref], - [ce2pres_in_proof_context_element ce]); - continuation])) tl continuation in - let hd_xref= get_xref hd in - B.V([], - [B.H([Some "helm", "xref", "ce_"^hd_xref], - [ce2pres_in_proof_context_element hd]); - continuation']) - - and ce2pres_in_joint_context_element = function - | `Inductive _ -> assert false (* TODO *) - | (`Declaration _) as x -> ce2pres x - | (`Hypothesis _) as x -> ce2pres x - | (`Proof _) as x -> ce2pres x - | (`Definition _) as x -> ce2pres x - - and ce2pres_in_proof_context_element = function - | `Joint ho -> - B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs)) - | (`Declaration _) as x -> ce2pres x - | (`Hypothesis _) as x -> ce2pres x - | (`Proof _) as x -> ce2pres x - | (`Definition _) as x -> ce2pres x - - and ce2pres = - function - `Declaration d -> - (match d.Con.dec_name with - Some s -> - let ty = term2pres d.Con.dec_type in - B.H ([], - [(B.b_kw "Assume"); - B.b_space; - B.Object ([], P.Mi([],s)); - B.Text([],":"); - ty]) - | None -> - prerr_endline "NO NAME!!"; assert false) - | `Hypothesis h -> - (match h.Con.dec_name with - Some s -> - let ty = term2pres h.Con.dec_type in - B.H ([], - [(B.b_kw "Suppose"); - B.b_space; - B.Text([],"("); - B.Object ([], P.Mi ([],s)); - B.Text([],")"); - B.b_space; - ty]) - | None -> - prerr_endline "NO NAME!!"; assert false) - | `Proof p -> - proof2pres p - | `Definition d -> - (match d.Con.def_name with - Some s -> - let term = term2pres d.Con.def_term in - B.H ([], - [ B.b_kw "Let"; B.b_space; - B.Object ([], P.Mi([],s)); - B.Text([]," = "); - term]) - | None -> - prerr_endline "NO NAME!!"; assert false) - - and acontext2pres ac continuation indent = - List.fold_right - (fun p continuation -> - let hd = - if indent then - B.indent (proof2pres p) - else - proof2pres p in - B.V([Some "helm","xref",p.Con.proof_id], - [B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]); - continuation])) ac continuation - - and conclude2pres conclude indent omit_conclusion = - let tconclude_body = - match conclude.Con.conclude_conclusion with - Some t when - not omit_conclusion or - (* CSC: I ignore the omit_conclusion flag in this case. *) - (* CSC: Is this the correct behaviour? In the stylesheets *) - (* CSC: we simply generated nothing (i.e. the output type *) - (* CSC: of the function should become an option. *) - conclude.Con.conclude_method = "BU_Conversion" -> - let concl = (term2pres t) in - if conclude.Con.conclude_method = "BU_Conversion" then - make_concl "that is equivalent to" concl - else if conclude.Con.conclude_method = "FalseInd" then - (* false ind is in charge to add the conclusion *) - falseind conclude - else - let conclude_body = conclude_aux conclude in - let ann_concl = - if conclude.Con.conclude_method = "TD_Conversion" then - make_concl "that is equivalent to" concl - else make_concl "we conclude" concl in - B.V ([], [conclude_body; ann_concl]) - | _ -> conclude_aux conclude in - if indent then - B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id], - [tconclude_body])) - else - B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body]) - - and conclude_aux conclude = - if conclude.Con.conclude_method = "TD_Conversion" then - let expected = - (match conclude.Con.conclude_conclusion with - None -> B.Text([],"NO EXPECTED!!!") - | Some c -> term2pres c) in - let subproof = - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> p - | _ -> assert false) in - let synth = - (match subproof.Con.proof_conclude.Con.conclude_conclusion with - None -> B.Text([],"NO SYNTH!!!") - | Some c -> (term2pres c)) in - B.V - ([], - [make_concl "we must prove" expected; - make_concl "or equivalently" synth; - proof2pres subproof]) - else if conclude.Con.conclude_method = "BU_Conversion" then - assert false - else if conclude.Con.conclude_method = "Exact" then - let arg = - (match conclude.Con.conclude_args with - [Con.Term t] -> term2pres t - | [Con.Premise p] -> - (match p.Con.premise_binder with - | None -> assert false; (* unnamed hypothesis ??? *) - | Some s -> B.Text([],s)) - | err -> assert false) in - (match conclude.Con.conclude_conclusion with - None -> - B.b_h [] [B.b_kw "Consider"; B.b_space; arg] - | Some c -> let conclusion = term2pres c in - make_row - [arg; B.b_space; B.b_kw "proves"] - conclusion - ) - else if conclude.Con.conclude_method = "Intros+LetTac" then - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> proof2pres p - | _ -> assert false) -(* OLD CODE - let conclusion = - (match conclude.Con.conclude_conclusion with - None -> B.Text([],"NO Conclusion!!!") - | Some c -> term2pres c) in - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> - B.V - ([None,"align","baseline 1"; None,"equalrows","false"; - None,"columnalign","left"], - [B.H([],[B.Object([],proof2pres p)]); - B.H([],[B.Object([], - (make_concl "we proved 1" conclusion))])]); - | _ -> assert false) -*) - else if (conclude.Con.conclude_method = "Case") then - case conclude - else if (conclude.Con.conclude_method = "ByInduction") then - byinduction conclude - else if (conclude.Con.conclude_method = "Exists") then - exists conclude - else if (conclude.Con.conclude_method = "AndInd") then - andind conclude - else if (conclude.Con.conclude_method = "FalseInd") then - falseind conclude - else if (conclude.Con.conclude_method = "Rewrite") then - let justif = - (match (List.nth conclude.Con.conclude_args 6) with - Con.ArgProof p -> justification term2pres p - | _ -> assert false) in - let term1 = - (match List.nth conclude.Con.conclude_args 2 with - Con.Term t -> term2pres t - | _ -> assert false) in - let term2 = - (match List.nth conclude.Con.conclude_args 5 with - Con.Term t -> term2pres t - | _ -> assert false) in - B.V ([], - [B.H ([],[ - (B.b_kw "rewrite"); - B.b_space; term1; - B.b_space; (B.b_kw "with"); - B.b_space; term2; - B.indent justif])]) - else if conclude.Con.conclude_method = "Apply" then - let pres_args = - make_args_for_apply term2pres conclude.Con.conclude_args in - B.H([], - (B.b_kw "by"):: - B.b_space:: - B.Text([],"(")::pres_args@[B.Text([],")")]) - else - B.V ([], [ - B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to"); - (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))]) - - and args2pres l = List.map arg2pres l - - and arg2pres = - function - Con.Aux n -> B.b_kw ("aux " ^ n) - | Con.Premise prem -> B.b_kw "premise" - | Con.Lemma lemma -> B.b_kw "lemma" - | Con.Term t -> term2pres t - | Con.ArgProof p -> proof2pres p - | Con.ArgMethod s -> B.b_kw "method" - - and case conclude = - let proof_conclusion = - (match conclude.Con.conclude_conclusion with - None -> B.b_kw "No conclusion???" - | Some t -> term2pres t) in - let arg,args_for_cases = - (match conclude.Con.conclude_args with - Con.Aux(_)::Con.Aux(_)::Con.Term(_)::arg::tl -> - arg,tl - | _ -> assert false) in - let case_on = - let case_arg = - (match arg with - Con.Aux n -> B.b_kw "an aux???" - | Con.Premise prem -> - (match prem.Con.premise_binder with - None -> B.b_kw "the previous result" - | Some n -> B.Object ([], P.Mi([],n))) - | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name)) - | Con.Term t -> - term2pres t - | Con.ArgProof p -> B.b_kw "a proof???" - | Con.ArgMethod s -> B.b_kw "a method???") - in - (make_concl "we proceed by cases on" case_arg) in - let to_prove = - (make_concl "to prove" proof_conclusion) in - B.V ([], case_on::to_prove::(make_cases args_for_cases)) - - and byinduction conclude = - let proof_conclusion = - (match conclude.Con.conclude_conclusion with - None -> B.b_kw "No conclusion???" - | Some t -> term2pres t) in - let inductive_arg,args_for_cases = - (match conclude.Con.conclude_args with - Con.Aux(n)::_::tl -> - let l1,l2 = split (int_of_string n) tl in - let last_pos = (List.length l2)-1 in - List.nth l2 last_pos,l1 - | _ -> assert false) in - let induction_on = - let arg = - (match inductive_arg with - Con.Aux n -> B.b_kw "an aux???" - | Con.Premise prem -> - (match prem.Con.premise_binder with - None -> B.b_kw "the previous result" - | Some n -> B.Object ([], P.Mi([],n))) - | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name)) - | Con.Term t -> - term2pres t - | Con.ArgProof p -> B.b_kw "a proof???" - | Con.ArgMethod s -> B.b_kw "a method???") in - (make_concl "we proceed by induction on" arg) in - let to_prove = - (make_concl "to prove" proof_conclusion) in - B.V ([], induction_on::to_prove:: (make_cases args_for_cases)) - - and make_cases l = List.map make_case l - - and make_case = - function - Con.ArgProof p -> - let name = - (match p.Con.proof_name with - None -> B.b_kw "no name for case!!" - | Some n -> B.Object ([], P.Mi([],n))) in - let indhyps,args = - List.partition - (function - `Hypothesis h -> h.Con.dec_inductive - | _ -> false) p.Con.proof_context in - let pattern_aux = - List.fold_right - (fun e p -> - let dec = - (match e with - `Declaration h - | `Hypothesis h -> - let name = - (match h.Con.dec_name with - None -> "NO NAME???" - | Some n ->n) in - [B.b_space; - B.Object ([], P.Mi ([],name)); - B.Text([],":"); - (term2pres h.Con.dec_type)] - | _ -> [B.Text ([],"???")]) in - dec@p) args [] in - let pattern = - B.H ([], - (B.b_kw "Case"::B.b_space::name::pattern_aux)@ - [B.b_space; - B.Text([], Utf8Macro.unicode_of_tex "\\Rightarrow")]) in - let subconcl = - (match p.Con.proof_conclude.Con.conclude_conclusion with - None -> B.b_kw "No conclusion!!!" - | Some t -> term2pres t) in - let asubconcl = B.indent (make_concl "the thesis becomes" subconcl) in - let induction_hypothesis = - (match indhyps with - [] -> [] - | _ -> - let text = B.indent (B.b_kw "by induction hypothesis we know") in - let make_hyp = - function - `Hypothesis h -> - let name = - (match h.Con.dec_name with - None -> "no name" - | Some s -> s) in - B.indent (B.H ([], - [B.Text([],"("); - B.Object ([], P.Mi ([],name)); - B.Text([],")"); - B.b_space; - term2pres h.Con.dec_type])) - | _ -> assert false in - let hyps = List.map make_hyp indhyps in - text::hyps) in - (* let acontext = - acontext2pres_old p.Con.proof_apply_context true in *) - let body = conclude2pres p.Con.proof_conclude true false in - let presacontext = - let acontext_id = - match p.Con.proof_apply_context with - [] -> p.Con.proof_conclude.Con.conclude_id - | {Con.proof_id = id}::_ -> id - in - B.Action([None,"type","toggle"], - [ B.indent (add_xref acontext_id (B.b_kw "Proof")); - acontext2pres p.Con.proof_apply_context body true]) in - B.V ([], pattern::asubconcl::induction_hypothesis@[presacontext]) - | _ -> assert false - - and falseind conclude = - let proof_conclusion = - (match conclude.Con.conclude_conclusion with - None -> B.b_kw "No conclusion???" - | Some t -> term2pres t) in - let case_arg = - (match conclude.Con.conclude_args with - [Con.Aux(n);_;case_arg] -> case_arg - | _ -> assert false; - (* - List.map (ContentPp.parg 0) conclude.Con.conclude_args; - assert false *)) in - let arg = - (match case_arg with - Con.Aux n -> assert false - | Con.Premise prem -> - (match prem.Con.premise_binder with - None -> [B.b_kw "Contradiction, hence"] - | Some n -> - [ B.Object ([],P.Mi([],n)); B.skip; - B.b_kw "is contradictory, hence"]) - | Con.Lemma lemma -> - [ B.Object ([], P.Mi([],lemma.Con.lemma_name)); B.skip; - B.b_kw "is contradictory, hence" ] - | _ -> assert false) in - (* let body = proof2pres {proof with Con.proof_context = tl} in *) - make_row arg proof_conclusion - - and andind conclude = - let proof,case_arg = - (match conclude.Con.conclude_args with - [Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg - | _ -> assert false; - (* - List.map (ContentPp.parg 0) conclude.Con.conclude_args; - assert false *)) in - let arg = - (match case_arg with - Con.Aux n -> assert false - | Con.Premise prem -> - (match prem.Con.premise_binder with - None -> [] - | Some n -> [(B.b_kw "by"); B.b_space; B.Object([], P.Mi([],n))]) - | Con.Lemma lemma -> - [(B.b_kw "by");B.skip; - B.Object([], P.Mi([],lemma.Con.lemma_name))] - | _ -> assert false) in - match proof.Con.proof_context with - `Hypothesis hyp1::`Hypothesis hyp2::tl -> - let get_name hyp = - (match hyp.Con.dec_name with - None -> "_" - | Some s -> s) in - let preshyp1 = - B.H ([], - [B.Text([],"("); - B.Object ([], P.Mi([],get_name hyp1)); - B.Text([],")"); - B.skip; - term2pres hyp1.Con.dec_type]) in - let preshyp2 = - B.H ([], - [B.Text([],"("); - B.Object ([], P.Mi([],get_name hyp2)); - B.Text([],")"); - B.skip; - term2pres hyp2.Con.dec_type]) in - (* let body = proof2pres {proof with Con.proof_context = tl} in *) - let body = conclude2pres proof.Con.proof_conclude false true in - let presacontext = - acontext2pres proof.Con.proof_apply_context body false in - B.V - ([], - [B.H ([],arg@[B.skip; B.b_kw "we have"]); - preshyp1; - B.b_kw "and"; - preshyp2; - presacontext]); - | _ -> assert false - - and exists conclude = - let proof = - (match conclude.Con.conclude_args with - [Con.Aux(n);_;Con.ArgProof proof;_] -> proof - | _ -> assert false; - (* - List.map (ContentPp.parg 0) conclude.Con.conclude_args; - assert false *)) in - match proof.Con.proof_context with - `Declaration decl::`Hypothesis hyp::tl - | `Hypothesis decl::`Hypothesis hyp::tl -> - let get_name decl = - (match decl.Con.dec_name with - None -> "_" - | Some s -> s) in - let presdecl = - B.H ([], - [(B.b_kw "let"); - B.skip; - B.Object ([], P.Mi([],get_name decl)); - B.Text([],":"); term2pres decl.Con.dec_type]) in - let suchthat = - B.H ([], - [(B.b_kw "such that"); - B.skip; - B.Text([],"("); - B.Object ([], P.Mi([],get_name hyp)); - B.Text([],")"); - B.skip; - term2pres hyp.Con.dec_type]) in - (* let body = proof2pres {proof with Con.proof_context = tl} in *) - let body = conclude2pres proof.Con.proof_conclude false true in - let presacontext = - acontext2pres proof.Con.proof_apply_context body false in - B.V - ([], - [presdecl; - suchthat; - presacontext]); - | _ -> assert false - - in - proof2pres p - -exception ToDo - -let counter = ref 0 - -let conjecture2pres term2pres (id, n, context, ty) = - B.b_indent - (B.b_hv [Some "helm", "xref", id] - ((B.b_toggle [ - B.b_h [] [B.b_text [] "{...}"; B.b_space]; - B.b_hv [] (List.map - (function - | None -> - B.b_h [] - [ B.b_object (p_mi [] "_") ; - B.b_object (p_mo [] ":?") ; - B.b_object (p_mi [] "_")] - | Some (`Declaration d) - | Some (`Hypothesis d) -> - let { Content.dec_name = - dec_name ; Content.dec_type = ty } = d - in - B.b_h [] - [ B.b_object - (p_mi [] - (match dec_name with - None -> "_" - | Some n -> n)); - B.b_text [] ":"; - term2pres ty ] - | Some (`Definition d) -> - let - { Content.def_name = def_name ; - Content.def_term = bo } = d - in - B.b_h [] - [ B.b_object (p_mi [] - (match def_name with - None -> "_" - | Some n -> n)) ; - B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign"); - term2pres bo] - | Some (`Proof p) -> - let proof_name = p.Content.proof_name in - B.b_h [] - [ B.b_object (p_mi [] - (match proof_name with - None -> "_" - | Some n -> n)) ; - B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign"); - proof2pres term2pres p]) - (List.rev context)) ] :: - [ B.b_h [] - [ B.b_text [] (Utf8Macro.unicode_of_tex "\\vdash"); - B.b_object (p_mi [] (string_of_int n)) ; - B.b_text [] ":" ; - term2pres ty ]]))) - -let metasenv2pres term2pres = function - | None -> [] - | Some metasenv' -> - (* Conjectures are in their own table to make *) - (* diffing the DOM trees easier. *) - [B.b_v [] - ((B.b_kw ("Conjectures:" ^ - (let _ = incr counter; in (string_of_int !counter)))) :: - (List.map (conjecture2pres term2pres) metasenv'))] - -let params2pres params = - let param2pres uri = - B.b_text [Some "xlink", "href", UriManager.string_of_uri uri] - (UriManager.name_of_uri uri) - in - let rec spatiate = function - | [] -> [] - | hd :: [] -> [hd] - | hd :: tl -> hd :: B.b_text [] ", " :: spatiate tl - in - match params with - | [] -> [] - | p -> - let params = spatiate (List.map param2pres p) in - [B.b_space; - B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])] - -let recursion_kind2pres params kind = - let kind = - match kind with - | `Recursive _ -> "Recursive definition" - | `CoRecursive -> "CoRecursive definition" - | `Inductive _ -> "Inductive definition" - | `CoInductive _ -> "CoInductive definition" - in - B.b_h [] (B.b_kw kind :: params2pres params) - -let inductive2pres term2pres ind = - let constructor2pres decl = - B.b_h [] [ - B.b_text [] ("| " ^ get_name decl.Content.dec_name ^ ":"); - B.b_space; - term2pres decl.Content.dec_type - ] - in - B.b_v [] - (B.b_h [] [ - B.b_kw (ind.Content.inductive_name ^ " of arity"); - B.smallskip; - term2pres ind.Content.inductive_type ] - :: List.map constructor2pres ind.Content.inductive_constructors) - -let joint_def2pres term2pres def = - match def with - | `Inductive ind -> inductive2pres term2pres ind - | _ -> assert false (* ZACK or raise ToDo? *) - -let content2pres term2pres (id,params,metasenv,obj) = - match obj with - | `Def (Content.Const, thesis, `Proof p) -> - let name = get_name p.Content.proof_name in - B.b_v - [Some "helm","xref","id"] - ([ B.b_h [] (B.b_kw ("Proof " ^ name) :: params2pres params); - B.b_kw "Thesis:"; - B.indent (term2pres thesis) ] @ - metasenv2pres term2pres metasenv @ - [proof2pres term2pres p]) - | `Def (_, ty, `Definition body) -> - let name = get_name body.Content.def_name in - B.b_v - [Some "helm","xref","id"] - ([B.b_h [] (B.b_kw ("Definition " ^ name) :: params2pres params); - B.b_kw "Type:"; - B.indent (term2pres ty)] @ - metasenv2pres term2pres metasenv @ - [B.b_kw "Body:"; term2pres body.Content.def_term]) - | `Decl (_, `Declaration decl) - | `Decl (_, `Hypothesis decl) -> - let name = get_name decl.Content.dec_name in - B.b_v - [Some "helm","xref","id"] - ([B.b_h [] (B.b_kw ("Axiom " ^ name) :: params2pres params); - B.b_kw "Type:"; - B.indent (term2pres decl.Content.dec_type)] @ - metasenv2pres term2pres metasenv) - | `Joint joint -> - B.b_v [] - (recursion_kind2pres params joint.Content.joint_kind - :: List.map (joint_def2pres term2pres) joint.Content.joint_defs) - | _ -> raise ToDo - -let content2pres ~ids_to_inner_sorts = - content2pres - (fun annterm -> - let ast, ids_to_uris = - TermAcicContent.ast_of_acic ids_to_inner_sorts annterm - in - CicNotationPres.box_of_mpres - (CicNotationPres.render ids_to_uris - (TermContentPres.pp_ast ast))) - diff --git a/helm/ocaml/content_pres/content2pres.mli b/helm/ocaml/content_pres/content2pres.mli deleted file mode 100644 index 793c31a4f..000000000 --- a/helm/ocaml/content_pres/content2pres.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 27/6/2003 *) -(* *) -(**************************************************************************) - -val content2pres: - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - Cic.annterm Content.cobj -> - CicNotationPres.boxml_markup - diff --git a/helm/ocaml/content_pres/content2presMatcher.ml b/helm/ocaml/content_pres/content2presMatcher.ml deleted file mode 100644 index 7e080ea69..000000000 --- a/helm/ocaml/content_pres/content2presMatcher.ml +++ /dev/null @@ -1,233 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt -module Env = CicNotationEnv -module Pp = CicNotationPp -module Util = CicNotationUtil - -let get_tag term0 = - let subterms = ref [] in - let map_term t = - subterms := t :: !subterms ; - Ast.Implicit - in - let rec aux t = CicNotationUtil.visit_ast ~special_k map_term t - and special_k = function - | Ast.AttributedTerm (_, t) -> aux t - | _ -> assert false - in - let term_mask = aux term0 in - let tag = Hashtbl.hash term_mask in - tag, List.rev !subterms - -module Matcher21 = -struct - module Pattern21 = - struct - type pattern_t = Ast.term - type term_t = Ast.term - let rec classify = function - | Ast.AttributedTerm (_, t) -> classify t - | Ast.Variable _ -> PatternMatcher.Variable - | Ast.Magic _ - | Ast.Layout _ - | Ast.Literal _ -> assert false - | _ -> PatternMatcher.Constructor - let tag_of_pattern = get_tag - let tag_of_term t = get_tag t - let string_of_term = CicNotationPp.pp_term - let string_of_pattern = CicNotationPp.pp_term - end - - module M = PatternMatcher.Matcher (Pattern21) - - let extract_magic term = - let magic_map = ref [] in - let add_magic m = - let name = Util.fresh_name () in - magic_map := (name, m) :: !magic_map; - Ast.Variable (Ast.TermVar name) - in - let rec aux = function - | Ast.AttributedTerm (_, t) -> assert false - | Ast.Literal _ - | Ast.Layout _ -> assert false - | Ast.Variable v -> Ast.Variable v - | Ast.Magic m -> add_magic m - | t -> Util.visit_ast aux t - in - let term' = aux term in - term', !magic_map - - let env_of_matched pl tl = - try - List.map2 - (fun p t -> - match p, t with - Ast.Variable (Ast.TermVar name), _ -> - name, (Env.TermType, Env.TermValue t) - | Ast.Variable (Ast.NumVar name), (Ast.Num (s, _)) -> - name, (Env.NumType, Env.NumValue s) - | Ast.Variable (Ast.IdentVar name), (Ast.Ident (s, None)) -> - name, (Env.StringType, Env.StringValue s) - | _ -> assert false) - pl tl - with Invalid_argument _ -> assert false - - let rec compiler rows = - let rows', magic_maps = - List.split - (List.map - (fun (p, pid) -> - let p', map = extract_magic p in - (p', pid), (pid, map)) - rows) - in - let magichecker map = - List.fold_left - (fun f (name, m) -> - let m_checker = compile_magic m in - (fun env ctors -> - match m_checker (Env.lookup_term env name) env ctors with - | None -> None - | Some (env, ctors) -> f env ctors)) - (fun env ctors -> Some (env, ctors)) - map - in - let magichooser candidates = - List.fold_left - (fun f (pid, pl, checker) -> - (fun matched_terms constructors -> - let env = env_of_matched pl matched_terms in - match checker env constructors with - | None -> f matched_terms constructors - | Some (env, ctors') -> - let magic_map = - try List.assoc pid magic_maps with Not_found -> assert false - in - let env' = Env.remove_names env (List.map fst magic_map) in - Some (env', ctors', pid))) - (fun _ _ -> None) - (List.rev candidates) - in - let match_cb rows = - let candidates = - List.map - (fun (pl, pid) -> - let magic_map = - try List.assoc pid magic_maps with Not_found -> assert false - in - pid, pl, magichecker magic_map) - rows - in - magichooser candidates - in - M.compiler rows' match_cb (fun _ -> None) - - and compile_magic = function - | Ast.Fold (kind, p_base, names, p_rec) -> - let p_rec_decls = Env.declarations_of_term p_rec in - (* LUCA: p_rec_decls should not contain "names" *) - let acc_name = try List.hd names with Failure _ -> assert false in - let compiled_base = compiler [p_base, 0] - and compiled_rec = compiler [p_rec, 0] in - (fun term env ctors -> - let aux_base term = - match compiled_base term with - | None -> None - | Some (env', ctors', _) -> Some (env', ctors', []) - in - let rec aux term = - match compiled_rec term with - | None -> aux_base term - | Some (env', ctors', _) -> - begin - let acc = Env.lookup_term env' acc_name in - let env'' = Env.remove_name env' acc_name in - match aux acc with - | None -> aux_base term - | Some (base_env, ctors', rec_envl) -> - let ctors'' = ctors' @ ctors in - Some (base_env, ctors'',env'' :: rec_envl) - end - in - match aux term with - | None -> None - | Some (base_env, ctors, rec_envl) -> - let env' = - base_env @ Env.coalesce_env p_rec_decls rec_envl @ env - (* @ env LUCA!!! *) - in - Some (env', ctors)) - - | Ast.Default (p_some, p_none) -> (* p_none can't bound names *) - let p_some_decls = Env.declarations_of_term p_some in - let p_none_decls = Env.declarations_of_term p_none in - let p_opt_decls = - List.filter - (fun decl -> not (List.mem decl p_none_decls)) - p_some_decls - in - let none_env = List.map Env.opt_binding_of_name p_opt_decls in - let compiled = compiler [p_some, 0] in - (fun term env ctors -> - match compiled term with - | None -> Some (none_env, ctors) (* LUCA: @ env ??? *) - | Some (env', ctors', 0) -> - let env' = - List.map - (fun (name, (ty, v)) as binding -> - if List.exists (fun (name', _) -> name = name') p_opt_decls - then Env.opt_binding_some binding - else binding) - env' - in - Some (env' @ env, ctors' @ ctors) - | _ -> assert false) - - | Ast.If (p_test, p_true, p_false) -> - let compiled_test = compiler [p_test, 0] - and compiled_true = compiler [p_true, 0] - and compiled_false = compiler [p_false, 0] in - (fun term env ctors -> - let branch = - match compiled_test term with - | None -> compiled_false - | Some _ -> compiled_true - in - match branch term with - | None -> None - | Some (env', ctors', _) -> Some (env' @ env, ctors' @ ctors)) - - | Ast.Fail -> (fun _ _ _ -> None) - - | _ -> assert false -end - diff --git a/helm/ocaml/content_pres/content2presMatcher.mli b/helm/ocaml/content_pres/content2presMatcher.mli deleted file mode 100644 index 86b97b6d8..000000000 --- a/helm/ocaml/content_pres/content2presMatcher.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -module Matcher21: -sig - (** @param l2_patterns level 2 (AST) patterns *) - val compiler : - (CicNotationPt.term * int) list -> - (CicNotationPt.term -> - (CicNotationEnv.t * CicNotationPt.term list * int) option) -end - diff --git a/helm/ocaml/content_pres/mpresentation.ml b/helm/ocaml/content_pres/mpresentation.ml deleted file mode 100644 index 1aa5db129..000000000 --- a/helm/ocaml/content_pres/mpresentation.ml +++ /dev/null @@ -1,258 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 16/62003 *) -(* *) -(**************************************************************************) - -(* $Id$ *) - -type 'a mpres = - Mi of attr * string - | Mn of attr * string - | Mo of attr * string - | Mtext of attr * string - | Mspace of attr - | Ms of attr * string - | Mgliph of attr * string - | Mrow of attr * 'a mpres list - | Mfrac of attr * 'a mpres * 'a mpres - | Msqrt of attr * 'a mpres - | Mroot of attr * 'a mpres * 'a mpres - | Mstyle of attr * 'a mpres - | Merror of attr * 'a mpres - | Mpadded of attr * 'a mpres - | Mphantom of attr * 'a mpres - | Mfenced of attr * 'a mpres list - | Menclose of attr * 'a mpres - | Msub of attr * 'a mpres * 'a mpres - | Msup of attr * 'a mpres * 'a mpres - | Msubsup of attr * 'a mpres * 'a mpres *'a mpres - | Munder of attr * 'a mpres * 'a mpres - | Mover of attr * 'a mpres * 'a mpres - | Munderover of attr * 'a mpres * 'a mpres *'a mpres -(* | Multiscripts of ??? NOT IMPLEMEMENTED *) - | Mtable of attr * 'a row list - | Maction of attr * 'a mpres list - | Mobject of attr * 'a -and 'a row = Mtr of attr * 'a mtd list -and 'a mtd = Mtd of attr * 'a mpres -and attr = (string option * string * string) list -;; - -let smallskip = Mspace([None,"width","0.5em"]);; -let indentation = Mspace([None,"width","1em"]);; - -let indented elem = - Mrow([],[indentation;elem]);; - -let standard_tbl_attr = - [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"] -;; - -let two_rows_table attr a b = - Mtable(attr@standard_tbl_attr, - [Mtr([],[Mtd([],a)]); - Mtr([],[Mtd([],b)])]);; - -let two_rows_table_with_brackets attr a b op = - (* only the open bracket is added; the closed bracket must be in b *) - Mtable(attr@standard_tbl_attr, - [Mtr([],[Mtd([],Mrow([],[Mtext([],"(");a]))]); - Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);; - -let two_rows_table_without_brackets attr a b op = - Mtable(attr@standard_tbl_attr, - [Mtr([],[Mtd([],a)]); - Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);; - -let row_with_brackets attr a b op = - (* by analogy with two_rows_table_with_brackets we only add the - open brackets *) - Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")]) - -let row_without_brackets attr a b op = - Mrow(attr,[a;op;b]) - -(* MathML prefix *) -let prefix = "m";; - -let print_mpres obj_printer mpres = - let module X = Xml in - let rec aux = - function - Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s) - | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s) - | Mo (attr,s) -> - let s = - let len = String.length s in - if len > 1 && s.[0] = '\\' - then String.sub s 1 (len - 1) - else s - in - X.xml_nempty ~prefix "mo" attr (X.xml_cdata s) - | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s) - | Mspace attr -> X.xml_empty ~prefix "mspace" attr - | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s) - | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s) - (* General Layout Schemata *) - | Mrow (attr,l) -> - X.xml_nempty ~prefix "mrow" attr - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) - >] - | Mfrac (attr,m1,m2) -> - X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >] - | Msqrt (attr,m) -> - X.xml_nempty ~prefix "msqrt" attr [< aux m >] - | Mroot (attr,m1,m2) -> - X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >] - | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >] - | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >] - | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >] - | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >] - | Mfenced (attr,l) -> - X.xml_nempty ~prefix "mfenced" attr - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) - >] - | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >] - (* Script and Limit Schemata *) - | Msub (attr,m1,m2) -> - X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >] - | Msup (attr,m1,m2) -> - X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >] - | Msubsup (attr,m1,m2,m3) -> - X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >] - | Munder (attr,m1,m2) -> - X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >] - | Mover (attr,m1,m2) -> - X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >] - | Munderover (attr,m1,m2,m3) -> - X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >] - (* | Multiscripts of ??? NOT IMPLEMEMENTED *) - (* Tables and Matrices *) - | Mtable (attr, rl) -> - X.xml_nempty ~prefix "mtable" attr - [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >] - (* Enlivening Expressions *) - | Maction (attr, l) -> - X.xml_nempty ~prefix "maction" attr - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >] - | Mobject (attr, obj) -> - let box_stream = obj_printer obj in - X.xml_nempty ~prefix "semantics" attr - [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"] - box_stream >] - - and aux_mrow = - let module X = Xml in - function - Mtr (attr, l) -> - X.xml_nempty ~prefix "mtr" attr - [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>]) - >] - and aux_mtd = - let module X = Xml in - function - Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr - [< (aux m) ; - X.xml_nempty ~prefix "mphantom" [] - (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >] - in - aux mpres -;; - -let document_of_mpres pres = - [< Xml.xml_cdata "\n" ; - Xml.xml_cdata "\n"; - Xml.xml_nempty ~prefix "math" - [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ; - Some "xmlns","helm","http://www.cs.unibo.it/helm" ; - Some "xmlns","xlink","http://www.w3.org/1999/xlink" - ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None, - "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres)) - >] - -let get_attr = function - | Maction (attr, _) - | Menclose (attr, _) - | Merror (attr, _) - | Mfenced (attr, _) - | Mfrac (attr, _, _) - | Mgliph (attr, _) - | Mi (attr, _) - | Mn (attr, _) - | Mo (attr, _) - | Mobject (attr, _) - | Mover (attr, _, _) - | Mpadded (attr, _) - | Mphantom (attr, _) - | Mroot (attr, _, _) - | Mrow (attr, _) - | Ms (attr, _) - | Mspace attr - | Msqrt (attr, _) - | Mstyle (attr, _) - | Msub (attr, _, _) - | Msubsup (attr, _, _, _) - | Msup (attr, _, _) - | Mtable (attr, _) - | Mtext (attr, _) - | Munder (attr, _, _) - | Munderover (attr, _, _, _) -> - attr - -let set_attr attr = function - | Maction (_, x) -> Maction (attr, x) - | Menclose (_, x) -> Menclose (attr, x) - | Merror (_, x) -> Merror (attr, x) - | Mfenced (_, x) -> Mfenced (attr, x) - | Mfrac (_, x, y) -> Mfrac (attr, x, y) - | Mgliph (_, x) -> Mgliph (attr, x) - | Mi (_, x) -> Mi (attr, x) - | Mn (_, x) -> Mn (attr, x) - | Mo (_, x) -> Mo (attr, x) - | Mobject (_, x) -> Mobject (attr, x) - | Mover (_, x, y) -> Mover (attr, x, y) - | Mpadded (_, x) -> Mpadded (attr, x) - | Mphantom (_, x) -> Mphantom (attr, x) - | Mroot (_, x, y) -> Mroot (attr, x, y) - | Mrow (_, x) -> Mrow (attr, x) - | Ms (_, x) -> Ms (attr, x) - | Mspace _ -> Mspace attr - | Msqrt (_, x) -> Msqrt (attr, x) - | Mstyle (_, x) -> Mstyle (attr, x) - | Msub (_, x, y) -> Msub (attr, x, y) - | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z) - | Msup (_, x, y) -> Msup (attr, x, y) - | Mtable (_, x) -> Mtable (attr, x) - | Mtext (_, x) -> Mtext (attr, x) - | Munder (_, x, y) -> Munder (attr, x, y) - | Munderover (_, x, y, z) -> Munderover (attr, x, y, z) - diff --git a/helm/ocaml/content_pres/mpresentation.mli b/helm/ocaml/content_pres/mpresentation.mli deleted file mode 100644 index 8252517a6..000000000 --- a/helm/ocaml/content_pres/mpresentation.mli +++ /dev/null @@ -1,86 +0,0 @@ -(* 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/. - *) - -type 'a mpres = - (* token elements *) - Mi of attr * string - | Mn of attr * string - | Mo of attr * string - | Mtext of attr * string - | Mspace of attr - | Ms of attr * string - | Mgliph of attr * string - (* General Layout Schemata *) - | Mrow of attr * 'a mpres list - | Mfrac of attr * 'a mpres * 'a mpres - | Msqrt of attr * 'a mpres - | Mroot of attr * 'a mpres * 'a mpres - | Mstyle of attr * 'a mpres - | Merror of attr * 'a mpres - | Mpadded of attr * 'a mpres - | Mphantom of attr * 'a mpres - | Mfenced of attr * 'a mpres list - | Menclose of attr * 'a mpres - (* Script and Limit Schemata *) - | Msub of attr * 'a mpres * 'a mpres - | Msup of attr * 'a mpres * 'a mpres - | Msubsup of attr * 'a mpres * 'a mpres *'a mpres - | Munder of attr * 'a mpres * 'a mpres - | Mover of attr * 'a mpres * 'a mpres - | Munderover of attr * 'a mpres * 'a mpres *'a mpres - (* Tables and Matrices *) - | Mtable of attr * 'a row list - (* Enlivening Expressions *) - | Maction of attr * 'a mpres list - (* Embedding *) - | Mobject of attr * 'a - -and 'a row = Mtr of attr * 'a mtd list - -and 'a mtd = Mtd of attr * 'a mpres - - (** XML attribute: namespace, name, value *) -and attr = (string option * string * string) list - -;; - -val get_attr: 'a mpres -> attr -val set_attr: attr -> 'a mpres -> 'a mpres - -val smallskip : 'a mpres -val indented : 'a mpres -> 'a mpres -val standard_tbl_attr : attr -val two_rows_table : attr -> 'a mpres -> 'a mpres -> 'a mpres -val two_rows_table_with_brackets : - attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres -val two_rows_table_without_brackets : - attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres -val row_with_brackets : - attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres -val row_without_brackets : - attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres -val print_mpres : ('a -> Xml.token Stream.t) -> 'a mpres -> Xml.token Stream.t -val document_of_mpres : 'a mpres -> Xml.token Stream.t - diff --git a/helm/ocaml/content_pres/renderingAttrs.ml b/helm/ocaml/content_pres/renderingAttrs.ml deleted file mode 100644 index 256238d3d..000000000 --- a/helm/ocaml/content_pres/renderingAttrs.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type xml_attribute = string option * string * string -type markup = [ `MathML | `BoxML ] - -let color1 = "blue" -(* let color2 = "red" *) -let color2 = "blue" - -let keyword_attributes = function - | `MathML -> [ None, "mathcolor", color1 ] - | `BoxML -> [ None, "color", color1 ] - -let builtin_symbol_attributes = function - | `MathML -> [ None, "mathcolor", color1 ] - | `BoxML -> [ None, "color", color1 ] - -let object_keyword_attributes = function - | `MathML -> [ None, "mathcolor", color2 ] - | `BoxML -> [ None, "color", color2 ] - -let symbol_attributes _ = [] -let ident_attributes _ = [] -let number_attributes _ = [] - -let spacing_attributes _ = [ None, "spacing", "0.5em" ] -let indent_attributes _ = [ None, "indent", "0.5em" ] -let small_skip_attributes _ = [ None, "width", "0.5em" ] - diff --git a/helm/ocaml/content_pres/renderingAttrs.mli b/helm/ocaml/content_pres/renderingAttrs.mli deleted file mode 100644 index 64323598b..000000000 --- a/helm/ocaml/content_pres/renderingAttrs.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(** XML attributes for MathML/BoxML rendering of terms and objects - * markup defaults to MathML in all functions below *) - -type xml_attribute = string option * string * string -type markup = [ `MathML | `BoxML ] - -(** High-level attributes *) - -val keyword_attributes: (* let, match, in, ... *) - markup -> xml_attribute list - -val builtin_symbol_attributes: (* \\Pi, \\to, ... *) - markup -> xml_attribute list - -val symbol_attributes: (* +, *, ... *) - markup -> xml_attribute list - -val ident_attributes: (* nat, plus, ... *) - markup -> xml_attribute list - -val number_attributes: (* 1, 2, ... *) - markup -> xml_attribute list - -val object_keyword_attributes: (* Body, Definition, ... *) - markup -> xml_attribute list - -(** Low-level attributes *) - -val spacing_attributes: markup -> xml_attribute list -val indent_attributes: markup -> xml_attribute list -val small_skip_attributes: markup -> xml_attribute list - diff --git a/helm/ocaml/content_pres/sequent2pres.ml b/helm/ocaml/content_pres/sequent2pres.ml deleted file mode 100644 index 88c804b7d..000000000 --- a/helm/ocaml/content_pres/sequent2pres.ml +++ /dev/null @@ -1,106 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 19/11/2003 *) -(* *) -(***************************************************************************) - -(* $Id$ *) - -let p_mtr a b = Mpresentation.Mtr(a,b) -let p_mtd a b = Mpresentation.Mtd(a,b) -let p_mtable a b = Mpresentation.Mtable(a,b) -let p_mtext a b = Mpresentation.Mtext(a,b) -let p_mi a b = Mpresentation.Mi(a,b) -let p_mo a b = Mpresentation.Mo(a,b) -let p_mrow a b = Mpresentation.Mrow(a,b) -let p_mphantom a b = Mpresentation.Mphantom(a,b) -let b_ink a = Box.Ink a - -module K = Content -module P = Mpresentation - -let sequent2pres term2pres (_,_,context,ty) = - let context2pres context = - let rec aux accum = - function - [] -> accum - | None::tl -> aux accum tl - | (Some (`Declaration d))::tl -> - let - { K.dec_name = dec_name ; - K.dec_id = dec_id ; - K.dec_type = ty } = d in - let r = - Box.b_h [Some "helm", "xref", dec_id] - [ Box.b_object (p_mi [] - (match dec_name with - None -> "_" - | Some n -> n)) ; - Box.b_text [] ":" ; - term2pres ty] in - aux (r::accum) tl - | (Some (`Definition d))::tl -> - let - { K.def_name = def_name ; - K.def_id = def_id ; - K.def_term = bo } = d in - let r = - Box.b_h [Some "helm", "xref", def_id] - [ Box.b_object (p_mi [] - (match def_name with - None -> "_" - | Some n -> n)) ; - Box.b_text [] (Utf8Macro.unicode_of_tex "\\def") ; - term2pres bo] in - aux (r::accum) tl - | _::_ -> assert false in - aux [] context in - let pres_context = (Box.b_v [] (context2pres context)) in - let pres_goal = term2pres ty in - (Box.b_h [] [ - Box.b_space; - (Box.b_v [] - [Box.b_space; - pres_context; - b_ink [None,"width","4cm"; None,"height","2px"]; (* sequent line *) - Box.b_space; - pres_goal])]) - -let sequent2pres ~ids_to_inner_sorts = - sequent2pres - (fun annterm -> - let ast, ids_to_uris = - TermAcicContent.ast_of_acic ids_to_inner_sorts annterm - in - CicNotationPres.box_of_mpres - (CicNotationPres.render ids_to_uris - (TermContentPres.pp_ast ast))) - diff --git a/helm/ocaml/content_pres/sequent2pres.mli b/helm/ocaml/content_pres/sequent2pres.mli deleted file mode 100644 index 615c8e35f..000000000 --- a/helm/ocaml/content_pres/sequent2pres.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 19/11/2003 *) -(* *) -(***************************************************************************) - -val sequent2pres : - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - Cic.annterm Content.conjecture -> - CicNotationPres.boxml_markup - diff --git a/helm/ocaml/content_pres/termContentPres.ml b/helm/ocaml/content_pres/termContentPres.ml deleted file mode 100644 index 4c8bbc7d4..000000000 --- a/helm/ocaml/content_pres/termContentPres.ml +++ /dev/null @@ -1,649 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt -module Env = CicNotationEnv - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) else () - -type pattern_id = int -type pretty_printer_id = pattern_id - -let resolve_binder = function - | `Lambda -> "\\lambda" - | `Pi -> "\\Pi" - | `Forall -> "\\forall" - | `Exists -> "\\exists" - -let add_level_info prec assoc t = Ast.AttributedTerm (`Level (prec, assoc), t) -let add_pos_info pos t = Ast.AttributedTerm (`ChildPos pos, t) -let left_pos = add_pos_info `Left -let right_pos = add_pos_info `Right -let inner_pos = add_pos_info `Inner - -let rec top_pos t = add_level_info ~-1 Gramext.NonA (inner_pos t) -(* function - | Ast.AttributedTerm (`Level _, t) -> - add_level_info ~-1 Gramext.NonA (inner_pos t) - | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, top_pos t) - | t -> add_level_info ~-1 Gramext.NonA (inner_pos t) *) - -let rec remove_level_info = - function - | Ast.AttributedTerm (`Level _, t) -> remove_level_info t - | Ast.AttributedTerm (a, t) -> Ast.AttributedTerm (a, remove_level_info t) - | t -> t - -let add_xml_attrs attrs t = - if attrs = [] then t else Ast.AttributedTerm (`XmlAttrs attrs, t) - -let add_keyword_attrs = - add_xml_attrs (RenderingAttrs.keyword_attributes `MathML) - -let box kind spacing indent content = - Ast.Layout (Ast.Box ((kind, spacing, indent), content)) - -let hbox = box Ast.H -let vbox = box Ast.V -let hvbox = box Ast.HV -let hovbox = box Ast.HOV -let break = Ast.Layout Ast.Break -let builtin_symbol s = Ast.Literal (`Symbol s) -let keyword k = add_keyword_attrs (Ast.Literal (`Keyword k)) - -let number s = - add_xml_attrs (RenderingAttrs.number_attributes `MathML) - (Ast.Literal (`Number s)) - -let ident i = - add_xml_attrs (RenderingAttrs.ident_attributes `MathML) (Ast.Ident (i, None)) - -let ident_w_href href i = - match href with - | None -> ident i - | Some href -> - let href = UriManager.string_of_uri href in - add_xml_attrs [Some "xlink", "href", href] (ident i) - -let binder_symbol s = - add_xml_attrs (RenderingAttrs.builtin_symbol_attributes `MathML) - (builtin_symbol s) - -let string_of_sort_kind = function - | `Prop -> "Prop" - | `Set -> "Set" - | `CProp -> "CProp" - | `Type _ -> "Type" - -let pp_ast0 t k = - let rec aux = - function - | Ast.Appl ts -> - let rec aux_args pos = - function - | [] -> [] - | [ last ] -> - let last = k last in - if pos = `Left then [ left_pos last ] else [ right_pos last ] - | hd :: tl -> - (add_pos_info pos (k hd)) :: aux_args `Inner tl - in - add_level_info Ast.apply_prec Ast.apply_assoc - (hovbox true true (CicNotationUtil.dress break (aux_args `Left ts))) - | Ast.Binder (binder_kind, (id, ty), body) -> - add_level_info Ast.binder_prec Ast.binder_assoc - (hvbox false true - [ binder_symbol (resolve_binder binder_kind); - k id; builtin_symbol ":"; aux_ty ty; break; - builtin_symbol "."; right_pos (k body) ]) - | Ast.Case (what, indty_opt, outty_opt, patterns) -> - let outty_box = - match outty_opt with - | None -> [] - | Some outty -> - [ keyword "return"; break; remove_level_info (k outty)] - in - let indty_box = - match indty_opt with - | None -> [] - | Some (indty, href) -> [ keyword "in"; break; ident_w_href href indty ] - in - let match_box = - hvbox false false [ - hvbox false true [ - hvbox false true [ keyword "match"; break; top_pos (k what) ]; - break; - hvbox false true indty_box; - break; - hvbox false true outty_box - ]; - break; - keyword "with" - ] - in - let mk_case_pattern (head, href, vars) = - hbox true false (ident_w_href href head :: List.map aux_var vars) - in - let patterns' = - List.map - (fun (lhs, rhs) -> - remove_level_info - (hvbox false true [ - hbox false true [ - mk_case_pattern lhs; builtin_symbol "\\Rightarrow" ]; - break; top_pos (k rhs) ])) - patterns - in - let patterns'' = - let rec aux_patterns = function - | [] -> assert false - | [ last ] -> - [ break; - hbox false false [ - builtin_symbol "|"; - last; builtin_symbol "]" ] ] - | hd :: tl -> - [ break; hbox false false [ builtin_symbol "|"; hd ] ] - @ aux_patterns tl - in - match patterns' with - | [] -> - [ hbox false false [ builtin_symbol "["; builtin_symbol "]" ] ] - | [ one ] -> - [ hbox false false [ - builtin_symbol "["; one; builtin_symbol "]" ] ] - | hd :: tl -> - hbox false false [ builtin_symbol "["; hd ] - :: aux_patterns tl - in - add_level_info Ast.simple_prec Ast.simple_assoc - (hvbox false false [ - hvbox false false ([match_box]); break; - hbox false false [ hvbox false false patterns'' ] ]) - | Ast.Cast (bo, ty) -> - add_level_info Ast.simple_prec Ast.simple_assoc - (hvbox false true [ - builtin_symbol "("; top_pos (k bo); break; builtin_symbol ":"; - top_pos (k ty); builtin_symbol ")"]) - | Ast.LetIn (var, s, t) -> - add_level_info Ast.let_in_prec Ast.let_in_assoc - (hvbox false true [ - hvbox false true [ - keyword "let"; - hvbox false true [ - aux_var var; builtin_symbol "\\def"; break; top_pos (k s) ]; - break; keyword "in" ]; - break; - k t ]) - | Ast.LetRec (rec_kind, funs, where) -> - let rec_op = - match rec_kind with `Inductive -> "rec" | `CoInductive -> "corec" - in - let mk_fun (var, body, _) = aux_var var, k body in - let mk_funs = List.map mk_fun in - let fst_fun, tl_funs = - match mk_funs funs with hd :: tl -> hd, tl | [] -> assert false - in - let fst_row = - let (name, body) = fst_fun in - hvbox false true [ - keyword "let"; keyword rec_op; name; builtin_symbol "\\def"; break; - top_pos body ] - in - let tl_rows = - List.map - (fun (name, body) -> - [ break; - hvbox false true [ - keyword "and"; name; builtin_symbol "\\def"; break; body ] ]) - tl_funs - in - add_level_info Ast.let_in_prec Ast.let_in_assoc - ((hvbox false false - (fst_row :: List.flatten tl_rows - @ [ break; keyword "in"; break; k where ]))) - | Ast.Implicit -> builtin_symbol "?" - | Ast.Meta (n, l) -> - let local_context l = - CicNotationUtil.dress (builtin_symbol ";") - (List.map (function None -> builtin_symbol "_" | Some t -> k t) l) - in - hbox false false - ([ builtin_symbol "?"; number (string_of_int n) ] - @ (if l <> [] then local_context l else [])) - | Ast.Sort sort -> aux_sort sort - | Ast.Num _ - | Ast.Symbol _ - | Ast.Ident (_, None) | Ast.Ident (_, Some []) - | Ast.Uri (_, None) | Ast.Uri (_, Some []) - | Ast.Literal _ - | Ast.UserInput as leaf -> leaf - | t -> CicNotationUtil.visit_ast ~special_k k t - and aux_sort sort_kind = - add_xml_attrs (RenderingAttrs.keyword_attributes `MathML) - (Ast.Ident (string_of_sort_kind sort_kind, None)) - and aux_ty = function - | None -> builtin_symbol "?" - | Some ty -> k ty - and aux_var = function - | name, Some ty -> - hvbox false true [ - builtin_symbol "("; name; builtin_symbol ":"; break; k ty; - builtin_symbol ")" ] - | name, None -> name - and special_k = function - | Ast.AttributedTerm (attrs, t) -> Ast.AttributedTerm (attrs, k t) - | t -> - prerr_endline ("unexpected special: " ^ CicNotationPp.pp_term t); - assert false - in - aux t - - (* persistent state *) - -let level1_patterns21 = Hashtbl.create 211 - -let compiled21 = ref None - -let pattern21_matrix = ref [] - -let get_compiled21 () = - match !compiled21 with - | None -> assert false - | Some f -> Lazy.force f - -let set_compiled21 f = compiled21 := Some f - -let add_idrefs = - List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t)) - -let instantiate21 idrefs env l1 = - let rec subst_singleton pos env = - function - Ast.AttributedTerm (attr, t) -> - Ast.AttributedTerm (attr, subst_singleton pos env t) - | t -> CicNotationUtil.group (subst pos env t) - and subst pos env = function - | Ast.AttributedTerm (attr, t) -> -(* prerr_endline ("loosing attribute " ^ CicNotationPp.pp_attribute attr); *) - subst pos env t - | Ast.Variable var -> - let name, expected_ty = CicNotationEnv.declaration_of_var var in - let ty, value = - try - List.assoc name env - with Not_found -> - prerr_endline ("name " ^ name ^ " not found in environment"); - assert false - in - assert (CicNotationEnv.well_typed ty value); (* INVARIANT *) - (* following assertion should be a conditional that makes this - * instantiation fail *) - assert (CicNotationEnv.well_typed expected_ty value); - [ add_pos_info pos (CicNotationEnv.term_of_value value) ] - | Ast.Magic m -> subst_magic pos env m - | Ast.Literal l as t -> - let t = add_idrefs idrefs t in - (match l with - | `Keyword k -> [ add_keyword_attrs t ] - | _ -> [ t ]) - | Ast.Layout l -> [ Ast.Layout (subst_layout pos env l) ] - | t -> [ CicNotationUtil.visit_ast (subst_singleton pos env) t ] - and subst_magic pos env = function - | Ast.List0 (p, sep_opt) - | Ast.List1 (p, sep_opt) -> - let rec_decls = CicNotationEnv.declarations_of_term p in - let rec_values = - List.map (fun (n, _) -> CicNotationEnv.lookup_list env n) rec_decls - in - let values = CicNotationUtil.ncombine rec_values in - let sep = - match sep_opt with - | None -> [] - | Some l -> [ Ast.Literal l ] - in - let rec instantiate_list acc = function - | [] -> List.rev acc - | value_set :: [] -> - let env = CicNotationEnv.combine rec_decls value_set in - instantiate_list (CicNotationUtil.group (subst pos env p) :: acc) - [] - | value_set :: tl -> - let env = CicNotationEnv.combine rec_decls value_set in - let terms = subst pos env p in - instantiate_list (CicNotationUtil.group (terms @ sep) :: acc) tl - in - instantiate_list [] values - | Ast.Opt p -> - let opt_decls = CicNotationEnv.declarations_of_term p in - let env = - let rec build_env = function - | [] -> [] - | (name, ty) :: tl -> - (* assumption: if one of the value is None then all are *) - (match CicNotationEnv.lookup_opt env name with - | None -> raise Exit - | Some v -> (name, (ty, v)) :: build_env tl) - in - try build_env opt_decls with Exit -> [] - in - begin - match env with - | [] -> [] - | _ -> subst pos env p - end - | _ -> assert false (* impossible *) - and subst_layout pos env = function - | Ast.Box (kind, tl) -> - let tl' = subst_children pos env tl in - Ast.Box (kind, List.concat tl') - | l -> CicNotationUtil.visit_layout (subst_singleton pos env) l - and subst_children pos env = - function - | [] -> [] - | [ child ] -> - let pos' = - match pos with - | `Inner -> `Right - | `Left -> `Left -(* | `None -> assert false *) - | `Right -> `Right - in - [ subst pos' env child ] - | hd :: tl -> - let pos' = - match pos with - | `Inner -> `Inner - | `Left -> `Inner -(* | `None -> assert false *) - | `Right -> `Right - in - (subst pos env hd) :: subst_children pos' env tl - in - subst_singleton `Left env l1 - -let rec pp_ast1 term = - let rec pp_value = function - | CicNotationEnv.NumValue _ as v -> v - | CicNotationEnv.StringValue _ as v -> v -(* | CicNotationEnv.TermValue t when t == term -> CicNotationEnv.TermValue (pp_ast0 t pp_ast1) *) - | CicNotationEnv.TermValue t -> CicNotationEnv.TermValue (pp_ast1 t) - | CicNotationEnv.OptValue None as v -> v - | CicNotationEnv.OptValue (Some v) -> - CicNotationEnv.OptValue (Some (pp_value v)) - | CicNotationEnv.ListValue vl -> - CicNotationEnv.ListValue (List.map pp_value vl) - in - let ast_env_of_env env = - List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env - in -(* prerr_endline ("pattern matching from 2 to 1 on term " ^ CicNotationPp.pp_term term); *) - match term with - | Ast.AttributedTerm (attrs, term') -> - Ast.AttributedTerm (attrs, pp_ast1 term') - | _ -> - (match (get_compiled21 ()) term with - | None -> pp_ast0 term pp_ast1 - | Some (env, ctors, pid) -> - let idrefs = - List.flatten (List.map CicNotationUtil.get_idrefs ctors) - in - let l1 = - try - Hashtbl.find level1_patterns21 pid - with Not_found -> assert false - in - instantiate21 idrefs (ast_env_of_env env) l1) - -let load_patterns21 t = - set_compiled21 (lazy (Content2presMatcher.Matcher21.compiler t)) - -let pp_ast ast = - debug_print (lazy "pp_ast <-"); - let ast' = pp_ast1 ast in - debug_print (lazy ("pp_ast -> " ^ CicNotationPp.pp_term ast')); - ast' - -exception Pretty_printer_not_found - -let fill_pos_info l1_pattern = l1_pattern -(* let rec aux toplevel pos = - function - | Ast.Layout l -> - (match l - - | Ast.Magic m -> - Ast.Box ( - | Ast.Variable _ as t -> add_pos_info pos t - | t -> t - in - aux true l1_pattern *) - -let fresh_id = - let counter = ref ~-1 in - fun () -> - incr counter; - !counter - -let add_pretty_printer ~precedence ~associativity l2 l1 = - let id = fresh_id () in - let l1' = add_level_info precedence associativity (fill_pos_info l1) in - let l2' = CicNotationUtil.strip_attributes l2 in - Hashtbl.add level1_patterns21 id l1'; - pattern21_matrix := (l2', id) :: !pattern21_matrix; - load_patterns21 !pattern21_matrix; - id - -let remove_pretty_printer id = - (try - Hashtbl.remove level1_patterns21 id; - with Not_found -> raise Pretty_printer_not_found); - pattern21_matrix := List.filter (fun (_, id') -> id <> id') !pattern21_matrix; - load_patterns21 !pattern21_matrix - - (* presentation -> content *) - -let unopt_names names env = - let rec aux acc = function - | (name, (ty, v)) :: tl when List.mem name names -> - (match ty, v with - | Env.OptType ty, Env.OptValue (Some v) -> - aux ((name, (ty, v)) :: acc) tl - | _ -> assert false) - | hd :: tl -> aux (hd :: acc) tl - | [] -> acc - in - aux [] env - -let head_names names env = - let rec aux acc = function - | (name, (ty, v)) :: tl when List.mem name names -> - (match ty, v with - | Env.ListType ty, Env.ListValue (v :: _) -> - aux ((name, (ty, v)) :: acc) tl - | _ -> assert false) - | _ :: tl -> aux acc tl - (* base pattern may contain only meta names, thus we trash all others *) - | [] -> acc - in - aux [] env - -let tail_names names env = - let rec aux acc = function - | (name, (ty, v)) :: tl when List.mem name names -> - (match ty, v with - | Env.ListType ty, Env.ListValue (_ :: vtl) -> - aux ((name, (Env.ListType ty, Env.ListValue vtl)) :: acc) tl - | _ -> assert false) - | binding :: tl -> aux (binding :: acc) tl - | [] -> acc - in - aux [] env - -let instantiate_level2 env term = - let fresh_env = ref [] in - let lookup_fresh_name n = - try - List.assoc n !fresh_env - with Not_found -> - let new_name = CicNotationUtil.fresh_name () in - fresh_env := (n, new_name) :: !fresh_env; - new_name - in - let rec aux env term = -(* prerr_endline ("ENV " ^ CicNotationPp.pp_env env); *) - match term with - | Ast.AttributedTerm (_, term) -> aux env term - | Ast.Appl terms -> Ast.Appl (List.map (aux env) terms) - | Ast.Binder (binder, var, body) -> - Ast.Binder (binder, aux_capture_var env var, aux env body) - | Ast.Case (term, indty, outty_opt, patterns) -> - Ast.Case (aux env term, indty, aux_opt env outty_opt, - List.map (aux_branch env) patterns) - | Ast.LetIn (var, t1, t2) -> - Ast.LetIn (aux_capture_var env var, aux env t1, aux env t2) - | Ast.LetRec (kind, definitions, body) -> - Ast.LetRec (kind, List.map (aux_definition env) definitions, - aux env body) - | Ast.Uri (name, None) -> Ast.Uri (name, None) - | Ast.Uri (name, Some substs) -> - Ast.Uri (name, Some (aux_substs env substs)) - | Ast.Ident (name, Some substs) -> - Ast.Ident (name, Some (aux_substs env substs)) - | Ast.Meta (index, substs) -> Ast.Meta (index, aux_meta_substs env substs) - - | Ast.Implicit - | Ast.Ident _ - | Ast.Num _ - | Ast.Sort _ - | Ast.Symbol _ - | Ast.UserInput -> term - - | Ast.Magic magic -> aux_magic env magic - | Ast.Variable var -> aux_variable env var - - | _ -> assert false - and aux_opt env = function - | Some term -> Some (aux env term) - | None -> None - and aux_capture_var env (name, ty_opt) = (aux env name, aux_opt env ty_opt) - and aux_branch env (pattern, term) = - (aux_pattern env pattern, aux env term) - and aux_pattern env (head, hrefs, vars) = - (head, hrefs, List.map (aux_capture_var env) vars) - and aux_definition env (var, term, i) = - (aux_capture_var env var, aux env term, i) - and aux_substs env substs = - List.map (fun (name, term) -> (name, aux env term)) substs - and aux_meta_substs env meta_substs = List.map (aux_opt env) meta_substs - and aux_variable env = function - | Ast.NumVar name -> Ast.Num (Env.lookup_num env name, 0) - | Ast.IdentVar name -> Ast.Ident (Env.lookup_string env name, None) - | Ast.TermVar name -> Env.lookup_term env name - | Ast.FreshVar name -> Ast.Ident (lookup_fresh_name name, None) - | Ast.Ascription (term, name) -> assert false - and aux_magic env = function - | Ast.Default (some_pattern, none_pattern) -> - let some_pattern_names = CicNotationUtil.names_of_term some_pattern in - let none_pattern_names = CicNotationUtil.names_of_term none_pattern in - let opt_names = - List.filter - (fun name -> not (List.mem name none_pattern_names)) - some_pattern_names - in - (match opt_names with - | [] -> assert false (* some pattern must contain at least 1 name *) - | (name :: _) as names -> - (match Env.lookup_value env name with - | Env.OptValue (Some _) -> - (* assumption: if "name" above is bound to Some _, then all - * names returned by "meta_names_of" are bound to Some _ as well - *) - aux (unopt_names names env) some_pattern - | Env.OptValue None -> aux env none_pattern - | _ -> - prerr_endline (sprintf - "lookup of %s in env %s did not return an optional value" - name (CicNotationPp.pp_env env)); - assert false)) - | Ast.Fold (`Left, base_pattern, names, rec_pattern) -> - let acc_name = List.hd names in (* names can't be empty, cfr. parser *) - let meta_names = - List.filter ((<>) acc_name) - (CicNotationUtil.names_of_term rec_pattern) - in - (match meta_names with - | [] -> assert false (* as above *) - | (name :: _) as names -> - let rec instantiate_fold_left acc env' = - match Env.lookup_value env' name with - | Env.ListValue (_ :: _) -> - instantiate_fold_left - (let acc_binding = - acc_name, (Env.TermType, Env.TermValue acc) - in - aux (acc_binding :: head_names names env') rec_pattern) - (tail_names names env') - | Env.ListValue [] -> acc - | _ -> assert false - in - instantiate_fold_left (aux env base_pattern) env) - | Ast.Fold (`Right, base_pattern, names, rec_pattern) -> - let acc_name = List.hd names in (* names can't be empty, cfr. parser *) - let meta_names = - List.filter ((<>) acc_name) - (CicNotationUtil.names_of_term rec_pattern) - in - (match meta_names with - | [] -> assert false (* as above *) - | (name :: _) as names -> - let rec instantiate_fold_right env' = - match Env.lookup_value env' name with - | Env.ListValue (_ :: _) -> - let acc = instantiate_fold_right (tail_names names env') in - let acc_binding = - acc_name, (Env.TermType, Env.TermValue acc) - in - aux (acc_binding :: head_names names env') rec_pattern - | Env.ListValue [] -> aux env base_pattern - | _ -> assert false - in - instantiate_fold_right env) - | Ast.If (_, p_true, p_false) as t -> - aux env (CicNotationUtil.find_branch (Ast.Magic t)) - | Ast.Fail -> assert false - | _ -> assert false - in - aux env term - - (* initialization *) - -let _ = load_patterns21 [] - diff --git a/helm/ocaml/content_pres/termContentPres.mli b/helm/ocaml/content_pres/termContentPres.mli deleted file mode 100644 index 5ff710036..000000000 --- a/helm/ocaml/content_pres/termContentPres.mli +++ /dev/null @@ -1,52 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - - (** {2 Persistant state handling} *) - -type pretty_printer_id - -val add_pretty_printer: - precedence:int -> - associativity:Gramext.g_assoc -> - CicNotationPt.term -> (* level 2 pattern *) - CicNotationPt.term -> (* level 1 pattern *) - pretty_printer_id - -exception Pretty_printer_not_found - - (** @raise Pretty_printer_not_found *) -val remove_pretty_printer: pretty_printer_id -> unit - - (** {2 content -> pres} *) - -val pp_ast: CicNotationPt.term -> CicNotationPt.term - - (** {2 pres -> content} *) - - (** fills a term pattern instantiating variable magics *) -val instantiate_level2: - CicNotationEnv.t -> CicNotationPt.term -> - CicNotationPt.term - diff --git a/helm/ocaml/content_pres/test_lexer.ml b/helm/ocaml/content_pres/test_lexer.ml deleted file mode 100644 index b032d7f61..000000000 --- a/helm/ocaml/content_pres/test_lexer.ml +++ /dev/null @@ -1,60 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let _ = - let level = ref "2@" in - let ic = ref stdin in - let arg_spec = [ "-level", Arg.Set_string level, "set the notation level" ] in - let usage = "test_lexer [ -level level ] [ file ]" in - let open_file fname = - if !ic <> stdin then close_in !ic; - ic := open_in fname - in - Arg.parse arg_spec open_file usage; - let lexer = - match !level with - "1" -> CicNotationLexer.level1_pattern_lexer - | "2@" -> CicNotationLexer.level2_ast_lexer - | "2$" -> CicNotationLexer.level2_meta_lexer - | l -> - prerr_endline (Printf.sprintf "Unsupported level %s" l); - exit 2 - in - let token_stream = - fst (lexer.Token.tok_func (Obj.magic (Ulexing.from_utf8_channel !ic))) - in - Printf.printf "Lexing notation level %s\n" !level; flush stdout; - let rec dump () = - let (a,b) = Stream.next token_stream in - if a = "EOI" then raise Stream.Failure; - print_endline (Printf.sprintf "%s '%s'" a b); - dump () - in - try - dump () - with Stream.Failure -> () - diff --git a/helm/ocaml/extlib/.depend b/helm/ocaml/extlib/.depend deleted file mode 100644 index e2c9fc2b8..000000000 --- a/helm/ocaml/extlib/.depend +++ /dev/null @@ -1,12 +0,0 @@ -componentsConf.cmo: componentsConf.cmi -componentsConf.cmx: componentsConf.cmi -hExtlib.cmo: componentsConf.cmi hExtlib.cmi -hExtlib.cmx: componentsConf.cmx hExtlib.cmi -hMarshal.cmo: hExtlib.cmi hMarshal.cmi -hMarshal.cmx: hExtlib.cmx hMarshal.cmi -patternMatcher.cmo: patternMatcher.cmi -patternMatcher.cmx: patternMatcher.cmi -hLog.cmo: hLog.cmi -hLog.cmx: hLog.cmi -trie.cmo: trie.cmi -trie.cmx: trie.cmi diff --git a/helm/ocaml/extlib/Makefile b/helm/ocaml/extlib/Makefile deleted file mode 100644 index 4e5c9b5a9..000000000 --- a/helm/ocaml/extlib/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -PACKAGE = extlib -PREDICATES = - -INTERFACE_FILES = \ - componentsConf.mli \ - hExtlib.mli \ - hMarshal.mli \ - patternMatcher.mli \ - hLog.mli \ - trie.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/extlib/componentsConf.ml.in b/helm/ocaml/extlib/componentsConf.ml.in deleted file mode 100644 index 528e90a1c..000000000 --- a/helm/ocaml/extlib/componentsConf.ml.in +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2006, 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://helm.cs.unibo.it/ - *) - -let debug = @DEBUG@ -let profiling = debug - diff --git a/helm/ocaml/extlib/componentsConf.mli b/helm/ocaml/extlib/componentsConf.mli deleted file mode 100644 index 79462bbf4..000000000 --- a/helm/ocaml/extlib/componentsConf.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2006, 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://helm.cs.unibo.it/ - *) - -val debug: bool -val profiling: bool - diff --git a/helm/ocaml/extlib/hExtlib.ml b/helm/ocaml/extlib/hExtlib.ml deleted file mode 100644 index 5f96e0f84..000000000 --- a/helm/ocaml/extlib/hExtlib.ml +++ /dev/null @@ -1,344 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -(** PROFILING *) - -let profiling_enabled = ComponentsConf.profiling - -let profiling_printings = ref (fun () -> true) -let set_profiling_printings f = profiling_printings := f - -type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b } -let profile ?(enable = true) = - if profiling_enabled && enable then - function s -> - let total = ref 0.0 in - let profile f x = - let before = Unix.gettimeofday () in - try - let res = f x in - let after = Unix.gettimeofday () in - total := !total +. (after -. before); - res - with - exc -> - let after = Unix.gettimeofday () in - total := !total +. (after -. before); - raise exc - in - at_exit - (fun () -> - if !profiling_printings () then - prerr_endline - ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total)); - { profile = profile } - else - function _ -> { profile = fun f x -> f x } - -(** {2 Optional values} *) - -let map_option f = function None -> None | Some v -> Some (f v) -let iter_option f = function None -> () | Some v -> f v -let unopt = function None -> failwith "unopt: None" | Some v -> v - -(** {2 String processing} *) - -let split ?(sep = ' ') s = - let pieces = ref [] in - let rec aux idx = - match (try Some (String.index_from s idx sep) with Not_found -> None) with - | Some pos -> - pieces := String.sub s idx (pos - idx) :: !pieces; - aux (pos + 1) - | None -> pieces := String.sub s idx (String.length s - idx) :: !pieces - in - aux 0; - List.rev !pieces - -let trim_blanks s = - let rec find_left idx = - match s.[idx] with - | ' ' | '\t' | '\r' | '\n' -> find_left (idx + 1) - | _ -> idx - in - let rec find_right idx = - match s.[idx] with - | ' ' | '\t' | '\r' | '\n' -> find_right (idx - 1) - | _ -> idx - in - let s_len = String.length s in - let left, right = find_left 0, find_right (s_len - 1) in - String.sub s left (right - left + 1) - -(** {2 Char processing} *) - -let is_alpha c = - let code = Char.code c in - (code >= 65 && code <= 90) || (code >= 97 && code <= 122) - -let is_digit c = - let code = Char.code c in - code >= 48 && code <= 57 - -let is_blank c = - let code = Char.code c in - code = 9 || code = 10 || code = 13 || code = 32 - -let is_alphanum c = is_alpha c || is_digit c - -(** {2 List processing} *) - -let rec list_uniq ?(eq=(=)) = function - | [] -> [] - | h::[] -> [h] - | h1::h2::tl when eq h1 h2 -> list_uniq ~eq (h2 :: tl) - | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq ~eq tl - -let rec filter_map f = - function - | [] -> [] - | hd :: tl -> - (match f hd with - | None -> filter_map f tl - | Some v -> v :: filter_map f tl) - -let list_concat ?(sep = []) = - let rec aux acc = - function - | [] -> [] - | [ last ] -> List.flatten (List.rev (last :: acc)) - | hd :: tl -> aux ([sep; hd] @ acc) tl - in - aux [] - -let rec list_findopt f l = - let rec aux = function - | [] -> None - | x::tl -> - (match f x with - | None -> aux tl - | Some _ as rc -> rc) - in - aux l - -(** {2 File predicates} *) - -let is_dir fname = - try - (Unix.stat fname).Unix.st_kind = Unix.S_DIR - with Unix.Unix_error _ -> false - -let is_regular fname = - try - (Unix.stat fname).Unix.st_kind = Unix.S_REG - with Unix.Unix_error _ -> false - -let mkdir path = - let components = split ~sep:'/' path in - let rec aux where = function - | [] -> () - | piece::tl -> - let path = - if where = "" then piece else where ^ "/" ^ piece in - (try - Unix.mkdir path 0o755 - with - | Unix.Unix_error (Unix.EEXIST,_,_) -> () - | Unix.Unix_error (e,_,_) -> - raise - (Failure - ("Unix.mkdir " ^ path ^ " 0o755 :" ^ (Unix.error_message e)))); - aux path tl - in - let where = if path.[0] = '/' then "/" else "" in - aux where components - -(** {2 Filesystem} *) - -let input_file fname = - let size = (Unix.stat fname).Unix.st_size in - let buf = Buffer.create size in - let ic = open_in fname in - Buffer.add_channel buf ic size; - close_in ic; - Buffer.contents buf - -let input_all ic = - let size = 10240 in - let buf = Buffer.create size in - let s = String.create size in - (try - while true do - let bytes = input ic s 0 size in - if bytes = 0 then raise End_of_file - else Buffer.add_substring buf s 0 bytes - done - with End_of_file -> ()); - Buffer.contents buf - -let output_file ~filename ~text = - let oc = open_out filename in - output_string oc text; - close_out oc - -let blank_split s = - let len = String.length s in - let buf = Buffer.create 0 in - let rec aux acc i = - if i >= len - then begin - if Buffer.length buf > 0 - then List.rev (Buffer.contents buf :: acc) - else List.rev acc - end else begin - if is_blank s.[i] then - if Buffer.length buf > 0 then begin - let s = Buffer.contents buf in - Buffer.clear buf; - aux (s :: acc) (i + 1) - end else - aux acc (i + 1) - else begin - Buffer.add_char buf s.[i]; - aux acc (i + 1) - end - end - in - aux [] 0 - - (* Rules: * "~name" -> home dir of "name" - * "~" -> value of $HOME if defined, home dir of the current user otherwise *) -let tilde_expand s = - let get_home login = (Unix.getpwnam login).Unix.pw_dir in - let expand_one s = - let len = String.length s in - if len > 0 && s.[0] = '~' then begin - let login_len = ref 1 in - while !login_len < len && is_alphanum (s.[!login_len]) do - incr login_len - done; - let login = String.sub s 1 (!login_len - 1) in - try - let home = - if login = "" then - try Sys.getenv "HOME" with Not_found -> get_home (Unix.getlogin ()) - else - get_home login - in - home ^ String.sub s !login_len (len - !login_len) - with Not_found | Invalid_argument _ -> s - end else - s - in - String.concat " " (List.map expand_one (blank_split s)) - -let find ?(test = fun _ -> true) path = - let rec aux acc todo = - match todo with - | [] -> acc - | path :: tl -> - try - let handle = Unix.opendir path in - let dirs = ref [] in - let matching_files = ref [] in - (try - while true do - match Unix.readdir handle with - | "." | ".." -> () - | entry -> - let qentry = path ^ "/" ^ entry in - (try - if is_dir qentry then - dirs := qentry :: !dirs - else if test qentry then - matching_files := qentry :: !matching_files; - with Unix.Unix_error _ -> ()) - done - with End_of_file -> Unix.closedir handle); - aux (!matching_files @ acc) (!dirs @ tl) - with Unix.Unix_error _ -> aux acc tl - in - aux [] [path] - -let safe_remove fname = if Sys.file_exists fname then Sys.remove fname - -let is_dir_empty d = - let od = Unix.opendir d in - let rec aux () = - let name = Unix.readdir od in - if name <> "." && name <> ".." then false else aux () in - let res = try aux () with End_of_file -> true in - Unix.closedir od; - res - -let safe_rmdir d = try Unix.rmdir d with Unix.Unix_error _ -> () - -let rec rmdir_descend d = - if is_dir_empty d then - begin - safe_rmdir d; - rmdir_descend (Filename.dirname d) - end - - -(** {2 Exception handling} *) - -let finally at_end f arg = - let res = - try f arg - with exn -> at_end (); raise exn - in - at_end (); - res - -(** {2 Localized exceptions } *) - -exception Localized of Token.flocation * exn - -let loc_of_floc = function - | { Lexing.pos_cnum = loc_begin }, { Lexing.pos_cnum = loc_end } -> - (loc_begin, loc_end) - -let floc_of_loc (loc_begin, loc_end) = - let floc_begin = - { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1; - Lexing.pos_cnum = loc_begin } - in - let floc_end = { floc_begin with Lexing.pos_cnum = loc_end } in - (floc_begin, floc_end) - -let dummy_floc = floc_of_loc (-1, -1) - -let raise_localized_exception ~offset floc exn = - let (x, y) = loc_of_floc floc in - let x = offset + x in - let y = offset + y in - let flocb,floce = floc in - let floc = - { flocb with Lexing.pos_cnum = x }, { floce with Lexing.pos_cnum = y } - in - raise (Localized (floc, exn)) diff --git a/helm/ocaml/extlib/hExtlib.mli b/helm/ocaml/extlib/hExtlib.mli deleted file mode 100644 index aed9b2406..000000000 --- a/helm/ocaml/extlib/hExtlib.mli +++ /dev/null @@ -1,95 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(** {2 Optional values} *) - -val map_option: ('a -> 'b) -> 'a option -> 'b option -val iter_option: ('a -> unit) -> 'a option -> unit -val unopt: 'a option -> 'a (** @raise Failure *) - -(** {2 Filesystem} *) - -val is_dir: string -> bool (** @return true if file is a directory *) -val is_regular: string -> bool (** @return true if file is a regular file *) -val mkdir: string -> unit (** create dir and parents. @raise Failure *) -val tilde_expand: string -> string (** bash-like (head) tilde expansion *) -val safe_remove: string -> unit (** removes a file if it exists *) -val safe_rmdir: string -> unit (** removes a dir if it exists and is empty *) -val is_dir_empty: string -> bool (** checks if the dir is empty *) -val rmdir_descend: string -> unit (** rmdir -p *) - - - (** find all _files_ matching test under a filesystem root *) -val find: ?test:(string -> bool) -> string -> string list - -(** {2 File I/O} *) - -val input_file: string -> string (** read all the contents of file to string *) -val input_all: in_channel -> string (** read all the contents of a channel *) -val output_file: filename:string -> text:string -> unit (** other way round *) - -(** {2 Exception handling} *) - -val finally: (unit -> unit) -> ('a -> 'b) -> 'a -> 'b - -(** {2 Char processing} *) - -val is_alpha: char -> bool -val is_blank: char -> bool -val is_digit: char -> bool -val is_alphanum: char -> bool (** is_alpha || is_digit *) - -(** {2 String processing} *) - -val split: ?sep:char -> string -> string list (** @param sep defaults to ' ' *) -val trim_blanks: string -> string (** strip heading and trailing blanks *) - -(** {2 List processing} *) - -val list_uniq: - ?eq:('a->'a->bool) -> 'a list -> 'a list (** uniq unix filter on lists *) -val filter_map: ('a -> 'b option) -> 'a list -> 'b list (** filter + map *) -val list_concat: ?sep:'a list -> 'a list list -> 'a list (**String.concat-like*) -val list_findopt: ('a -> 'b option) -> 'a list -> 'b option - -(** {2 Debugging & Profiling} *) - -type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b } - - (** @return a profiling function; [s] is used for labelling the total time at - * the end of the execution *) -val profile : ?enable:bool -> string -> profiler -val set_profiling_printings : (unit -> bool) -> unit - -(** {2 Localized exceptions } *) - -exception Localized of Token.flocation * exn - -val loc_of_floc: Token.flocation -> int * int -val floc_of_loc: int * int -> Token.flocation - -val dummy_floc: Lexing.position * Lexing.position - -val raise_localized_exception: offset:int -> Token.flocation -> exn -> 'a diff --git a/helm/ocaml/extlib/hLog.ml b/helm/ocaml/extlib/hLog.ml deleted file mode 100644 index 4ad2b5ba4..000000000 --- a/helm/ocaml/extlib/hLog.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -type log_tag = [ `Debug | `Error | `Message | `Warning ] -type log_callback = log_tag -> string -> unit - -(* -colors=(black red green yellow blue magenta cyan gray white) -ccodes=(30 31 32 33 34 35 36 37 39) -*) - -let blue = "" -let yellow = "" -let green = "" -let red = "" -let black = "" - -let default_callback tag s = - let prefix,ch = - match tag with - | `Message -> green ^ "Info: ", stdout - | `Warning -> yellow ^ "Warn: ", stderr - | `Error -> red ^ "Error: ", stderr - | `Debug -> blue ^ "Debug: ", stderr - in - output_string ch (prefix ^ black ^ s ^ "\n"); - flush ch - -let callback = ref default_callback - -let set_log_callback f = callback := f -let get_log_callback () = !callback - -let message s = !callback `Message s -let warn s = !callback `Warning s -let error s = !callback `Error s -let debug s = !callback `Debug s - diff --git a/helm/ocaml/extlib/hLog.mli b/helm/ocaml/extlib/hLog.mli deleted file mode 100644 index 6847ce32d..000000000 --- a/helm/ocaml/extlib/hLog.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -type log_tag = [ `Debug | `Error | `Message | `Warning ] -type log_callback = log_tag -> string -> unit - -val set_log_callback: log_callback -> unit -val get_log_callback: unit -> log_callback - -val message : string -> unit -val warn : string -> unit -val error : string -> unit -val debug : string -> unit - diff --git a/helm/ocaml/extlib/hMarshal.ml b/helm/ocaml/extlib/hMarshal.ml deleted file mode 100644 index c57886819..000000000 --- a/helm/ocaml/extlib/hMarshal.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception Corrupt_file of string -exception Format_mismatch of string -exception Version_mismatch of string - -let ensure_path_exists fname = HExtlib.mkdir (Filename.dirname fname) -let marshal_flags = [] - -let save ~fmt ~version ~fname data = - ensure_path_exists fname; - let oc = open_out fname in - let marshalled = Marshal.to_string data marshal_flags in - output_binary_int oc (Hashtbl.hash fmt); (* field 1 *) - output_binary_int oc version; (* field 2 *) - output_string oc fmt; (* field 3 *) - output_string oc (string_of_int version); (* field 4 *) - output_binary_int oc (Hashtbl.hash marshalled); (* field 5 *) - output_string oc marshalled; (* field 6 *) - close_out oc - -let expect ic fname s = - let len = String.length s in - let buf = String.create len in - really_input ic buf 0 len; - if buf <> s then raise (Corrupt_file fname) - -let load ~fmt ~version ~fname = - let ic = open_in fname in - HExtlib.finally - (fun () -> close_in ic) - (fun () -> - try - let fmt' = input_binary_int ic in (* field 1 *) - if fmt' <> Hashtbl.hash fmt then raise (Format_mismatch fname); - let version' = input_binary_int ic in (* field 2 *) - if version' <> version then raise (Version_mismatch fname); - expect ic fname fmt; (* field 3 *) - expect ic fname (string_of_int version); (* field 4 *) - let checksum' = input_binary_int ic in (* field 5 *) - let marshalled' = HExtlib.input_all ic in (* field 6 *) - if checksum' <> Hashtbl.hash marshalled' then - raise (Corrupt_file fname); - Marshal.from_string marshalled' 0 - with End_of_file -> raise (Corrupt_file fname)) - () - diff --git a/helm/ocaml/extlib/hMarshal.mli b/helm/ocaml/extlib/hMarshal.mli deleted file mode 100644 index 90ce20def..000000000 --- a/helm/ocaml/extlib/hMarshal.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(** {2 Marshalling with version/consistency checks} *) - -(** {3 File formats} - * - * Files saved/loaded by this module share a common format: - * - * | n | Field name | Field type | Description | - * +---+-------------+------------+---------------------------------------+ - * | 1 | format | integer | hash value of the 'fmt' parameter | - * | 2 | version | integer | 'version' parameter | - * | 3 | format dsc | string | extended 'fmt' parameter | - * | 4 | version dsc | string | extended 'version' parameter | - * | 5 | checksum | integer | hash value of the _field_ below | - * | 6 | data | raw | ocaml marshalling of 'data' parameter | - * - *) - -exception Corrupt_file of string (** checksum mismatch, or file too short *) -exception Format_mismatch of string -exception Version_mismatch of string - - (** Marhsal some data according to the file format above. - * @param fmt format name - * @param version version number - * @param fname file name to which marshal data - * @param data data to be marshalled on disk *) -val save: fmt:string -> version:int -> fname:string -> 'a -> unit - - (** parameters as above - * @raise Corrupt_file - * @raise Format_mismatch - * @raise Version_mismatch *) -val load: fmt:string -> version:int -> fname:string -> 'a - diff --git a/helm/ocaml/extlib/patternMatcher.ml b/helm/ocaml/extlib/patternMatcher.ml deleted file mode 100644 index c1b436a97..000000000 --- a/helm/ocaml/extlib/patternMatcher.ml +++ /dev/null @@ -1,191 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -type pattern_kind = Variable | Constructor -type tag_t = int - -type pattern_id = int - -module OrderedInt = -struct - type t = int - let compare (x1:t) (x2:t) = Pervasives.compare x2 x1 (* reverse order *) -end - -module IntSet = Set.Make (OrderedInt) - -let int_set_of_int_list l = - List.fold_left (fun acc i -> IntSet.add i acc) IntSet.empty l - -module type PATTERN = -sig - type pattern_t - type term_t - val classify : pattern_t -> pattern_kind - val tag_of_pattern : pattern_t -> tag_t * pattern_t list - val tag_of_term : term_t -> tag_t * term_t list - val string_of_term: term_t -> string - val string_of_pattern: pattern_t -> string -end - -module Matcher (P: PATTERN) = -struct - type row_t = P.pattern_t list * P.pattern_t list * pattern_id - type t = row_t list - - let compatible p1 p2 = P.classify p1 = P.classify p2 - - let matched = List.map (fun (matched, _, pid) -> matched, pid) - - let partition t pidl = - let partitions = Hashtbl.create 11 in - let add pid row = Hashtbl.add partitions pid row in - (try - List.iter2 add pidl t - with Invalid_argument _ -> assert false); - let pidset = int_set_of_int_list pidl in - IntSet.fold - (fun pid acc -> - match Hashtbl.find_all partitions pid with - | [] -> acc - | patterns -> (pid, List.rev patterns) :: acc) - pidset [] - - let are_empty t = - match t with - | (_, [], _) :: _ -> true - (* if first row has an empty list of patterns, then others have as well *) - | _ -> false - - (* return 2 lists of rows, first one containing homogeneous rows according - * to "compatible" below *) - let horizontal_split t = - let ap, first_row, t', first_row_class = - match t with - | [] -> assert false - | (_, [], _) :: _ -> - assert false (* are_empty should have been invoked in advance *) - | ((_, hd :: _ , _) as row) :: tl -> hd, row, tl, P.classify hd - in - let rec aux prev_t = function - | [] -> List.rev prev_t, [] - | (_, [], _) :: _ -> assert false - | ((_, hd :: _, _) as row) :: tl when compatible ap hd -> - aux (row :: prev_t) tl - | t -> List.rev prev_t, t - in - let rows1, rows2 = aux [first_row] t' in - first_row_class, rows1, rows2 - - (* return 2 lists, first one representing first column, second one - * representing a new pattern matrix where matched patterns have been moved - * to decl *) - let vertical_split t = - List.map - (function - | decls, hd :: tl, pid -> hd :: decls, tl, pid - | _ -> assert false) - t - - let variable_closure ksucc = - (fun matched_terms constructors terms -> -(* prerr_endline "variable_closure"; *) - match terms with - | hd :: tl -> ksucc (hd :: matched_terms) constructors tl - | _ -> assert false) - - let success_closure ksucc = - (fun matched_terms constructors terms -> -(* prerr_endline "success_closure"; *) - ksucc matched_terms constructors) - - let constructor_closure ksuccs = - (fun matched_terms constructors terms -> -(* prerr_endline "constructor_closure"; *) - match terms with - | t :: tl -> - (try - let tag, subterms = P.tag_of_term t in - let constructors' = - if subterms = [] then t :: constructors else constructors - in - let k' = List.assoc tag ksuccs in - k' matched_terms constructors' (subterms @ tl) - with Not_found -> None) - | [] -> assert false) - - let backtrack_closure ksucc kfail = - (fun matched_terms constructors terms -> -(* prerr_endline "backtrack_closure"; *) - match ksucc matched_terms constructors terms with - | Some x -> Some x - | None -> kfail matched_terms constructors terms) - - let compiler rows match_cb fail_k = - let rec aux t = - if t = [] then - (fun _ _ _ -> fail_k ()) - else if are_empty t then - success_closure (match_cb (matched t)) - else - match horizontal_split t with - | _, [], _ -> assert false - | Variable, t', [] -> variable_closure (aux (vertical_split t')) - | Constructor, t', [] -> - let tagl = - List.map - (function - | _, p :: _, _ -> fst (P.tag_of_pattern p) - | _ -> assert false) - t' - in - let clusters = partition t' tagl in - let ksuccs = - List.map - (fun (tag, cluster) -> - let cluster' = - List.map (* add args as patterns heads *) - (function - | matched_p, p :: tl, pid -> - let _, subpatterns = P.tag_of_pattern p in - matched_p, subpatterns @ tl, pid - | _ -> assert false) - cluster - in - tag, aux cluster') - clusters - in - constructor_closure ksuccs - | _, t', t'' -> backtrack_closure (aux t') (aux t'') - in - let t = List.map (fun (p, pid) -> [], [p], pid) rows in - let matcher = aux t in - (fun term -> matcher [] [] [term]) -end - diff --git a/helm/ocaml/extlib/patternMatcher.mli b/helm/ocaml/extlib/patternMatcher.mli deleted file mode 100644 index 2201ddf7f..000000000 --- a/helm/ocaml/extlib/patternMatcher.mli +++ /dev/null @@ -1,62 +0,0 @@ - -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -type pattern_kind = Variable | Constructor -type tag_t = int - -module type PATTERN = -sig - type pattern_t - type term_t - - val classify : pattern_t -> pattern_kind - val tag_of_pattern : pattern_t -> tag_t * pattern_t list - val tag_of_term : term_t -> tag_t * term_t list - - (** {3 Debugging} *) - val string_of_term: term_t -> string - val string_of_pattern: pattern_t -> string -end - -module Matcher (P: PATTERN) : -sig - (** @param patterns pattern matrix (pairs ) - * @param success_cb callback invoked in case of matching. - * Its argument are the list of pattern who matches the input term, the list - * of terms bound in them, the list of terms which matched constructors. - * Its return value is Some _ if the matching is valid, None otherwise; the - * latter kind of return value will trigger backtracking in the pattern - * matching algorithm - * @param failure_cb callback invoked in case of matching failure - * @param term term on which pattern match on *) - val compiler: - (P.pattern_t * int) list -> - ((P.pattern_t list * int) list -> P.term_t list -> P.term_t list -> - 'a option) -> (* terms *) (* constructors *) - (unit -> 'a option) -> - (P.term_t -> 'a option) -end - diff --git a/helm/ocaml/extlib/trie.ml b/helm/ocaml/extlib/trie.ml deleted file mode 100644 index f60b2d45c..000000000 --- a/helm/ocaml/extlib/trie.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* - * Trie: maps over lists. - * Copyright (C) 2000 Jean-Christophe FILLIATRE - * - * This software is free software; you can redistribute it and/or - * modify it under the terms of the GNU Library General Public - * License version 2, as published by the Free Software Foundation. - * - * This software 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 Library General Public License version 2 for more details - * (enclosed in the file LGPL). - *) - -(* $Id$ *) - -(*s A trie is a tree-like structure to implement dictionaries over - keys which have list-like structures. The idea is that each node - branches on an element of the list and stores the value associated - to the path from the root, if any. Therefore, a trie can be - defined as soon as a map over the elements of the list is - given. *) - - -module Make (M : Map.S) = struct - -(*s Then a trie is just a tree-like structure, where a possible - information is stored at the node (['a option]) and where the sons - are given by a map from type [key] to sub-tries, so of type - ['a t M.t]. The empty trie is just the empty map. *) - - type key = M.key list - - type 'a t = Node of 'a option * 'a t M.t - - let empty = Node (None, M.empty) - -(*s To find a mapping in a trie is easy: when all the elements of the - key have been read, we just inspect the optional info at the - current node; otherwise, we descend in the appropriate sub-trie - using [M.find]. *) - - let rec find l t = match (l,t) with - | [], Node (None,_) -> raise Not_found - | [], Node (Some v,_) -> v - | x::r, Node (_,m) -> find r (M.find x m) - - let rec mem l t = match (l,t) with - | [], Node (None,_) -> false - | [], Node (Some _,_) -> true - | x::r, Node (_,m) -> try mem r (M.find x m) with Not_found -> false - -(*s Insertion is more subtle. When the final node is reached, we just - put the information ([Some v]). Otherwise, we have to insert the - binding in the appropriate sub-trie [t']. But it may not exists, - and in that case [t'] is bound to an empty trie. Then we get a new - sub-trie [t''] by a recursive insertion and we modify the - branching, so that it now points to [t''], with [M.add]. *) - - let add l v t = - let rec ins = function - | [], Node (_,m) -> Node (Some v,m) - | x::r, Node (v,m) -> - let t' = try M.find x m with Not_found -> empty in - let t'' = ins (r,t') in - Node (v, M.add x t'' m) - in - ins (l,t) - -(*s When removing a binding, we take care of not leaving bindings to empty - sub-tries in the nodes. Therefore, we test wether the result [t'] of - the recursive call is the empty trie [empty]: if so, we just remove - the branching with [M.remove]; otherwise, we modify it with [M.add]. *) - - let rec remove l t = match (l,t) with - | [], Node (_,m) -> Node (None,m) - | x::r, Node (v,m) -> - try - let t' = remove r (M.find x m) in - Node (v, if t' = empty then M.remove x m else M.add x t' m) - with Not_found -> - t - -(*s The iterators [map], [mapi], [iter] and [fold] are implemented in - a straigthforward way using the corresponding iterators [M.map], - [M.mapi], [M.iter] and [M.fold]. For the last three of them, - we have to remember the path from the root, as an extra argument - [revp]. Since elements are pushed in reverse order in [revp], - we have to reverse it with [List.rev] when the actual binding - has to be passed to function [f]. *) - - let rec map f = function - | Node (None,m) -> Node (None, M.map (map f) m) - | Node (Some v,m) -> Node (Some (f v), M.map (map f) m) - - let mapi f t = - let rec maprec revp = function - | Node (None,m) -> - Node (None, M.mapi (fun x -> maprec (x::revp)) m) - | Node (Some v,m) -> - Node (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x::revp)) m) - in - maprec [] t - - let iter f t = - let rec traverse revp = function - | Node (None,m) -> - M.iter (fun x -> traverse (x::revp)) m - | Node (Some v,m) -> - f (List.rev revp) v; M.iter (fun x t -> traverse (x::revp) t) m - in - traverse [] t - - let rec fold f t acc = - let rec traverse revp t acc = match t with - | Node (None,m) -> - M.fold (fun x -> traverse (x::revp)) m acc - | Node (Some v,m) -> - f (List.rev revp) v (M.fold (fun x -> traverse (x::revp)) m acc) - in - traverse [] t acc - - let compare cmp a b = - let rec comp a b = match a,b with - | Node (Some _, _), Node (None, _) -> 1 - | Node (None, _), Node (Some _, _) -> -1 - | Node (None, m1), Node (None, m2) -> - M.compare comp m1 m2 - | Node (Some a, m1), Node (Some b, m2) -> - let c = cmp a b in - if c <> 0 then c else M.compare comp m1 m2 - in - comp a b - - let equal eq a b = - let rec comp a b = match a,b with - | Node (None, m1), Node (None, m2) -> - M.equal comp m1 m2 - | Node (Some a, m1), Node (Some b, m2) -> - eq a b && M.equal comp m1 m2 - | _ -> - false - in - comp a b - - (* The base case is rather stupid, but constructable *) - let is_empty = function - | Node (None, m1) -> M.is_empty m1 - | _ -> false - -end diff --git a/helm/ocaml/extlib/trie.mli b/helm/ocaml/extlib/trie.mli deleted file mode 100644 index b95157fd0..000000000 --- a/helm/ocaml/extlib/trie.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -module Make : - functor (M : Map.S) -> - sig - type key = M.key list - type 'a t = Node of 'a option * 'a t M.t - val empty : 'a t - val find : M.key list -> 'a t -> 'a - val mem : M.key list -> 'a t -> bool - val add : M.key list -> 'a -> 'a t -> 'a t - val remove : M.key list -> 'a t -> 'a t - val map : ('a -> 'b) -> 'a t -> 'b t - val mapi : (M.key list -> 'a -> 'b) -> 'a t -> 'b t - val iter : (M.key list -> 'a -> 'b) -> 'a t -> unit - val fold : (M.key list -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val is_empty : 'a t -> bool - end diff --git a/helm/ocaml/getter/.depend b/helm/ocaml/getter/.depend deleted file mode 100644 index 20f69cf0c..000000000 --- a/helm/ocaml/getter/.depend +++ /dev/null @@ -1,31 +0,0 @@ -http_getter_env.cmi: http_getter_types.cmo -http_getter_common.cmi: http_getter_types.cmo -http_getter.cmi: http_getter_types.cmo -http_getter_wget.cmo: http_getter_types.cmo http_getter_wget.cmi -http_getter_wget.cmx: http_getter_types.cmx http_getter_wget.cmi -http_getter_logger.cmo: http_getter_logger.cmi -http_getter_logger.cmx: http_getter_logger.cmi -http_getter_misc.cmo: http_getter_logger.cmi http_getter_misc.cmi -http_getter_misc.cmx: http_getter_logger.cmx http_getter_misc.cmi -http_getter_const.cmo: http_getter_const.cmi -http_getter_const.cmx: http_getter_const.cmi -http_getter_env.cmo: http_getter_types.cmo http_getter_misc.cmi \ - http_getter_logger.cmi http_getter_const.cmi http_getter_env.cmi -http_getter_env.cmx: http_getter_types.cmx http_getter_misc.cmx \ - http_getter_logger.cmx http_getter_const.cmx http_getter_env.cmi -http_getter_storage.cmo: http_getter_wget.cmi http_getter_types.cmo \ - http_getter_misc.cmi http_getter_env.cmi http_getter_storage.cmi -http_getter_storage.cmx: http_getter_wget.cmx http_getter_types.cmx \ - http_getter_misc.cmx http_getter_env.cmx http_getter_storage.cmi -http_getter_common.cmo: http_getter_types.cmo http_getter_misc.cmi \ - http_getter_logger.cmi http_getter_env.cmi http_getter_common.cmi -http_getter_common.cmx: http_getter_types.cmx http_getter_misc.cmx \ - http_getter_logger.cmx http_getter_env.cmx http_getter_common.cmi -http_getter.cmo: http_getter_wget.cmi http_getter_types.cmo \ - http_getter_storage.cmi http_getter_misc.cmi http_getter_logger.cmi \ - http_getter_env.cmi http_getter_const.cmi http_getter_common.cmi \ - http_getter.cmi -http_getter.cmx: http_getter_wget.cmx http_getter_types.cmx \ - http_getter_storage.cmx http_getter_misc.cmx http_getter_logger.cmx \ - http_getter_env.cmx http_getter_const.cmx http_getter_common.cmx \ - http_getter.cmi diff --git a/helm/ocaml/getter/.ocamlinit b/helm/ocaml/getter/.ocamlinit deleted file mode 100644 index 6512190cd..000000000 --- a/helm/ocaml/getter/.ocamlinit +++ /dev/null @@ -1,3 +0,0 @@ -#use "topfind";; -#require "helm-getter";; -Helm_registry.load_from "sample.conf.xml";; diff --git a/helm/ocaml/getter/Makefile b/helm/ocaml/getter/Makefile deleted file mode 100644 index 0f2132eec..000000000 --- a/helm/ocaml/getter/Makefile +++ /dev/null @@ -1,21 +0,0 @@ - -PACKAGE = getter - -INTERFACE_FILES = \ - http_getter_wget.mli \ - http_getter_logger.mli \ - http_getter_misc.mli \ - http_getter_const.mli \ - http_getter_env.mli \ - http_getter_storage.mli \ - http_getter_common.mli \ - http_getter.mli \ - $(NULL) - -IMPLEMENTATION_FILES = \ - http_getter_types.ml \ - $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common - diff --git a/helm/ocaml/getter/http_getter.ml b/helm/ocaml/getter/http_getter.ml deleted file mode 100644 index 1b47a6c38..000000000 --- a/helm/ocaml/getter/http_getter.ml +++ /dev/null @@ -1,363 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open Http_getter_common -open Http_getter_misc -open Http_getter_types - -exception Not_implemented of string -exception UnexpectedGetterOutput - -type resolve_result = - | Unknown - | Exception of exn - | Resolved of string - -type logger_callback = HelmLogger.html_tag -> unit - -let stdout_logger tag = print_string (HelmLogger.string_of_html_tag tag) - -let not_implemented s = raise (Not_implemented ("Http_getter." ^ s)) - -let index_line_sep_RE = Pcre.regexp "[ \t]+" -let index_sep_RE = Pcre.regexp "\r\n|\r|\n" -let trailing_types_RE = Pcre.regexp "\\.types$" -let heading_cic_RE = Pcre.regexp "^cic:" -let heading_theory_RE = Pcre.regexp "^theory:" -let heading_nuprl_RE = Pcre.regexp "^nuprl:" -let types_RE = Pcre.regexp "\\.types$" -let types_ann_RE = Pcre.regexp "\\.types\\.ann$" -let body_RE = Pcre.regexp "\\.body$" -let body_ann_RE = Pcre.regexp "\\.body\\.ann$" -let proof_tree_RE = Pcre.regexp "\\.proof_tree$" -let proof_tree_ann_RE = Pcre.regexp "\\.proof_tree\\.ann$" -let theory_RE = Pcre.regexp "\\.theory$" -let basepart_RE = Pcre.regexp - "^([^.]*\\.[^.]*)((\\.body)|(\\.proof_tree)|(\\.types))?(\\.ann)?$" -let slash_RE = Pcre.regexp "/" -let pipe_RE = Pcre.regexp "\\|" -let til_slash_RE = Pcre.regexp "^.*/" -let no_slashes_RE = Pcre.regexp "^[^/]*$" -let fix_regexp_RE = Pcre.regexp ("^" ^ (Pcre.quote "(cic|theory)")) -let showable_file_RE = - Pcre.regexp "(\\.con|\\.ind|\\.var|\\.body|\\.types|\\.proof_tree)$" - -let xml_suffix = ".xml" -let theory_suffix = ".theory" - - (* global maps, shared by all threads *) - -let ends_with_slash s = - try - s.[String.length s - 1] = '/' - with Invalid_argument _ -> false - - (* should we use a remote getter or not *) -let remote () = - try - Helm_registry.get "getter.mode" = "remote" - with Helm_registry.Key_not_found _ -> false - -let getter_url () = Helm_registry.get "getter.url" - -(* Remote interface: getter methods implemented using a remote getter *) - - (* *) -let getxml_remote uri = not_implemented "getxml_remote" -let getxslt_remote uri = not_implemented "getxslt_remote" -let getdtd_remote uri = not_implemented "getdtd_remote" -let clean_cache_remote () = not_implemented "clean_cache_remote" -let list_servers_remote () = not_implemented "list_servers_remote" -let add_server_remote ~logger ~position name = - not_implemented "add_server_remote" -let remove_server_remote ~logger position = - not_implemented "remove_server_remote" -let getalluris_remote () = not_implemented "getalluris_remote" -let ls_remote lsuri = not_implemented "ls_remote" -let exists_remote uri = not_implemented "exists_remote" - (* *) - -let resolve_remote uri = - (* deliver resolve request to http_getter *) - let doc = - Http_getter_wget.get (sprintf "%sresolve?uri=%s" (getter_url ()) uri) - in - let res = ref Unknown in - let start_element tag attrs = - match tag with - | "url" -> - (try - res := Resolved (List.assoc "value" attrs) - with Not_found -> ()) - | "unresolvable" -> res := Exception (Unresolvable_URI uri) - | "not_found" -> res := Exception (Key_not_found uri) - | _ -> () - in - let callbacks = { - XmlPushParser.default_callbacks with - XmlPushParser.start_element = Some start_element - } in - let xml_parser = XmlPushParser.create_parser callbacks in - XmlPushParser.parse xml_parser (`String doc); - XmlPushParser.final xml_parser; - match !res with - | Unknown -> raise UnexpectedGetterOutput - | Exception e -> raise e - | Resolved url -> url - -let deref_index_theory uri = - if Http_getter_storage.exists (uri ^ xml_suffix) then uri - else if is_theory_uri uri && Filename.basename uri = "index.theory" then - strip_trailing_slash (Filename.dirname uri) ^ theory_suffix - else - uri - -(* API *) - -let help () = Http_getter_const.usage_string (Http_getter_env.env_to_string ()) - -let exists uri = -(* prerr_endline ("Http_getter.exists " ^ uri); *) - if remote () then - exists_remote uri - else - let uri = deref_index_theory uri in - Http_getter_storage.exists (uri ^ xml_suffix) - -let resolve uri = - if remote () then - resolve_remote uri - else - let uri = deref_index_theory uri in - try - Http_getter_storage.resolve (uri ^ xml_suffix) - with Http_getter_storage.Resource_not_found _ -> raise (Key_not_found uri) - -let getxml uri = - if remote () then getxml_remote uri - else begin - let uri' = deref_index_theory uri in - (try - Http_getter_storage.filename (uri' ^ xml_suffix) - with Http_getter_storage.Resource_not_found _ -> raise (Key_not_found uri)) - end - -let getxslt uri = - if remote () then getxslt_remote uri - else Http_getter_storage.filename ~find:true ("xslt:/" ^ uri) - -let getdtd uri = - if remote () then - getdtd_remote uri - else begin - let fname = Http_getter_env.get_dtd_dir () ^ "/" ^ uri in - if not (Sys.file_exists fname) then raise (Dtd_not_found uri); - fname - end - -let clean_cache () = - if remote () then - clean_cache_remote () - else - Http_getter_storage.clean_cache () - -let (++) (oldann, oldtypes, oldbody, oldtree) - (newann, newtypes, newbody, newtree) = - ((if newann > oldann then newann else oldann), - (if newtypes > oldtypes then newtypes else oldtypes), - (if newbody > oldbody then newbody else oldbody), - (if newtree > oldtree then newtree else oldtree)) - -let store_obj tbl o = -(* prerr_endline ("Http_getter.store_obj " ^ o); *) - if Pcre.pmatch ~rex:showable_file_RE o then begin - let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in - let no_flags = false, No, No, No in - let oldflags = - try - Hashtbl.find tbl basepart - with Not_found -> (* no ann, no types, no body, no proof tree *) - no_flags - in - let newflags = - match o with - | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No, No) - | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No, No) - | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes, No) - | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann, No) - | s when Pcre.pmatch ~rex:proof_tree_RE s -> (false, No, No, Yes) - | s when Pcre.pmatch ~rex:proof_tree_ann_RE s -> (true, No, No, Ann) - | s -> no_flags - in - Hashtbl.replace tbl basepart (oldflags ++ newflags) - end - -let store_dir set_ref d = - set_ref := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !set_ref - -let collect_ls_items dirs_set objs_tbl = - let items = ref [] in - StringSet.iter (fun dir -> items := Ls_section dir :: !items) dirs_set; - Http_getter_misc.hashtbl_sorted_iter - (fun uri (annflag, typesflag, bodyflag, treeflag) -> - items := - Ls_object { - uri = uri; ann = annflag; - types = typesflag; body = bodyflag; proof_tree = treeflag - } :: !items) - objs_tbl; - List.rev !items - -let contains_object = (<>) [] - - (** non regexp-aware version of ls *) -let rec dumb_ls uri_prefix = -(* prerr_endline ("Http_getter.dumb_ls " ^ uri_prefix); *) - if is_cic_obj_uri uri_prefix then begin - let dirs = ref StringSet.empty in - let objs = Hashtbl.create 17 in - List.iter - (fun fname -> - if ends_with_slash fname then - store_dir dirs fname - else - try - store_obj objs (strip_suffix ~suffix:xml_suffix fname) - with Invalid_argument _ -> ()) - (Http_getter_storage.ls uri_prefix); - collect_ls_items !dirs objs - end else if is_theory_uri uri_prefix then begin - let items = ref [] in - let add_theory fname = - items := - Ls_object { - uri = fname; ann = false; types = No; body = No; proof_tree = No } - :: !items - in - let cic_uri_prefix = - Pcre.replace_first ~rex:heading_theory_RE ~templ:"cic:" uri_prefix - in - List.iter - (fun fname -> - if ends_with_slash fname then - items := Ls_section (strip_trailing_slash fname) :: !items - else - try - let fname = strip_suffix ~suffix:xml_suffix fname in - let theory_name = strip_suffix ~suffix:theory_suffix fname in - let sub_theory = normalize_dir cic_uri_prefix ^ theory_name ^ "/" in - if is_empty_theory sub_theory then add_theory fname - with Invalid_argument _ -> ()) - (Http_getter_storage.ls uri_prefix); - (try - if contains_object (dumb_ls cic_uri_prefix) - && exists (strip_trailing_slash uri_prefix ^ theory_suffix) - then - add_theory "index.theory"; - with Unresolvable_URI _ -> ()); - !items - end else - raise (Invalid_URI uri_prefix) - -and is_empty_theory uri_prefix = -(* prerr_endline ("is_empty_theory " ^ uri_prefix); *) - not (contains_object (dumb_ls uri_prefix)) - - (* handle simple regular expressions of the form "...(..|..|..)..." on cic - * uris, not meant to be a real implementation of regexp. The only we use is - * "(cic|theory):/..." *) -let explode_ls_regexp regexp = - try - let len = String.length regexp in - let lparen_idx = String.index regexp '(' in - let rparen_idx = String.index_from regexp lparen_idx ')' in - let choices_str = (* substring between parens, parens excluded *) - String.sub regexp (lparen_idx + 1) (rparen_idx - lparen_idx - 1) - in - let choices = Pcre.split ~rex:pipe_RE choices_str in - let prefix = String.sub regexp 0 lparen_idx in - let suffix = String.sub regexp (rparen_idx + 1) (len - (rparen_idx + 1)) in - List.map (fun choice -> prefix ^ choice ^ suffix) choices - with Not_found -> [regexp] - -let merge_results results = - let rec aux objects_acc dirs_acc = function - | [] -> dirs_acc @ objects_acc - | Ls_object _ as obj :: tl -> aux (obj :: objects_acc) dirs_acc tl - | Ls_section _ as dir :: tl -> - if List.mem dir dirs_acc then (* filters out dir duplicates *) - aux objects_acc dirs_acc tl - else - aux objects_acc (dir :: dirs_acc) tl - in - aux [] [] (List.concat results) - -let ls regexp = - if remote () then - ls_remote regexp - else - let prefixes = explode_ls_regexp regexp in - merge_results (List.map dumb_ls prefixes) - -let getalluris () = - let rec aux acc = function - | [] -> acc - | dir :: todo -> - let acc', todo' = - List.fold_left - (fun (acc, subdirs) result -> - match result with - | Ls_object obj -> (dir ^ obj.uri) :: acc, subdirs - | Ls_section sect -> acc, (dir ^ sect ^ "/") :: subdirs) - (acc, todo) - (dumb_ls dir) - in - aux acc' todo' - in - aux [] ["cic:/"] (* trailing slash required *) - -(* Shorthands from now on *) - -let getxml' uri = getxml (UriManager.string_of_uri uri) -let resolve' uri = resolve (UriManager.string_of_uri uri) -let exists' uri = exists (UriManager.string_of_uri uri) - -let tilde_expand_key k = - try - Helm_registry.set k (HExtlib.tilde_expand (Helm_registry.get k)) - with Helm_registry.Key_not_found _ -> () - -let init () = - List.iter tilde_expand_key ["getter.cache_dir"; "getter.dtd_dir"]; - Http_getter_logger.set_log_level - (Helm_registry.get_opt_default Helm_registry.int ~default:1 - "getter.log_level"); - Http_getter_logger.set_log_file - (Helm_registry.get_opt Helm_registry.string "getter.log_file") - diff --git a/helm/ocaml/getter/http_getter.mli b/helm/ocaml/getter/http_getter.mli deleted file mode 100644 index 4bbc447bd..000000000 --- a/helm/ocaml/getter/http_getter.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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 Http_getter_types - - (** {2 Loggers} *) - -type logger_callback = HelmLogger.html_tag -> unit - -val stdout_logger: logger_callback - - (** {2 Getter Web Service interface as API *) - -val help: unit -> string - - (** @raise Http_getter_types.Unresolvable_URI _ - * @raise Http_getter_types.Key_not_found _ *) -val resolve: string -> string (* uri -> url *) - -val exists: string -> bool - -val getxml : string -> string -val getxslt : string -> string -val getdtd : string -> string -val clean_cache: unit -> unit -val getalluris: unit -> string list - - (** @param baseuri uri to be listed, simple form or regular expressions (a - * single choice among parens) are permitted *) -val ls: string -> ls_item list - - (** {2 UriManager shorthands} *) - -val getxml' : UriManager.uri -> string -val resolve' : UriManager.uri -> string -val exists' : UriManager.uri -> bool - - (** {2 Misc} *) - -val init: unit -> unit - diff --git a/helm/ocaml/getter/http_getter_common.ml b/helm/ocaml/getter/http_getter_common.ml deleted file mode 100644 index ddce33f5d..000000000 --- a/helm/ocaml/getter/http_getter_common.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Http_getter_types;; -open Printf;; - -let string_of_ls_flag = function No -> "NO" | Yes -> "YES" | Ann -> "ANN" -let string_of_encoding = function - | `Normal -> "Normal" - | `Gzipped -> "GZipped" - -let is_cic_obj_uri uri = Pcre.pmatch ~pat:"^cic:" uri -let is_theory_uri uri = Pcre.pmatch ~pat:"^theory:" uri -let is_cic_uri uri = is_cic_obj_uri uri || is_theory_uri uri -let is_nuprl_uri uri = Pcre.pmatch ~pat:"^nuprl:" uri -let is_rdf_uri uri = Pcre.pmatch ~pat:"^helm:rdf(.*):(.*)//(.*)" uri -let is_xsl_uri uri = Pcre.pmatch ~pat:"^\\w+\\.xsl" uri - -let rec uri_of_string = function - | uri when is_rdf_uri uri -> - (match Pcre.split ~pat:"//" uri with - | [ prefix; uri ] -> - let rest = - match uri_of_string uri with - | Cic_uri xmluri -> xmluri - | _ -> raise (Invalid_URI uri) - in - Rdf_uri (prefix, rest) - | _ -> raise (Invalid_URI uri)) - | uri when is_cic_obj_uri uri -> Cic_uri (Cic (Pcre.replace ~pat:"^cic:" uri)) - | uri when is_nuprl_uri uri -> Nuprl_uri (Pcre.replace ~pat:"^nuprl:" uri) - | uri when is_theory_uri uri -> - Cic_uri (Theory (Pcre.replace ~pat:"^theory:" uri)) - | uri -> raise (Invalid_URI uri) - -let patch_xsl ?(via_http = true) () = - fun line -> - let mk_patch_fun tag line = - Pcre.replace - ~pat:(sprintf "%s\\s+href=\"" tag) - ~templ:(sprintf "%s href=\"%s/getxslt?uri=" - tag (Lazy.force Http_getter_env.my_own_url)) - line - in - let (patch_import, patch_include) = - (mk_patch_fun "xsl:import", mk_patch_fun "xsl:include") - in - patch_include (patch_import line) - -let patch_system kind ?(via_http = true) () = - let rex = - Pcre.regexp (sprintf "%s (.*) SYSTEM\\s+\"((%s)/)?" kind - (String.concat "|" (Lazy.force Http_getter_env.dtd_base_urls))) - in - let templ = - if via_http then - sprintf "%s $1 SYSTEM \"%s/getdtd?uri=" kind - (Lazy.force Http_getter_env.my_own_url) - else - sprintf "%s $1 SYSTEM \"file://%s/" kind (Http_getter_env.get_dtd_dir ()) - in - fun line -> Pcre.replace ~rex ~templ line - -let patch_entity = patch_system "ENTITY" -let patch_doctype = patch_system "DOCTYPE" - -let patch_xmlbase = - let rex = Pcre.regexp "^(\\s*<\\w[^ ]*)(\\s|>)" in - fun xmlbases baseurl baseuri s -> - let s' = - Pcre.replace ~rex - ~templ:(sprintf "$1 xml:base=\"%s\" helm:base=\"%s\"$2" baseurl baseuri) - s - in - if s <> s' then xmlbases := None; - s' - -let patch_dtd = patch_entity -let patch_xml ?via_http ?xmlbases () = - let xmlbases = ref xmlbases in - fun line -> - match !xmlbases with - | None -> patch_doctype ?via_http () (patch_entity ?via_http () line) - | Some (xmlbaseuri, xmlbaseurl) -> - patch_xmlbase xmlbases xmlbaseurl xmlbaseuri - (patch_doctype ?via_http () (patch_entity ?via_http () line)) - -let return_file - ~fname ?contype ?contenc ?patch_fun ?(gunzip = false) ?(via_http = true) - ~enc outchan -= - if via_http then begin - let headers = - match (contype, contenc) with - | (Some t, Some e) -> ["Content-Encoding", e; "Content-Type", t] - | (Some t, None) -> ["Content-Type" , t] - | (None, Some e) -> ["Content-Encoding", e] - | (None, None) -> [] - in - Http_daemon.send_basic_headers ~code:(`Code 200) outchan; - Http_daemon.send_headers headers outchan; - Http_daemon.send_CRLF outchan - end; - match gunzip, patch_fun with - | true, Some patch_fun -> - Http_getter_logger.log ~level:2 - "Patch required, uncompress/compress cycle needed :-("; - (* gunzip needed, uncompress file, apply patch_fun to it, compress the - * result and sent it to client *) - let (tmp1, tmp2) = - (Http_getter_misc.tempfile (), Http_getter_misc.tempfile ()) - in - (try - Http_getter_misc.gunzip ~keep:true ~output:tmp1 fname; (* gunzip tmp1 *) - let new_file = open_out tmp2 in - Http_getter_misc.iter_file (* tmp2 = patch(tmp1) *) - (fun line -> - output_string new_file (patch_fun line ^ "\n"); - flush outchan) - tmp1; - close_out new_file; - Http_getter_misc.gzip ~output:tmp1 tmp2;(* tmp1 = gzip(tmp2); rm tmp2 *) - Http_getter_misc.iter_file (* send tmp1 to client as is*) - (fun line -> output_string outchan (line ^ "\n"); flush outchan) - tmp1; - Sys.remove tmp1 (* rm tmp1 *) - with e -> - Sys.remove tmp1; - raise e) - | false, Some patch_fun -> - (match enc with - | `Normal -> - Http_getter_misc.iter_file - (fun line -> output_string outchan (patch_fun (line ^ "\n"))) - fname - | `Gzipped -> assert false) - (* dangerous case, if this happens it needs to be investigated *) - | _, None -> Http_getter_misc.iter_file_data (output_string outchan) fname -;; - diff --git a/helm/ocaml/getter/http_getter_common.mli b/helm/ocaml/getter/http_getter_common.mli deleted file mode 100644 index d1bc66f76..000000000 --- a/helm/ocaml/getter/http_getter_common.mli +++ /dev/null @@ -1,70 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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 Http_getter_types;; - -val string_of_ls_flag: ls_flag -> string -val string_of_encoding: encoding -> string - -val is_cic_uri: string -> bool -val is_cic_obj_uri: string -> bool -val is_theory_uri: string -> bool -val is_nuprl_uri: string -> bool -val is_rdf_uri: string -> bool -val is_xsl_uri: string -> bool - -val uri_of_string: string -> uri - - (** @param xmlbases (xml base URI * xml base URL) *) -val patch_xml : - ?via_http:bool -> ?xmlbases:(string * string) -> unit -> (string -> string) -val patch_dtd : ?via_http:bool -> unit -> (string -> string) - (* TODO via_http not yet supported for patch_xsl *) -val patch_xsl : ?via_http:bool -> unit -> (string -> string) - - (** - @param fname name of the file to be sent - @param contype Content-Type header value - @param contenc Content-Enconding header value - @param patch_fun function used to patch file contents - @param gunzip is meaningful only if a patch function is provided. If gunzip - is true and patch_fun is given (i.e. is not None), then patch_fun is applied - to the uncompressed version of the file. The file is then compressed again and - send to client - @param via_http (default: true) if true http specific communications are used - (e.g. headers, crlf before body) and sent via outchan, otherwise they're not. - Set it to false when saving to a local file - @param outchan output channel over which sent file fname *) -val return_file: - fname:string -> - ?contype:string -> ?contenc:string -> - ?patch_fun:(string -> string) -> ?gunzip:bool -> ?via_http:bool -> - enc:encoding -> - out_channel -> - unit - diff --git a/helm/ocaml/getter/http_getter_const.ml b/helm/ocaml/getter/http_getter_const.ml deleted file mode 100644 index 8103efcfa..000000000 --- a/helm/ocaml/getter/http_getter_const.ml +++ /dev/null @@ -1,102 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Printf;; - -let version = "0.4.0" -let conffile = "http_getter.conf.xml" - -let xhtml_ns = "http://www.w3.org/1999/xhtml" -let helm_ns = "http://www.cs.unibo.it/helm" - - (* TODO provide a better usage string *) -let usage_string configuration = - sprintf -" - - - HTTP Getter's help message - - -

HTTP Getter, version %s

-

Usage information

-

- Usage: http://hostname:getterport/command -

-

- Available commands: -

-

- help
- display this help message -

-

- getxml?uri=URI[&format=(normal|gz)][&patch_dtd=(yes|no)]
-

-

- resolve?uri=URI
-

-

- getdtd?uri=URI[&patch_dtd=(yes|no)]
-

-

- getxslt?uri=URI[&patch_dtd=(yes|no)]
-

-

- update
-

-

- clean_cache
-

-

- ls?baseuri=regexp&format=(txt|xml)
-

-

- getalluris?format=(txt|xml)
-

-

- getempty
-

-

Current configuration

- 
%s
- - -" - xhtml_ns helm_ns - version configuration - -let empty_xml = -" - -]> - -" - diff --git a/helm/ocaml/getter/http_getter_const.mli b/helm/ocaml/getter/http_getter_const.mli deleted file mode 100644 index d532313f0..000000000 --- a/helm/ocaml/getter/http_getter_const.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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 version: string -val conffile: string -val empty_xml: string - -val helm_ns: string (** helm namespace *) -val xhtml_ns: string (** xhtml namespace *) - - (** @return an HTML usage string including configuration information passed as - input parameter *) -val usage_string: string -> string - diff --git a/helm/ocaml/getter/http_getter_env.ml b/helm/ocaml/getter/http_getter_env.ml deleted file mode 100644 index 79b0ab42e..000000000 --- a/helm/ocaml/getter/http_getter_env.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Printf - -open Http_getter_types -open Http_getter_misc - -let version = Http_getter_const.version - -let prefix_RE = Pcre.regexp "^\\s*([^\\s]+)\\s+([^\\s]+)\\s*(.*)$" - -let cache_dir = lazy (normalize_dir (Helm_registry.get "getter.cache_dir")) -let dtd_dir = lazy ( - match Helm_registry.get_opt Helm_registry.get_string "getter.dtd_dir" with - | None -> None - | Some dir -> Some (normalize_dir dir)) -let dtd_base_urls = lazy ( - let rex = Pcre.regexp "/*$" in - let raw_urls = - match - Helm_registry.get_list Helm_registry.string "getter.dtd_base_urls" - with - | [] -> ["http://helm.cs.unibo.it/dtd"; "http://mowgli.cs.unibo.it/dtd"] - | urls -> urls - in - List.map (Pcre.replace ~rex) raw_urls) -let port = lazy ( - Helm_registry.get_opt_default Helm_registry.int ~default:58081 "getter.port") - -let parse_prefix_attrs s = - List.fold_right - (fun s acc -> - match s with - | "ro" -> `Read_only :: acc - | "legacy" -> `Legacy :: acc - | s -> - Http_getter_logger.log ("ignoring unknown attribute: " ^ s); - acc) - (Pcre.split s) [] - -let prefixes = lazy ( - let prefixes = Helm_registry.get_list Helm_registry.string "getter.prefix" in - List.fold_left - (fun acc prefix -> - let subs = Pcre.extract ~rex:prefix_RE prefix in - try - (subs.(1), (subs.(2), parse_prefix_attrs subs.(3))) :: acc - with Invalid_argument _ -> - Http_getter_logger.log ("skipping invalid prefix: " ^ prefix); - acc) - [] prefixes) - -let host = lazy (Http_getter_misc.backtick "hostname -f") - -let my_own_url = - lazy - (let (host, port) = (Lazy.force host, Lazy.force port) in - sprintf "http://%s%s" (* without trailing '/' *) - host (if port = 80 then "" else (sprintf ":%d" port))) - -let env_to_string () = - let pp_attr = function `Read_only -> "ro" | `Legacy -> "legacy" in - let pp_prefix (uri_prefix, (url_prefix, attrs)) = - sprintf " %s -> %s [%s]" uri_prefix url_prefix - (String.concat "," (List.map pp_attr attrs)) in - let pp_prefixes prefixes = - match prefixes with - | [] -> "" - | l -> "\n" ^ String.concat "\n" (List.map pp_prefix l) - in - sprintf -"HTTP Getter %s - -prefixes:%s -dtd_dir:\t%s -host:\t\t%s -port:\t\t%d -my_own_url:\t%s -dtd_base_urls:\t%s -log_file:\t%s -log_level:\t%d -" - version - (pp_prefixes (Lazy.force prefixes)) - (match Lazy.force dtd_dir with Some dir -> dir | None -> "NONE") - (Lazy.force host) (Lazy.force port) - (Lazy.force my_own_url) (String.concat " " (Lazy.force dtd_base_urls)) - (match Http_getter_logger.get_log_file () with None -> "None" | Some f -> f) - (Http_getter_logger.get_log_level ()) - -let get_dtd_dir () = - match Lazy.force dtd_dir with - | None -> raise (Internal_error "dtd_dir is not available") - | Some dtd_dir -> dtd_dir - diff --git a/helm/ocaml/getter/http_getter_env.mli b/helm/ocaml/getter/http_getter_env.mli deleted file mode 100644 index d1ab73db8..000000000 --- a/helm/ocaml/getter/http_getter_env.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -open Http_getter_types - - (** {2 general information} *) - -val version : string (* getter version *) - - (** {2 environment gathered data} *) - (** all *_dir values are returned with trailing "/" *) - -val cache_dir : string lazy_t (* cache root *) -val dtd_dir : string option lazy_t (* DTDs' root directory *) -val port : int lazy_t (* port on which getter listens *) -val dtd_base_urls : string list lazy_t (* base URLs for document patching *) -val prefixes : (string * (string * prefix_attr list)) list lazy_t - (* prefix map uri -> url + attrs *) - - (* {2 derived data} *) - -val host : string lazy_t (* host on which getter listens *) -val my_own_url : string lazy_t (* URL at which contact getter *) - - (* {2 misc} *) - -val env_to_string : unit -> string (* dump a textual representation of the - current http_getter settings on an output - channel *) - -val get_dtd_dir : unit -> string - diff --git a/helm/ocaml/getter/http_getter_logger.ml b/helm/ocaml/getter/http_getter_logger.ml deleted file mode 100644 index 1d774c102..000000000 --- a/helm/ocaml/getter/http_getter_logger.ml +++ /dev/null @@ -1,63 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -let log_level = ref 1 -let get_log_level () = !log_level -let set_log_level l = log_level := l - -(* invariant: if logfile is set, then logchan is set too *) -let logfile = ref None -let logchan = ref None - -let set_log_file f = - (match !logchan with None -> () | Some oc -> close_out oc); - match f with - | Some f -> - logfile := Some f; - logchan := Some (open_out f) - | None -> - logfile := None; - logchan := None - -let get_log_file () = !logfile - -let close_log_file () = set_log_file None - -let log ?(level = 1) s = - if level <= !log_level then - let msg = "[HTTP-Getter] " ^ s in - match (!logfile, !logchan) with - | None, _ -> prerr_endline msg - | Some fname, Some oc -> - output_string oc msg; - output_string oc "\n"; - flush oc - | Some _, None -> assert false - diff --git a/helm/ocaml/getter/http_getter_logger.mli b/helm/ocaml/getter/http_getter_logger.mli deleted file mode 100644 index d39fe739d..000000000 --- a/helm/ocaml/getter/http_getter_logger.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(** {2 Debugger and logger} *) - - (** log level - * 0 -> logging disabled - * 1 -> standard logging - * >=2 -> verbose logging - * default is 1 *) -val get_log_level: unit -> int -val set_log_level: int -> unit - - (** log a message through the logger with a given log level - * level defaults to 1, higher level denotes more verbose messages which are - * ignored with the default log_level *) -val log: ?level: int -> string -> unit - - (** if set to Some fname, fname will be used as a logfile, otherwise stderr - * will be used *) -val get_log_file: unit -> string option -val set_log_file: string option -> unit -val close_log_file: unit -> unit - diff --git a/helm/ocaml/getter/http_getter_misc.ml b/helm/ocaml/getter/http_getter_misc.ml deleted file mode 100644 index 45403effa..000000000 --- a/helm/ocaml/getter/http_getter_misc.ml +++ /dev/null @@ -1,315 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Printf - -let file_scheme_prefix = "file://" - -let trailing_dot_gz_RE = Pcre.regexp "\\.gz$" (* for g{,un}zip *) -let url_RE = Pcre.regexp "^([\\w.-]+)(:(\\d+))?(/.*)?$" -let http_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "^http://" -let file_scheme_RE = Pcre.regexp ~flags:[`CASELESS] ("^" ^ file_scheme_prefix) -let dir_sep_RE = Pcre.regexp "/" -let heading_slash_RE = Pcre.regexp "^/" - -let local_url = - let rex = Pcre.regexp ("^(" ^ file_scheme_prefix ^ ")(.*)(.gz)$") in - fun s -> - try - Some ((Pcre.extract ~rex s).(2)) - with Not_found -> None - -let bufsiz = 16384 (* for file system I/O *) -let tcp_bufsiz = 4096 (* for TCP I/O *) - -let fold_file f init fname = - let ic = open_in fname in - let rec aux acc = - let line = try Some (input_line ic) with End_of_file -> None in - match line with - | None -> acc - | Some line -> aux (f line acc) - in - let res = try aux init with e -> close_in ic; raise e in - close_in ic; - res - -let iter_file f = fold_file (fun line _ -> f line) () - -let iter_buf_size = 10240 - -let iter_file_data f fname = - let ic = open_in fname in - let buf = String.create iter_buf_size in - try - while true do - let bytes = input ic buf 0 iter_buf_size in - if bytes = 0 then raise End_of_file; - f (String.sub buf 0 bytes) - done - with End_of_file -> close_in ic - -let hashtbl_sorted_fold f tbl init = - let sorted_keys = - List.sort compare (Hashtbl.fold (fun key _ keys -> key::keys) tbl []) - in - List.fold_left (fun acc k -> f k (Hashtbl.find tbl k) acc) init sorted_keys - -let hashtbl_sorted_iter f tbl = - let sorted_keys = - List.sort compare (Hashtbl.fold (fun key _ keys -> key::keys) tbl []) - in - List.iter (fun k -> f k (Hashtbl.find tbl k)) sorted_keys - -let cp src dst = - try - let ic = open_in src in - try - let oc = open_out dst in - let buf = String.create bufsiz in - (try - while true do - let bytes = input ic buf 0 bufsiz in - if bytes = 0 then raise End_of_file else output oc buf 0 bytes - done - with - End_of_file -> () - ); - close_in ic; close_out oc - with - Sys_error s -> - Http_getter_logger.log s; - close_in ic - | e -> - Http_getter_logger.log (Printexc.to_string e); - close_in ic; - raise e - with - Sys_error s -> - Http_getter_logger.log s - | e -> - Http_getter_logger.log (Printexc.to_string e); - raise e - -let wget ?output url = - Http_getter_logger.log - (sprintf "wgetting %s (output: %s)" url - (match output with None -> "default" | Some f -> f)); - match url with - | url when Pcre.pmatch ~rex:file_scheme_RE url -> (* file:// *) - (let src_fname = Pcre.replace ~rex:file_scheme_RE url in - match output with - | Some dst_fname -> cp src_fname dst_fname - | None -> - let dst_fname = Filename.basename src_fname in - if src_fname <> dst_fname then - cp src_fname dst_fname - else (* src and dst are the same: do nothing *) - ()) - | url when Pcre.pmatch ~rex:http_scheme_RE url -> (* http:// *) - (let oc = - open_out (match output with Some f -> f | None -> Filename.basename url) - in - Http_user_agent.get_iter (fun data -> output_string oc data) url; - close_out oc) - | scheme -> (* unsupported scheme *) - failwith ("Http_getter_misc.wget: unsupported scheme: " ^ scheme) - -let gzip ?(keep = false) ?output fname = - let output = match output with None -> fname ^ ".gz" | Some fname -> fname in - Http_getter_logger.log ~level:3 - (sprintf "gzipping %s (keep: %b, output: %s)" fname keep output); - let (ic, oc) = (open_in fname, Gzip.open_out output) in - let buf = String.create bufsiz in - (try - while true do - let bytes = input ic buf 0 bufsiz in - if bytes = 0 then raise End_of_file else Gzip.output oc buf 0 bytes - done - with End_of_file -> ()); - close_in ic; Gzip.close_out oc; - if not keep then Sys.remove fname -;; - -let gunzip ?(keep = false) ?output fname = - (* assumption: given file name ends with ".gz" or output is set *) - let output = - match output with - | None -> - if (Pcre.pmatch ~rex:trailing_dot_gz_RE fname) then - Pcre.replace ~rex:trailing_dot_gz_RE fname - else - failwith - "Http_getter_misc.gunzip: unable to determine output file name" - | Some fname -> fname - in - Http_getter_logger.log ~level:3 - (sprintf "gunzipping %s (keep: %b, output: %s)" fname keep output); - (* Open the zipped file manually since Gzip.open_in may - * leak the descriptor if it raises an exception *) - let zic = open_in fname in - begin - try - let ic = Gzip.open_in_chan zic in - let oc = open_out output in - let buf = String.create bufsiz in - (try - while true do - let bytes = Gzip.input ic buf 0 bufsiz in - if bytes = 0 then raise End_of_file else Pervasives.output oc buf 0 bytes - done - with End_of_file -> ()); - close_out oc; - Gzip.close_in ic - with - e -> close_in zic ; raise e - end ; - if not keep then Sys.remove fname -;; - -let tempfile () = Filename.temp_file "http_getter_" "" - -exception Mkdir_failure of string * string;; (* dirname, failure reason *) -let dir_perm = 0o755 - -let mkdir ?(parents = false) dirname = - let mkdirhier () = - let (pieces, hd) = - let split = Pcre.split ~rex:dir_sep_RE dirname in - if Pcre.pmatch ~rex:heading_slash_RE dirname then - (List.tl split, "/") - else - (split, "") - in - ignore - (List.fold_left - (fun pre dir -> - let next_dir = - sprintf "%s%s%s" pre (match pre with "/" | "" -> "" | _ -> "/") dir - in - (try - (match (Unix.stat next_dir).Unix.st_kind with - | Unix.S_DIR -> () (* dir component already exists, go on! *) - | _ -> (* dir component already exists but isn't a dir, abort! *) - raise - (Mkdir_failure (dirname, - sprintf "'%s' already exists but is not a dir" next_dir))) - with Unix.Unix_error (Unix.ENOENT, "stat", _) -> - (* dir component doesn't exists, create it and go on! *) - Unix.mkdir next_dir dir_perm); - next_dir) - hd pieces) - in - if parents then mkdirhier () else Unix.mkdir dirname dir_perm - -let string_of_proc_status = function - | Unix.WEXITED code -> sprintf "[Exited: %d]" code - | Unix.WSIGNALED sg -> sprintf "[Killed: %d]" sg - | Unix.WSTOPPED sg -> sprintf "[Stopped: %d]" sg - -let http_get url = - if Pcre.pmatch ~rex:file_scheme_RE url then begin - (* file:// URL. Read data from file system *) - let fname = Pcre.replace ~rex:file_scheme_RE url in - try - let size = (Unix.stat fname).Unix.st_size in - let buf = String.create size in - let ic = open_in fname in - really_input ic buf 0 size ; - close_in ic; - Some buf - with Unix.Unix_error (Unix.ENOENT, "stat", _) -> None - end else (* other URL, pass it to Http_user_agent *) - try - Some (Http_user_agent.get url) - with e -> - Http_getter_logger.log (sprintf - "Warning: Http_user_agent failed on url %s with exception: %s" - url (Printexc.to_string e)); - None - -let is_blank_line = - let blank_line_RE = Pcre.regexp "(^#)|(^\\s*$)" in - fun line -> - Pcre.pmatch ~rex:blank_line_RE line - -let normalize_dir s = (* append "/" if missing *) - let len = String.length s in - try - if s.[len - 1] = '/' then s - else s ^ "/" - with Invalid_argument _ -> (* string is empty *) "/" - -let strip_trailing_slash s = - try - let len = String.length s in - if s.[len - 1] = '/' then String.sub s 0 (len - 1) - else s - with Invalid_argument _ -> s - -let strip_suffix ~suffix s = - try - let s_len = String.length s in - let suffix_len = String.length suffix in - let suffix_sub = String.sub s (s_len - suffix_len) suffix_len in - if suffix_sub <> suffix then raise (Invalid_argument ""); - String.sub s 0 (s_len - suffix_len) - with Invalid_argument _ -> - raise (Invalid_argument "Http_getter_misc.strip_suffix") - -let rec list_uniq = function - | [] -> [] - | h::[] -> [h] - | h1::h2::tl when h1 = h2 -> list_uniq (h2 :: tl) - | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq tl - -let extension s = - try - let idx = String.rindex s '.' in - String.sub s idx (String.length s - idx) - with Not_found -> "" - -let temp_file_of_uri uri = - let flat_string s s' c = - let cs = String.copy s in - for i = 0 to (String.length s) - 1 do - if String.contains s' s.[i] then cs.[i] <- c - done; - cs - in - let user = try Unix.getlogin () with _ -> "" in - Filename.open_temp_file (user ^ flat_string uri ".-=:;!?/&" '_') "" - -let backtick cmd = - let ic = Unix.open_process_in cmd in - let res = input_line ic in - ignore (Unix.close_process_in ic); - res - diff --git a/helm/ocaml/getter/http_getter_misc.mli b/helm/ocaml/getter/http_getter_misc.mli deleted file mode 100644 index e9b013ebd..000000000 --- a/helm/ocaml/getter/http_getter_misc.mli +++ /dev/null @@ -1,102 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - - (** 'mkdir' failed, arguments are: name of the directory to be created and - failure reason *) -exception Mkdir_failure of string * string - - (** @return Some localpart for URI belonging to the "file://" scheme, None for - * other URIs - * removes trailing ".gz", if any - * e.g.: local_url "file:///etc/passwd.gz" = Some "/etc/passwd" - * local_url "http://...." = None *) -val local_url: string -> string option - - (** "fold_left" like function on file lines, trailing newline is not passed to - the given function *) -val fold_file : (string -> 'a -> 'a) -> 'a -> string -> 'a - - (* "iter" like function on file lines, trailing newline is not passed to the - given function *) -val iter_file : (string -> unit) -> string -> unit - - (* "iter" like function on file data chunks of fixed size *) -val iter_file_data: (string -> unit) -> string -> unit - - (** like Hashtbl.fold but keys are processed ordered *) -val hashtbl_sorted_fold : - ('a -> 'b -> 'c -> 'c) -> ('a, 'b) Hashtbl.t -> 'c -> 'c - (** like Hashtbl.iter but keys are processed ordered *) -val hashtbl_sorted_iter : ('a -> 'b -> unit) -> ('a, 'b) Hashtbl.t -> unit - -val list_uniq: 'a list -> 'a list (* uniq unix filter on lists *) - - (** cp frontend *) -val cp: string -> string -> unit - (** wget frontend, if output is given it is the destination file, otherwise - standard wget rules are used. Additionally this function support also the - "file://" scheme for file system addressing *) -val wget: ?output: string -> string -> unit - (** gzip frontend. If keep = true original file will be kept, default is - false. output is the file on which gzipped data will be saved, default is - given file with an added ".gz" suffix *) -val gzip: ?keep: bool -> ?output: string -> string -> unit - (** gunzip frontend. If keep = true original file will be kept, default is - false. output is the file on which gunzipped data will be saved, default is - given file name without trailing ".gz" *) -val gunzip: ?keep: bool -> ?output: string -> string -> unit - (** tempfile frontend, return the name of created file. A special purpose - suffix is used (actually "_http_getter" *) -val tempfile: unit -> string - (** mkdir frontend, if parents = true also parent directories will be created. - If the given directory already exists doesn't act. - parents defaults to false *) -val mkdir: ?parents:bool -> string -> unit - - (** pretty printer for Unix.process_status values *) -val string_of_proc_status : Unix.process_status -> string - - (** raw URL downloader, return Some the contents of downloaded resource or - None if an error occured while downloading. This function support also - "file://" scheme for filesystem resources *) -val http_get: string -> string option - - (** true on blanks-only and #-commented lines, false otherwise *) -val is_blank_line: string -> bool - -val normalize_dir: string -> string (** add trailing "/" if missing *) -val strip_trailing_slash: string -> string -val strip_suffix: suffix:string -> string -> string - -val extension: string -> string (** @return string part after rightmost "." *) - -val temp_file_of_uri: string -> string * out_channel - - (** execute a command and return first line of what it prints on stdout *) -val backtick: string -> string - diff --git a/helm/ocaml/getter/http_getter_storage.ml b/helm/ocaml/getter/http_getter_storage.ml deleted file mode 100644 index fc6f415ac..000000000 --- a/helm/ocaml/getter/http_getter_storage.ml +++ /dev/null @@ -1,275 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open Http_getter_misc -open Http_getter_types - -exception Not_found' -exception Resource_not_found of string * string (** method, uri *) - -let index_fname = "INDEX" - -let trailing_slash_RE = Pcre.regexp "/$" -let relative_RE_raw = "(^[^/]+(/[^/]+)*/?$)" -let relative_RE = Pcre.regexp relative_RE_raw -let file_scheme_RE_raw = "(^file://)" -let extended_file_scheme_RE = Pcre.regexp "(^file:/+)" -let file_scheme_RE = Pcre.regexp (relative_RE_raw ^ "|" ^ file_scheme_RE_raw) -let http_scheme_RE = Pcre.regexp "^http://" -let newline_RE = Pcre.regexp "\\n" -let cic_scheme_sep_RE = Pcre.regexp ":/" -let gz_suffix = ".gz" -let gz_suffix_len = String.length gz_suffix - -let path_of_file_url url = - assert (Pcre.pmatch ~rex:file_scheme_RE url); - if Pcre.pmatch ~rex:relative_RE url then - url - else (* absolute path, add heading "/" if missing *) - "/" ^ (Pcre.replace ~rex:extended_file_scheme_RE url) - - (** associative list regular expressions -> url prefixes - * sorted with longest prefixes first *) -let prefix_map = lazy ( - let map_w_length = - List.map - (fun (uri_prefix, (url_prefix, attrs)) -> - let uri_prefix = normalize_dir uri_prefix in - let url_prefix = normalize_dir url_prefix in - let regexp = Pcre.regexp ("^(" ^ Pcre.quote uri_prefix ^ ")") in - (regexp, String.length uri_prefix, uri_prefix, url_prefix, attrs)) - (Lazy.force Http_getter_env.prefixes) - in - let decreasing_length (_, len1, _, _, _) (_, len2, _, _, _) = - compare len2 len1 in - List.map - (fun (regexp, len, uri_prefix, url_prefix, attrs) -> - (regexp, strip_trailing_slash uri_prefix, url_prefix, attrs)) - (List.fast_sort decreasing_length map_w_length)) - -let lookup uri = - let matches = - List.filter (fun (rex, _, _, _) -> Pcre.pmatch ~rex uri) - (Lazy.force prefix_map) in - if matches = [] then raise (Unresolvable_URI uri); - matches - -let resolve_prefix uri = - match lookup uri with - | (rex, _, url_prefix, _) :: _ -> - Pcre.replace_first ~rex ~templ:url_prefix uri - | [] -> assert false - -let resolve_prefixes uri = - let matches = lookup uri in - List.map - (fun (rex, _, url_prefix, _) -> - Pcre.replace_first ~rex ~templ:url_prefix uri) - matches - -let get_attrs uri = - match lookup uri with - | (_, _, _, attrs) :: _ -> attrs - | [] -> assert false - -let is_legacy uri = List.exists ((=) `Legacy) (get_attrs uri) - -let is_read_only uri = - is_legacy uri || List.exists ((=) `Read_only) (get_attrs uri) - -let exists_http _ url = - Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url - -let exists_file _ fname = - Sys.file_exists (fname ^ gz_suffix) || Sys.file_exists fname - -let resolve_http _ url = - try - List.find Http_getter_wget.exists [ url ^ gz_suffix; url ] - with Not_found -> raise Not_found' - -let resolve_file _ fname = - try - List.find Sys.file_exists [ fname ^ gz_suffix; fname ] - with Not_found -> raise Not_found' - -let strip_gz_suffix fname = - if extension fname = gz_suffix then - String.sub fname 0 (String.length fname - gz_suffix_len) - else - fname - -let remove_duplicates l = - Http_getter_misc.list_uniq (List.fast_sort Pervasives.compare l) - -let ls_file_single _ path_prefix = - let is_dir fname = (Unix.stat fname).Unix.st_kind = Unix.S_DIR in - let is_useless dir = try dir.[0] = '.' with _ -> false in - let entries = ref [] in - try - let dir_handle = Unix.opendir path_prefix in - (try - while true do - let entry = Unix.readdir dir_handle in - if is_useless entry then - () - else if is_dir (path_prefix ^ "/" ^ entry) then - entries := normalize_dir entry :: !entries - else - entries := strip_gz_suffix entry :: !entries - done - with End_of_file -> Unix.closedir dir_handle); - remove_duplicates !entries - with Unix.Unix_error (_, "opendir", _) -> [] - -let ls_http_single _ url_prefix = - try - let index = Http_getter_wget.get (normalize_dir url_prefix ^ index_fname) in - Pcre.split ~rex:newline_RE index - with Http_client_error _ -> raise Not_found' - -let get_file _ path = - if Sys.file_exists (path ^ gz_suffix) then - path ^ gz_suffix - else if Sys.file_exists path then - path - else - raise Not_found' - -let get_http uri url = - let scheme, path = - match Pcre.split ~rex:cic_scheme_sep_RE uri with - | [scheme; path] -> scheme, path - | _ -> assert false - in - let cache_name = - sprintf "%s%s/%s" (Lazy.force Http_getter_env.cache_dir) scheme path - in - if Sys.file_exists (cache_name ^ gz_suffix) then - cache_name ^ gz_suffix - else if Sys.file_exists cache_name then - cache_name - else begin (* fill cache *) - Http_getter_misc.mkdir ~parents:true (Filename.dirname cache_name); - (try - Http_getter_wget.get_and_save (url ^ gz_suffix) (cache_name ^ gz_suffix); - cache_name ^ gz_suffix - with Http_client_error _ -> - (try - Http_getter_wget.get_and_save url cache_name; - cache_name - with Http_client_error _ -> - raise Not_found')) - end - -let remove_file _ path = - if Sys.file_exists (path ^ gz_suffix) then Sys.remove (path ^ gz_suffix); - if Sys.file_exists path then Sys.remove path - -let remove_http _ _ = - prerr_endline "Http_getter_storage.remove: not implemented for HTTP scheme"; - assert false - -type 'a storage_method = { - name: string; - file: string -> string -> 'a; (* unresolved uri, resolved uri *) - http: string -> string -> 'a; (* unresolved uri, resolved uri *) -} - -let normalize_root uri = (* add trailing slash to roots *) - try - if uri.[String.length uri - 1] = ':' then uri ^ "/" - else uri - with Invalid_argument _ -> uri - -let invoke_method storage_method uri url = - try - if Pcre.pmatch ~rex:file_scheme_RE url then - storage_method.file uri (path_of_file_url url) - else if Pcre.pmatch ~rex:http_scheme_RE url then - storage_method.http uri url - else - raise (Unsupported_scheme url) - with Not_found' -> raise (Resource_not_found (storage_method.name, uri)) - -let dispatch_single storage_method uri = - assert (extension uri <> gz_suffix); - let uri = normalize_root uri in - let url = resolve_prefix uri in - invoke_method storage_method uri url - -let dispatch_multi storage_method uri = - let urls = resolve_prefixes uri in - let rec aux = function - | [] -> raise (Resource_not_found (storage_method.name, uri)) - | url :: tl -> - (try - invoke_method storage_method uri url - with Resource_not_found _ -> aux tl) - in - aux urls - -let exists = - dispatch_single { name = "exists"; file = exists_file; http = exists_http } - -let resolve = - dispatch_single { name = "resolve"; file = resolve_file; http = resolve_http } - -let ls_single = - dispatch_single { name = "ls"; file = ls_file_single; http = ls_http_single } - -let remove = - dispatch_single { name = "remove"; file = remove_file; http = remove_http } - -let filename ?(find = false) = - if find then - dispatch_multi { name = "filename"; file = get_file; http = get_http } - else - dispatch_single { name = "filename"; file = get_file; http = get_http } - - (* ls_single performs ls only below a single prefix, but prefixes which have - * common prefix (sorry) with a given one may need to be considered as well - * for example: when doing "ls cic:/" we would like to see the "cic:/matita" - * directory *) -let ls uri_prefix = -(* prerr_endline ("Http_getter_storage.ls " ^ uri_prefix); *) - let direct_results = ls_single uri_prefix in - List.fold_left - (fun results (_, uri_prefix', _, _) -> - if Filename.dirname uri_prefix' = strip_trailing_slash uri_prefix then - (Filename.basename uri_prefix' ^ "/") :: results - else - results) - direct_results - (Lazy.force prefix_map) - -let clean_cache () = - ignore (Sys.command - (sprintf "rm -rf %s/" (Lazy.force Http_getter_env.cache_dir))) - diff --git a/helm/ocaml/getter/http_getter_storage.mli b/helm/ocaml/getter/http_getter_storage.mli deleted file mode 100644 index 24fc329c9..000000000 --- a/helm/ocaml/getter/http_getter_storage.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** Transparent handling of local/remote getter resources. - * Configuration of this module are prefix mappings (see - * Http_getter_env.prefixes). All functions of this module take as input an URI, - * resolve it using mappings and act on the resulting resource which can be - * local (file:/// scheme or relative path) or remote via HTTP (http:// scheme). - * - * Each resource could be either compressed (trailing ".gz") or non-compressed. - * All functions of this module will first loook for the compressed resource - * (i.e. the asked one ^ ".gz"), falling back to the non-compressed one. - * - * All filenames returned by functions of this module exists on the filesystem - * after function's return. - * - * Almost all functions may raise Resource_not_found, the following invariant - * holds: that exception is raised iff exists return false on a given resource - * *) - -exception Resource_not_found of string * string (** method, uri *) - - (** @return a list of string where dir are returned with a trailing "/" *) -val ls: string -> string list - - - (** @return the filename of the resource corresponding to a given uri. Handle - * download and caching for remote resources. - * @param find if set to true all matching prefixes will be searched for the - * asked resource, if not only the best matching prefix will be used. Note - * that the search is performed only if the asked resource is not found in - * cache (i.e. to perform the find again you need to clean the cache). - * Defaults to false *) -val filename: ?find:bool -> string -> string - - (** only works for local resources - * if both compressed and non-compressed versions of a resource exist, both of - * them are removed *) -val remove: string -> unit - -val exists: string -> bool -val resolve: string -> string - -(* val get_attrs: string -> Http_getter_types.prefix_attr list *) -val is_read_only: string -> bool -val is_legacy: string -> bool - -val clean_cache: unit -> unit - diff --git a/helm/ocaml/getter/http_getter_types.ml b/helm/ocaml/getter/http_getter_types.ml deleted file mode 100644 index fb0c30e83..000000000 --- a/helm/ocaml/getter/http_getter_types.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -exception Bad_request of string -exception Unresolvable_URI of string -exception Invalid_URI of string -exception Invalid_URL of string -exception Invalid_RDF_class of string -exception Internal_error of string -exception Cache_failure of string -exception Dtd_not_found of string (* dtd's url *) -exception Key_already_in of string;; -exception Key_not_found of string;; -exception Http_client_error of string * string (* url, error message *) -exception Unsupported_scheme of string (** unsupported url scheme *) - -type encoding = [ `Normal | `Gzipped ] -type answer_format = [ `Text | `Xml ] -type ls_flag = No | Yes | Ann -type ls_object = - { - uri: string; - ann: bool; - types: ls_flag; - body: ls_flag; - proof_tree: ls_flag; - } -type ls_item = - | Ls_section of string - | Ls_object of ls_object - -type xml_uri = - | Cic of string - | Theory of string -type rdf_uri = string * xml_uri -type nuprl_uri = string -type uri = - | Cic_uri of xml_uri - | Nuprl_uri of nuprl_uri - | Rdf_uri of rdf_uri - -module StringSet = Set.Make (String) - -type prefix_attr = [ `Read_only | `Legacy ] - diff --git a/helm/ocaml/getter/http_getter_wget.ml b/helm/ocaml/getter/http_getter_wget.ml deleted file mode 100644 index 2052e7bd5..000000000 --- a/helm/ocaml/getter/http_getter_wget.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* Copyright (C) 2000-2005, 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/. - *) - -(* $Id$ *) - -open Http_getter_types - -let send cmd = - try - ignore (Http_user_agent.get cmd) - with exn -> raise (Http_client_error (cmd, Printexc.to_string exn)) - -let get url = - try - Http_user_agent.get url - with exn -> raise (Http_client_error (Printexc.to_string exn, url)) - -let get_and_save url dest_filename = - let out_channel = open_out dest_filename in - (try - Http_user_agent.get_iter (output_string out_channel) url; - with exn -> - close_out out_channel; - Sys.remove dest_filename; - raise (Http_client_error (Printexc.to_string exn, url))); - close_out out_channel - -let get_and_save_to_tmp url = - let flat_string s s' c = - let cs = String.copy s in - for i = 0 to (String.length s) - 1 do - if String.contains s' s.[i] then cs.[i] <- c - done; - cs - in - let user = try Unix.getlogin () with _ -> "" in - let tmp_file = - Filename.temp_file (user ^ flat_string url ".-=:;!?/&" '_') "" - in - get_and_save url tmp_file; - tmp_file - -let exists url = - try - ignore (Http_user_agent.head url); - true - with Http_user_agent.Http_error _ -> false - diff --git a/helm/ocaml/getter/http_getter_wget.mli b/helm/ocaml/getter/http_getter_wget.mli deleted file mode 100644 index 5d28df185..000000000 --- a/helm/ocaml/getter/http_getter_wget.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2000-2005, 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/. - *) - - (** try to guess if an HTTP resource exists using HEAD request - * @return true if HEAD response code = 200 *) -val exists: string -> bool - -val get: string -> string -val get_and_save: string -> string -> unit -val get_and_save_to_tmp: string -> string - -val send: string -> unit - diff --git a/helm/ocaml/getter/mkindexes.pl b/helm/ocaml/getter/mkindexes.pl deleted file mode 100755 index 3107846aa..000000000 --- a/helm/ocaml/getter/mkindexes.pl +++ /dev/null @@ -1,40 +0,0 @@ -#!/usr/bin/perl -w -# To be invoked in a directory where a tree of XML files of the HELM library is -# rooted. This script will then creates INDEX files in all directories of the -# tree. -use strict; -my $index_fname = "INDEX"; -sub getcwd() { - my $pwd = `pwd`; - chomp $pwd; - return $pwd; -} -sub add_trailing_slash($) { - my ($dir) = @_; - return $dir if ($dir =~ /\/$/); - return "$dir/"; -} -sub indexable($) { - my ($fname) = @_; - return 1 if ($fname =~ /\.(ind|types|body|var|theory).xml/); - return 0; -} -my @todo = (getcwd()); -while (my $dir = shift @todo) { - print "$dir\n"; - chdir $dir or die "Can't chdir to $dir\n"; - open LS, 'ls | sed \'s/\\.gz//\' | sort | uniq |'; - open INDEX, "> $index_fname" - or die "Can't open $index_fname in " . getcwd() . "\n"; - while (my $entry = ) { - chomp $entry; - if (-d $entry) { - print INDEX add_trailing_slash($entry) . "\n"; - push @todo, getcwd() . "/$entry"; - } else { - print INDEX "$entry\n" if indexable($entry); - } - } - close INDEX; - close LS; -} diff --git a/helm/ocaml/getter/sample.conf.xml b/helm/ocaml/getter/sample.conf.xml deleted file mode 100644 index 54cdc2557..000000000 --- a/helm/ocaml/getter/sample.conf.xml +++ /dev/null @@ -1,50 +0,0 @@ - -
- /tmp/helm/cache - /projects/helm/xml/dtd - 58081 - 180 - http_getter.log - - theory:/ file:///projects/helm/library/theories/ - - - xslt:/ file:///projects/helm/xml/stylesheets_ccorn/ - - - xslt:/ file:///projects/helm/xml/stylesheets_hanane/ - - - xslt:/ file:///projects/helm/xml/on-line/xslt/ - - - xslt:/ file:///projects/helm/nuprl/NuPRL/nuprl_stylesheets/ - - - nuprl:/ http://www.cs.uwyo.edu/~nuprl/helm-library/ - - - xslt:/ file:///projects/helm/xml/stylesheets/ - - - xslt:/ file:///projects/helm/xml/stylesheets/generated/ - - - theory:/residual_theory_in_lambda_calculus/ - http://helm.cs.unibo.it/~sacerdot/huet_lambda_calculus_mowgli/residual_theory_in_lambda_calculus/ - - - theory:/IDA/ - http://mowgli.cs.unibo.it/~sacerdot/ida/IDA/ - - - cic:/ file:///projects/helm/library/coq_contribs/ - legacy - - - cic:/matita/ - file:///projects/helm/library/matita/ - ro - -
- diff --git a/helm/ocaml/getter/test.ml b/helm/ocaml/getter/test.ml deleted file mode 100644 index 6fa236fd0..000000000 --- a/helm/ocaml/getter/test.ml +++ /dev/null @@ -1,12 +0,0 @@ -(* $Id$ *) - -let _ = Helm_registry.load_from "foo.conf.xml" -let fname = Http_getter.getxml ~format:`Normal ~patch_dtd:true Sys.argv.(1) in -let ic = open_in fname in -(try - while true do - let line = input_line ic in - print_endline line - done -with End_of_file -> ()) - diff --git a/helm/ocaml/grafite/.depend b/helm/ocaml/grafite/.depend deleted file mode 100644 index dc225e221..000000000 --- a/helm/ocaml/grafite/.depend +++ /dev/null @@ -1,6 +0,0 @@ -grafiteAstPp.cmi: grafiteAst.cmo -grafiteMarshal.cmi: grafiteAst.cmo -grafiteAstPp.cmo: grafiteAst.cmo grafiteAstPp.cmi -grafiteAstPp.cmx: grafiteAst.cmx grafiteAstPp.cmi -grafiteMarshal.cmo: grafiteAstPp.cmi grafiteAst.cmo grafiteMarshal.cmi -grafiteMarshal.cmx: grafiteAstPp.cmx grafiteAst.cmx grafiteMarshal.cmi diff --git a/helm/ocaml/grafite/Makefile b/helm/ocaml/grafite/Makefile deleted file mode 100644 index 6eb3e7a78..000000000 --- a/helm/ocaml/grafite/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -PACKAGE = grafite -PREDICATES = - -INTERFACE_FILES = \ - grafiteAstPp.mli \ - grafiteMarshal.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - grafiteAst.ml \ - $(INTERFACE_FILES:%.mli=%.ml) - - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/grafite/grafiteAst.ml b/helm/ocaml/grafite/grafiteAst.ml deleted file mode 100644 index 6c51fc80a..000000000 --- a/helm/ocaml/grafite/grafiteAst.ml +++ /dev/null @@ -1,168 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type direction = [ `LeftToRight | `RightToLeft ] - -type loc = Token.flocation - -type ('term, 'lazy_term, 'ident) pattern = - 'lazy_term option * ('ident * 'term) list * 'term option - -type ('term, 'ident) type_spec = - | Ident of 'ident - | Type of UriManager.uri * int - -type 'lazy_term reduction = - [ `Demodulate - | `Normalize - | `Reduce - | `Simpl - | `Unfold of 'lazy_term option - | `Whd ] - -type ('term, 'lazy_term, 'reduction, 'ident) tactic = - | Absurd of loc * 'term - | Apply of loc * 'term - | Assumption of loc - | Auto of loc * int option * int option * string option * string option - (* depth, width, paramodulation, full *) (* ALB *) - | Change of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term - | Clear of loc * 'ident - | ClearBody of loc * 'ident - | Compare of loc * 'term - | Constructor of loc * int - | Contradiction of loc - | Cut of loc * 'ident option * 'term - | DecideEquality of loc - | Decompose of loc * ('term, 'ident) type_spec list * 'ident * 'ident list - | Discriminate of loc * 'term - | Elim of loc * 'term * 'term option * int option * 'ident list - | ElimType of loc * 'term * 'term option * int option * 'ident list - | Exact of loc * 'term - | Exists of loc - | Fail of loc - | Fold of loc * 'reduction * 'lazy_term * ('term, 'lazy_term, 'ident) pattern - | Fourier of loc - | FwdSimpl of loc * string * 'ident list - | Generalize of loc * ('term, 'lazy_term, 'ident) pattern * 'ident option - | Goal of loc * int (* change current goal, argument is goal number 1-based *) - | IdTac of loc - | Injection of loc * 'term - | Intros of loc * int option * 'ident list - | Inversion of loc * 'term - | LApply of loc * int option * 'term list * 'term * 'ident option - | Left of loc - | LetIn of loc * 'term * 'ident - | Reduce of loc * 'reduction * ('term, 'lazy_term, 'ident) pattern - | Reflexivity of loc - | Replace of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term - | Rewrite of loc * direction * 'term * - ('term, 'lazy_term, 'ident) pattern - | Right of loc - | Ring of loc - | Split of loc - | Symmetry of loc - | Transitivity of loc * 'term - -type search_kind = [ `Locate | `Hint | `Match | `Elim ] - -type print_kind = [ `Env | `Coer ] - -type 'term macro = - (* Whelp's stuff *) - | WHint of loc * 'term - | WMatch of loc * 'term - | WInstance of loc * 'term - | WLocate of loc * string - | WElim of loc * 'term - (* real macros *) -(* | Abort of loc *) - | Print of loc * string - | Check of loc * 'term - | Hint of loc - | Quit of loc -(* | Redo of loc * int option - | Undo of loc * int option *) -(* | Print of loc * print_kind *) - | Search_pat of loc * search_kind * string (* searches with string pattern *) - | Search_term of loc * search_kind * 'term (* searches with term pattern *) - -(** To be increased each time the command type below changes, used for "safe" - * marshalling *) -let magic = 5 - -type 'obj command = - | Default of loc * string * UriManager.uri list - | Include of loc * string - | Set of loc * string * string - | Drop of loc - | Qed of loc - | Coercion of loc * UriManager.uri * bool (* add composites *) - | Obj of loc * 'obj - -type ('term, 'lazy_term, 'reduction, 'ident) tactical = - | Tactic of loc * ('term, 'lazy_term, 'reduction, 'ident) tactic - | Do of loc * int * ('term, 'lazy_term, 'reduction, 'ident) tactical - | Repeat of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical - | Seq of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list - (* sequential composition *) - | Then of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical * - ('term, 'lazy_term, 'reduction, 'ident) tactical list - | First of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list - (* try a sequence of loc * tactical until one succeeds, fail otherwise *) - | Try of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical - (* try a tactical and mask failures *) - | Solve of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list - - | Dot of loc - | Semicolon of loc - | Branch of loc - | Shift of loc - | Pos of loc * int - | Merge of loc - | Focus of loc * int list - | Unfocus of loc - | Skip of loc - -let is_punctuation = - function - | Dot _ | Semicolon _ | Branch _ | Shift _ | Merge _ | Pos _ -> true - | _ -> false - -type ('term, 'lazy_term, 'reduction, 'obj, 'ident) code = - | Command of loc * 'obj command - | Macro of loc * 'term macro - | Tactical of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical - * ('term, 'lazy_term, 'reduction, 'ident) tactical option(* punctuation *) - -type ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment = - | Note of loc * string - | Code of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code - -type ('term, 'lazy_term, 'reduction, 'obj, 'ident) statement = - | Executable of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code - | Comment of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment diff --git a/helm/ocaml/grafite/grafiteAstPp.ml b/helm/ocaml/grafite/grafiteAstPp.ml deleted file mode 100644 index 8bd5c96f1..000000000 --- a/helm/ocaml/grafite/grafiteAstPp.ml +++ /dev/null @@ -1,254 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open GrafiteAst - -let tactical_terminator = "" -let tactic_terminator = tactical_terminator -let command_terminator = tactical_terminator - -let pp_idents idents = "[" ^ String.concat "; " idents ^ "]" - -let pp_reduction_kind ~term_pp = function - | `Demodulate -> "demodulate" - | `Normalize -> "normalize" - | `Reduce -> "reduce" - | `Simpl -> "simplify" - | `Unfold (Some t) -> "unfold " ^ term_pp t - | `Unfold None -> "unfold" - | `Whd -> "whd" - -let pp_tactic_pattern ~term_pp ~lazy_term_pp (what, hyp, goal) = - let what_text = - match what with - | None -> "" - | Some t -> sprintf "in match (%s) " (lazy_term_pp t) in - let hyp_text = - String.concat " " - (List.map (fun (name, p) -> sprintf "%s:(%s)" name (term_pp p)) hyp) in - let goal_text = - match goal with - | None -> "" - | Some t -> sprintf "\\vdash (%s)" (term_pp t) in - sprintf "%sin %s%s" what_text hyp_text goal_text - -let pp_intros_specs = function - | None, [] -> "" - | Some num, [] -> Printf.sprintf " names %i" num - | None, idents -> Printf.sprintf " names %s" (pp_idents idents) - | Some num, idents -> Printf.sprintf " names %i %s" num (pp_idents idents) - -let terms_pp ~term_pp terms = String.concat ", " (List.map term_pp terms) - -let rec pp_tactic ~term_pp ~lazy_term_pp = - let pp_reduction_kind = pp_reduction_kind ~term_pp in - let pp_tactic_pattern = pp_tactic_pattern ~lazy_term_pp ~term_pp in - function - | Absurd (_, term) -> "absurd" ^ term_pp term - | Apply (_, term) -> "apply " ^ term_pp term - | Auto _ -> "auto" - | Assumption _ -> "assumption" - | Change (_, where, with_what) -> - sprintf "change %s with %s" (pp_tactic_pattern where) (lazy_term_pp with_what) - | Clear (_,id) -> sprintf "clear %s" id - | ClearBody (_,id) -> sprintf "clearbody %s" id - | Compare (_,term) -> "compare " ^ term_pp term - | Constructor (_,n) -> "constructor " ^ string_of_int n - | Contradiction _ -> "contradiction" - | Cut (_, ident, term) -> - "cut " ^ term_pp term ^ - (match ident with None -> "" | Some id -> " as " ^ id) - | DecideEquality _ -> "decide equality" - | Decompose (_, [], what, names) -> - sprintf "decompose %s%s" what (pp_intros_specs (None, names)) - | Decompose (_, types, what, names) -> - let to_ident = function - | Ident id -> id - | Type _ -> assert false - in - let types = List.rev_map to_ident types in - sprintf "decompose %s %s%s" (pp_idents types) what (pp_intros_specs (None, names)) - | Discriminate (_, term) -> "discriminate " ^ term_pp term - | Elim (_, term, using, num, idents) -> - sprintf "elim " ^ term_pp term ^ - (match using with None -> "" | Some term -> " using " ^ term_pp term) - ^ pp_intros_specs (num, idents) - | ElimType (_, term, using, num, idents) -> - sprintf "elim type " ^ term_pp term ^ - (match using with None -> "" | Some term -> " using " ^ term_pp term) - ^ pp_intros_specs (num, idents) - | Exact (_, term) -> "exact " ^ term_pp term - | Exists _ -> "exists" - | Fold (_, kind, term, pattern) -> - sprintf "fold %s %s %s" (pp_reduction_kind kind) - (lazy_term_pp term) (pp_tactic_pattern pattern) - | FwdSimpl (_, hyp, idents) -> - sprintf "fwd %s%s" hyp - (match idents with [] -> "" | idents -> " " ^ pp_idents idents) - | Generalize (_, pattern, ident) -> - sprintf "generalize %s%s" (pp_tactic_pattern pattern) - (match ident with None -> "" | Some id -> " as " ^ id) - | Goal (_, n) -> "goal " ^ string_of_int n - | Fail _ -> "fail" - | Fourier _ -> "fourier" - | IdTac _ -> "id" - | Injection (_, term) -> "injection " ^ term_pp term - | Intros (_, None, []) -> "intro" - | Inversion (_, term) -> "inversion " ^ term_pp term - | Intros (_, num, idents) -> - sprintf "intros%s%s" - (match num with None -> "" | Some num -> " " ^ string_of_int num) - (match idents with [] -> "" | idents -> " " ^ pp_idents idents) - | LApply (_, level_opt, terms, term, ident_opt) -> - sprintf "lapply %s%s%s%s" - (match level_opt with None -> "" | Some i -> " depth = " ^ string_of_int i ^ " ") - (term_pp term) - (match terms with [] -> "" | _ -> " to " ^ terms_pp ~term_pp terms) - (match ident_opt with None -> "" | Some ident -> " using " ^ ident) - | Left _ -> "left" - | LetIn (_, term, ident) -> sprintf "let %s in %s" (term_pp term) ident - | Reduce (_, kind, pat) -> - sprintf "%s %s" (pp_reduction_kind kind) (pp_tactic_pattern pat) - | Reflexivity _ -> "reflexivity" - | Replace (_, pattern, t) -> - sprintf "replace %s with %s" (pp_tactic_pattern pattern) (lazy_term_pp t) - | Rewrite (_, pos, t, pattern) -> - sprintf "rewrite %s %s %s" - (if pos = `LeftToRight then ">" else "<") - (term_pp t) - (pp_tactic_pattern pattern) - | Right _ -> "right" - | Ring _ -> "ring" - | Split _ -> "split" - | Symmetry _ -> "symmetry" - | Transitivity (_, term) -> "transitivity " ^ term_pp term - -let pp_search_kind = function - | `Locate -> "locate" - | `Hint -> "hint" - | `Match -> "match" - | `Elim -> "elim" - | `Instance -> "instance" - -let pp_macro ~term_pp = function - (* Whelp *) - | WInstance (_, term) -> "whelp instance " ^ term_pp term - | WHint (_, t) -> "whelp hint " ^ term_pp t - | WLocate (_, s) -> "whelp locate " ^ s - | WElim (_, t) -> "whelp elim " ^ term_pp t - | WMatch (_, term) -> "whelp match " ^ term_pp term - (* real macros *) - | Check (_, term) -> sprintf "Check %s" (term_pp term) - | Hint _ -> "hint" - | Search_pat (_, kind, pat) -> - sprintf "search %s \"%s\"" (pp_search_kind kind) pat - | Search_term (_, kind, term) -> - sprintf "search %s %s" (pp_search_kind kind) (term_pp term) - | Print (_, name) -> sprintf "Print \"%s\"" name - | Quit _ -> "Quit" - -let pp_associativity = function - | Gramext.LeftA -> "left associative" - | Gramext.RightA -> "right associative" - | Gramext.NonA -> "non associative" - -let pp_precedence i = sprintf "with precedence %d" i - -let pp_dir_opt = function - | None -> "" - | Some `LeftToRight -> "> " - | Some `RightToLeft -> "< " - -let pp_default what uris = - sprintf "default \"%s\" %s" what - (String.concat " " (List.map UriManager.string_of_uri uris)) - -let pp_coercion uri do_composites = - sprintf "coercion %s (* %s *)" (UriManager.string_of_uri uri) - (if do_composites then "compounds" else "no compounds") - -let pp_command ~obj_pp = function - | Include (_,path) -> "include " ^ path - | Qed _ -> "qed" - | Drop _ -> "drop" - | Set (_, name, value) -> sprintf "set \"%s\" \"%s\"" name value - | Coercion (_, uri, do_composites) -> pp_coercion uri do_composites - | Obj (_,obj) -> obj_pp obj - | Default (_,what,uris) -> - pp_default what uris - -let rec pp_tactical ~term_pp ~lazy_term_pp = - let pp_tactic = pp_tactic ~lazy_term_pp ~term_pp in - let pp_tacticals = pp_tacticals ~lazy_term_pp ~term_pp in - function - | Tactic (_, tac) -> pp_tactic tac - | Do (_, count, tac) -> - sprintf "do %d %s" count (pp_tactical ~term_pp ~lazy_term_pp tac) - | Repeat (_, tac) -> "repeat " ^ pp_tactical ~term_pp ~lazy_term_pp tac - | Seq (_, tacs) -> pp_tacticals ~sep:"; " tacs - | Then (_, tac, tacs) -> - sprintf "%s; [%s]" (pp_tactical ~term_pp ~lazy_term_pp tac) - (pp_tacticals ~sep:" | " tacs) - | First (_, tacs) -> sprintf "tries [%s]" (pp_tacticals ~sep:" | " tacs) - | Try (_, tac) -> "try " ^ pp_tactical ~term_pp ~lazy_term_pp tac - | Solve (_, tac) -> sprintf "solve [%s]" (pp_tacticals ~sep:" | " tac) - - | Dot _ -> "." - | Semicolon _ -> ";" - | Branch _ -> "[" - | Shift _ -> "|" - | Pos (_, i) -> sprintf "%d:" i - | Merge _ -> "]" - | Focus (_, goals) -> - sprintf "focus %s" (String.concat " " (List.map string_of_int goals)) - | Unfocus _ -> "unfocus" - | Skip _ -> "skip" - -and pp_tacticals ~term_pp ~lazy_term_pp ~sep tacs = - String.concat sep (List.map (pp_tactical~lazy_term_pp ~term_pp) tacs) - -let pp_executable ~term_pp ~lazy_term_pp ~obj_pp = - function - | Macro (_, macro) -> pp_macro ~term_pp macro - | Tactical (_, tac, Some punct) -> - pp_tactical ~lazy_term_pp ~term_pp tac - ^ pp_tactical ~lazy_term_pp ~term_pp punct - | Tactical (_, tac, None) -> pp_tactical ~lazy_term_pp ~term_pp tac - | Command (_, cmd) -> pp_command ~obj_pp cmd - -let pp_comment ~term_pp ~lazy_term_pp ~obj_pp = - function - | Note (_,str) -> sprintf "(* %s *)" str - | Code (_,code) -> - sprintf "(** %s. **)" (pp_executable ~term_pp ~lazy_term_pp ~obj_pp code) - -let pp_statement ~term_pp ~lazy_term_pp ~obj_pp = - function - | Executable (_, ex) -> pp_executable ~lazy_term_pp ~term_pp ~obj_pp ex - | Comment (_, c) -> pp_comment ~term_pp ~lazy_term_pp ~obj_pp c diff --git a/helm/ocaml/grafite/grafiteAstPp.mli b/helm/ocaml/grafite/grafiteAstPp.mli deleted file mode 100644 index f9b3b37cc..000000000 --- a/helm/ocaml/grafite/grafiteAstPp.mli +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -val pp_tactic: - term_pp:('term -> string) -> - lazy_term_pp:('lazy_term -> string) -> - ('term, 'lazy_term, 'term GrafiteAst.reduction, string) - GrafiteAst.tactic -> - string - -val pp_tactic_pattern: - term_pp:('term -> string) -> - lazy_term_pp:('lazy_term -> string) -> - ('term, 'lazy_term, string) GrafiteAst.pattern -> - string - -val pp_reduction_kind: - term_pp:('a -> string) -> - 'a GrafiteAst.reduction -> - string - -val pp_command: obj_pp:('obj -> string) -> 'obj GrafiteAst.command -> string -val pp_macro: term_pp:('term -> string) -> 'term GrafiteAst.macro -> string -val pp_comment: - term_pp:('term -> string) -> - lazy_term_pp:('lazy_term -> string) -> - obj_pp:('obj -> string) -> - ('term, 'lazy_term, 'term GrafiteAst.reduction, 'obj, string) - GrafiteAst.comment -> - string - -val pp_executable: - term_pp:('term -> string) -> - lazy_term_pp:('lazy_term -> string) -> - obj_pp:('obj -> string) -> - ('term, 'lazy_term, 'term GrafiteAst.reduction, 'obj, string) - GrafiteAst.code -> - string - -val pp_statement: - term_pp:('term -> string) -> - lazy_term_pp:('lazy_term -> string) -> - obj_pp:('obj -> string) -> - ('term, 'lazy_term, 'term GrafiteAst.reduction, 'obj, string) - GrafiteAst.statement -> - string - -val pp_tactical: - term_pp:('term -> string) -> - lazy_term_pp:('lazy_term -> string) -> - ('term, 'lazy_term, 'term GrafiteAst.reduction, string) - GrafiteAst.tactical -> - string - diff --git a/helm/ocaml/grafite/grafiteMarshal.ml b/helm/ocaml/grafite/grafiteMarshal.ml deleted file mode 100644 index e786d5001..000000000 --- a/helm/ocaml/grafite/grafiteMarshal.ml +++ /dev/null @@ -1,60 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type ast_command = Cic.obj GrafiteAst.command -type moo = ast_command list - -let format_name = "grafite" - -let save_moo_to_file ~fname moo = - HMarshal.save ~fmt:format_name ~version:GrafiteAst.magic ~fname moo - -let load_moo_from_file ~fname = - let raw = HMarshal.load ~fmt:format_name ~version:GrafiteAst.magic ~fname in - (raw: moo) - -let rehash_cmd_uris = - let rehash_uri uri = - UriManager.uri_of_string (UriManager.string_of_uri uri) in - function - | GrafiteAst.Default (loc, name, uris) -> - let uris = List.map rehash_uri uris in - GrafiteAst.Default (loc, name, uris) - | GrafiteAst.Coercion (loc, uri, close) -> - GrafiteAst.Coercion (loc, rehash_uri uri, close) - | cmd -> - prerr_endline "Found a command not expected in a .moo:"; - let obj_pp _ = assert false in - prerr_endline (GrafiteAstPp.pp_command ~obj_pp cmd); - assert false - -let save_moo ~fname moo = save_moo_to_file ~fname (List.rev moo) - -let load_moo ~fname = - let moo = load_moo_from_file ~fname in - List.map rehash_cmd_uris moo - diff --git a/helm/ocaml/grafite/grafiteMarshal.mli b/helm/ocaml/grafite/grafiteMarshal.mli deleted file mode 100644 index e60ad39d8..000000000 --- a/helm/ocaml/grafite/grafiteMarshal.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -type ast_command = Cic.obj GrafiteAst.command -type moo = ast_command list - -val save_moo: fname:string -> moo -> unit - - (** @raise Corrupt_moo *) -val load_moo: fname:string -> moo - diff --git a/helm/ocaml/grafite_engine/.depend b/helm/ocaml/grafite_engine/.depend deleted file mode 100644 index d0e9a3a86..000000000 --- a/helm/ocaml/grafite_engine/.depend +++ /dev/null @@ -1,12 +0,0 @@ -grafiteSync.cmi: grafiteTypes.cmi -grafiteEngine.cmi: grafiteTypes.cmi -grafiteTypes.cmo: grafiteTypes.cmi -grafiteTypes.cmx: grafiteTypes.cmi -grafiteSync.cmo: grafiteTypes.cmi grafiteSync.cmi -grafiteSync.cmx: grafiteTypes.cmx grafiteSync.cmi -grafiteMisc.cmo: grafiteMisc.cmi -grafiteMisc.cmx: grafiteMisc.cmi -grafiteEngine.cmo: grafiteTypes.cmi grafiteSync.cmi grafiteMisc.cmi \ - grafiteEngine.cmi -grafiteEngine.cmx: grafiteTypes.cmx grafiteSync.cmx grafiteMisc.cmx \ - grafiteEngine.cmi diff --git a/helm/ocaml/grafite_engine/Makefile b/helm/ocaml/grafite_engine/Makefile deleted file mode 100644 index d810e1be2..000000000 --- a/helm/ocaml/grafite_engine/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -PACKAGE = grafite_engine -PREDICATES = - -INTERFACE_FILES = \ - grafiteTypes.mli \ - grafiteSync.mli \ - grafiteMisc.mli \ - grafiteEngine.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/grafite_engine/grafiteEngine.ml b/helm/ocaml/grafite_engine/grafiteEngine.ml deleted file mode 100644 index 65dd17b6a..000000000 --- a/helm/ocaml/grafite_engine/grafiteEngine.ml +++ /dev/null @@ -1,714 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -exception Drop -exception IncludedFileNotCompiled of string (* file name *) -exception Macro of - GrafiteAst.loc * - (Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -exception ReadOnlyUri of string - -type options = { - do_heavy_checks: bool ; - clean_baseuri: bool -} - -(** create a ProofEngineTypes.mk_fresh_name_type function which uses given - * names as long as they are available, then it fallbacks to name generation - * using FreshNamesGenerator module *) -let namer_of names = - let len = List.length names in - let count = ref 0 in - fun metasenv context name ~typ -> - if !count < len then begin - let name = Cic.Name (List.nth names !count) in - incr count; - name - end else - FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ - -let tactic_of_ast ast = - let module PET = ProofEngineTypes in - match ast with - | GrafiteAst.Absurd (_, term) -> Tactics.absurd term - | GrafiteAst.Apply (_, term) -> Tactics.apply term - | GrafiteAst.Assumption _ -> Tactics.assumption - | GrafiteAst.Auto (_,depth,width,paramodulation,full) -> - AutoTactic.auto_tac ?depth ?width ?paramodulation ?full - ~dbd:(LibraryDb.instance ()) () - | GrafiteAst.Change (_, pattern, with_what) -> - Tactics.change ~pattern with_what - | GrafiteAst.Clear (_,id) -> Tactics.clear id - | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id - | GrafiteAst.Contradiction _ -> Tactics.contradiction - | GrafiteAst.Compare (_, term) -> Tactics.compare term - | GrafiteAst.Constructor (_, n) -> Tactics.constructor n - | GrafiteAst.Cut (_, ident, term) -> - let names = match ident with None -> [] | Some id -> [id] in - Tactics.cut ~mk_fresh_name_callback:(namer_of names) term - | GrafiteAst.DecideEquality _ -> Tactics.decide_equality - | GrafiteAst.Decompose (_, types, what, names) -> - let to_type = function - | GrafiteAst.Type (uri, typeno) -> uri, typeno - | GrafiteAst.Ident _ -> assert false - in - let user_types = List.rev_map to_type types in - let dbd = LibraryDb.instance () in - let mk_fresh_name_callback = namer_of names in - Tactics.decompose ~mk_fresh_name_callback ~dbd ~user_types what - | GrafiteAst.Discriminate (_,term) -> Tactics.discriminate term - | GrafiteAst.Elim (_, what, using, depth, names) -> - Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names) - what - | GrafiteAst.ElimType (_, what, using, depth, names) -> - Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names) - what - | GrafiteAst.Exact (_, term) -> Tactics.exact term - | GrafiteAst.Exists _ -> Tactics.exists - | GrafiteAst.Fail _ -> Tactics.fail - | GrafiteAst.Fold (_, reduction_kind, term, pattern) -> - let reduction = - match reduction_kind with - | `Demodulate -> - GrafiteTypes.command_error "demodulation can't be folded" - | `Normalize -> - PET.const_lazy_reduction - (CicReduction.normalize ~delta:false ~subst:[]) - | `Reduce -> PET.const_lazy_reduction ProofEngineReduction.reduce - | `Simpl -> PET.const_lazy_reduction ProofEngineReduction.simpl - | `Unfold None -> - PET.const_lazy_reduction (ProofEngineReduction.unfold ?what:None) - | `Unfold (Some lazy_term) -> - (fun context metasenv ugraph -> - let what, metasenv, ugraph = lazy_term context metasenv ugraph in - ProofEngineReduction.unfold ~what, metasenv, ugraph) - | `Whd -> - PET.const_lazy_reduction (CicReduction.whd ~delta:false ~subst:[]) - in - Tactics.fold ~reduction ~term ~pattern - | GrafiteAst.Fourier _ -> Tactics.fourier - | GrafiteAst.FwdSimpl (_, hyp, names) -> - Tactics.fwd_simpl ~mk_fresh_name_callback:(namer_of names) - ~dbd:(LibraryDb.instance ()) hyp - | GrafiteAst.Generalize (_,pattern,ident) -> - let names = match ident with None -> [] | Some id -> [id] in - Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern - | GrafiteAst.Goal (_, n) -> Tactics.set_goal n - | GrafiteAst.IdTac _ -> Tactics.id - | GrafiteAst.Injection (_,term) -> Tactics.injection term - | GrafiteAst.Intros (_, None, names) -> - PrimitiveTactics.intros_tac ~mk_fresh_name_callback:(namer_of names) () - | GrafiteAst.Intros (_, Some num, names) -> - PrimitiveTactics.intros_tac ~howmany:num - ~mk_fresh_name_callback:(namer_of names) () - | GrafiteAst.Inversion (_, term) -> - Tactics.inversion term - | GrafiteAst.LApply (_, how_many, to_what, what, ident) -> - let names = match ident with None -> [] | Some id -> [id] in - Tactics.lapply ~mk_fresh_name_callback:(namer_of names) ?how_many - ~to_what what - | GrafiteAst.Left _ -> Tactics.left - | GrafiteAst.LetIn (loc,term,name) -> - Tactics.letin term ~mk_fresh_name_callback:(namer_of [name]) - | GrafiteAst.Reduce (_, reduction_kind, pattern) -> - (match reduction_kind with - | `Demodulate -> Tactics.demodulate ~dbd:(LibraryDb.instance ()) ~pattern - | `Normalize -> Tactics.normalize ~pattern - | `Reduce -> Tactics.reduce ~pattern - | `Simpl -> Tactics.simpl ~pattern - | `Unfold what -> Tactics.unfold ~pattern what - | `Whd -> Tactics.whd ~pattern) - | GrafiteAst.Reflexivity _ -> Tactics.reflexivity - | GrafiteAst.Replace (_, pattern, with_what) -> - Tactics.replace ~pattern ~with_what - | GrafiteAst.Rewrite (_, direction, t, pattern) -> - EqualityTactics.rewrite_tac ~direction ~pattern t - | GrafiteAst.Right _ -> Tactics.right - | GrafiteAst.Ring _ -> Tactics.ring - | GrafiteAst.Split _ -> Tactics.split - | GrafiteAst.Symmetry _ -> Tactics.symmetry - | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term - -(* maybe we only need special cases for apply and goal *) -let classify_tactic tactic = - match tactic with - (* tactics that can't close the goal (return a goal we want to "select") *) - | GrafiteAst.Rewrite _ - | GrafiteAst.Split _ - | GrafiteAst.Replace _ - | GrafiteAst.Reduce _ - | GrafiteAst.Injection _ - | GrafiteAst.IdTac _ - | GrafiteAst.Generalize _ - | GrafiteAst.Elim _ - | GrafiteAst.Cut _ - | GrafiteAst.Decompose _ -> true, true - (* tactics we don't want to reorder goals. I think only Goal needs this. *) - | GrafiteAst.Goal _ -> false, true - (* tactics like apply *) - | _ -> true, false - -let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal= - let module PEH = ProofEngineHelpers in -(* let print_m name metasenv = - prerr_endline (">>>>> " ^ name); - prerr_endline (CicMetaSubst.ppmetasenv [] metasenv) - in *) - (* phase one calculates: - * new_goals_from_refine: goals added by refine - * head_goal: the first goal opened by ythe tactic - * other_goals: other goals opened by the tactic - *) - let new_goals_from_refine = PEH.compare_metasenvs start refine in - let new_goals_from_tactic = PEH.compare_metasenvs refine tactic in - let head_goal, other_goals, goals = - match goals with - | [] -> None,[],goals - | hd::tl -> - (* assert (List.mem hd new_goals_from_tactic); - * invalidato dalla goal_tac - * *) - Some hd, List.filter ((<>) hd) new_goals_from_tactic, List.filter ((<>) - hd) goals - in - let produced_goals = - match head_goal with - | None -> new_goals_from_refine @ other_goals - | Some x -> x :: new_goals_from_refine @ other_goals - in - (* extract the metas generated by refine and tactic *) - let metas_for_tactic_head = - match head_goal with - | None -> [] - | Some head_goal -> List.filter (fun (n,_,_) -> n = head_goal) tactic in - let metas_for_tactic_goals = - List.map - (fun x -> List.find (fun (metano,_,_) -> metano = x) tactic) - goals - in - let metas_for_refine_goals = - List.filter (fun (n,_,_) -> List.mem n new_goals_from_refine) tactic in - let produced_metas, goals = - let produced_metas = - if always_opens_a_goal then - metas_for_tactic_head @ metas_for_refine_goals @ - metas_for_tactic_goals - else begin -(* print_m "metas_for_refine_goals" metas_for_refine_goals; - print_m "metas_for_tactic_head" metas_for_tactic_head; - print_m "metas_for_tactic_goals" metas_for_tactic_goals; *) - metas_for_refine_goals @ metas_for_tactic_head @ - metas_for_tactic_goals - end - in - let goals = List.map (fun (metano, _, _) -> metano) produced_metas in - produced_metas, goals - in - (* residual metas, preserving the original order *) - let before, after = - let rec split e = - function - | [] -> [],[] - | (metano, _, _) :: tl when metano = e -> - [], List.map (fun (x,_,_) -> x) tl - | (metano, _, _) :: tl -> let b, a = split e tl in metano :: b, a - in - let find n metasenv = - try - Some (List.find (fun (metano, _, _) -> metano = n) metasenv) - with Not_found -> None - in - let extract l = - List.fold_right - (fun n acc -> - match find n tactic with - | Some x -> x::acc - | None -> acc - ) l [] in - let before_l, after_l = split current_goal start in - let before_l = - List.filter (fun x -> not (List.mem x produced_goals)) before_l in - let after_l = - List.filter (fun x -> not (List.mem x produced_goals)) after_l in - let before = extract before_l in - let after = extract after_l in - before, after - in -(* |+ DEBUG CODE +| - print_m "BEGIN" start; - prerr_endline ("goal was: " ^ string_of_int current_goal); - prerr_endline ("and metas from refine are:"); - List.iter - (fun t -> prerr_string (" " ^ string_of_int t)) - new_goals_from_refine; - prerr_endline ""; - print_m "before" before; - print_m "metas_for_tactic_head" metas_for_tactic_head; - print_m "metas_for_refine_goals" metas_for_refine_goals; - print_m "metas_for_tactic_goals" metas_for_tactic_goals; - print_m "produced_metas" produced_metas; - print_m "after" after; -|+ FINE DEBUG CODE +| *) - before @ produced_metas @ after, goals - -let apply_tactic ~disambiguate_tactic tactic (status, goal) = -(* prerr_endline "apply_tactic"; *) -(* prerr_endline (Continuationals.Stack.pp (GrafiteTypes.get_stack status)); *) - let starting_metasenv = GrafiteTypes.get_proof_metasenv status in - let before = List.map (fun g, _, _ -> g) starting_metasenv in -(* prerr_endline "disambiguate"; *) - let status, tactic = disambiguate_tactic status goal tactic in - let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in - let proof = GrafiteTypes.get_current_proof status in - let proof_status = proof, goal in - let needs_reordering, always_opens_a_goal = classify_tactic tactic in - let tactic = tactic_of_ast tactic in - (* apply tactic will change the lexicon_status ... *) -(* prerr_endline "apply_tactic bassa"; *) - let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in - let after = ProofEngineTypes.goals_of_proof proof in - let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in -(* prerr_endline("before: " ^ String.concat ", " (List.map string_of_int before)); -prerr_endline("after: " ^ String.concat ", " (List.map string_of_int after)); -prerr_endline("opened: " ^ String.concat ", " (List.map string_of_int opened)); *) -(* prerr_endline("opened_goals: " ^ String.concat ", " (List.map string_of_int opened_goals)); -prerr_endline("closed_goals: " ^ String.concat ", " (List.map string_of_int closed_goals)); *) - let proof, opened_goals = - if needs_reordering then begin - let uri, metasenv_after_tactic, t, ty = proof in -(* prerr_endline ("goal prima del riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof))); *) - let reordered_metasenv, opened_goals = - reorder_metasenv - starting_metasenv - metasenv_after_refinement metasenv_after_tactic - opened goal always_opens_a_goal - in - let proof' = uri, reordered_metasenv, t, ty in -(* prerr_endline ("goal dopo il riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof'))); *) - proof', opened_goals - end - else - proof, opened_goals - in - let incomplete_proof = - match status.GrafiteTypes.proof_status with - | GrafiteTypes.Incomplete_proof p -> p - | _ -> assert false - in - { status with GrafiteTypes.proof_status = - GrafiteTypes.Incomplete_proof - { incomplete_proof with GrafiteTypes.proof = proof } }, - opened_goals, closed_goals - -type eval_ast = - {ea_go: - 'term 'lazy_term 'reduction 'obj 'ident. - disambiguate_tactic: - (GrafiteTypes.status -> - ProofEngineTypes.goal -> - ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> - - disambiguate_command: - (GrafiteTypes.status -> - 'obj GrafiteAst.command -> - GrafiteTypes.status * Cic.obj GrafiteAst.command) -> - - disambiguate_macro: - (GrafiteTypes.status -> - 'term GrafiteAst.macro -> - Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -> - - ?do_heavy_checks:bool -> - ?clean_baseuri:bool -> - GrafiteTypes.status -> - ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement -> - GrafiteTypes.status * UriManager.uri list - } - -type 'a eval_command = - {ec_go: 'term 'obj. - disambiguate_command: - (GrafiteTypes.status -> - 'obj GrafiteAst.command -> - GrafiteTypes.status * Cic.obj GrafiteAst.command) -> - options -> GrafiteTypes.status -> 'obj GrafiteAst.command -> - GrafiteTypes.status * UriManager.uri list - } - -type 'a eval_executable = - {ee_go: 'term 'lazy_term 'reduction 'obj 'ident. - disambiguate_tactic: - (GrafiteTypes.status -> - ProofEngineTypes.goal -> - ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> - - disambiguate_command: - (GrafiteTypes.status -> - 'obj GrafiteAst.command -> - GrafiteTypes.status * Cic.obj GrafiteAst.command) -> - - disambiguate_macro: - (GrafiteTypes.status -> - 'term GrafiteAst.macro -> - Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -> - - options -> - GrafiteTypes.status -> - ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.code -> - GrafiteTypes.status * UriManager.uri list - } - -type 'a eval_from_moo = - { efm_go: GrafiteTypes.status -> string -> GrafiteTypes.status } - -let coercion_moo_statement_of uri = - GrafiteAst.Coercion (HExtlib.dummy_floc, uri, false) - -let eval_coercion status ~add_composites uri = - let basedir = Helm_registry.get "matita.basedir" in - let status,compounds = - prerr_endline "evaluating a coercion command"; - GrafiteSync.add_coercion ~basedir ~add_composites status uri in - let moo_content = coercion_moo_statement_of uri in - let status = GrafiteTypes.add_moo_content [moo_content] status in - {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof}, - compounds - -let eval_tactical ~disambiguate_tactic status tac = - let apply_tactic = apply_tactic ~disambiguate_tactic in - let module MatitaStatus = - struct - type input_status = GrafiteTypes.status * ProofEngineTypes.goal - - type output_status = - GrafiteTypes.status * ProofEngineTypes.goal list * ProofEngineTypes.goal list - - type tactic = input_status -> output_status - - let id_tactic = apply_tactic (GrafiteAst.IdTac HExtlib.dummy_floc) - let mk_tactic tac = tac - let apply_tactic tac = tac - let goals (_, opened, closed) = opened, closed - let set_goals (opened, closed) (status, _, _) = (status, opened, closed) - let get_stack (status, _) = GrafiteTypes.get_stack status - - let set_stack stack (status, opened, closed) = - GrafiteTypes.set_stack stack status, opened, closed - - let inject (status, _) = (status, [], []) - let focus goal (status, _, _) = (status, goal) - end - in - let module MatitaTacticals = Tacticals.Make (MatitaStatus) in - let rec tactical_of_ast l tac = - match tac with - | GrafiteAst.Tactic (loc, tactic) -> - MatitaTacticals.tactic (MatitaStatus.mk_tactic (apply_tactic tactic)) - | GrafiteAst.Seq (loc, tacticals) -> (* tac1; tac2; ... *) - assert (l > 0); - MatitaTacticals.seq ~tactics:(List.map (tactical_of_ast (l+1)) tacticals) - | GrafiteAst.Do (loc, n, tactical) -> - MatitaTacticals.do_tactic ~n ~tactic:(tactical_of_ast (l+1) tactical) - | GrafiteAst.Repeat (loc, tactical) -> - MatitaTacticals.repeat_tactic ~tactic:(tactical_of_ast (l+1) tactical) - | GrafiteAst.Then (loc, tactical, tacticals) -> (* tac; [ tac1 | ... ] *) - assert (l > 0); - MatitaTacticals.thens ~start:(tactical_of_ast (l+1) tactical) - ~continuations:(List.map (tactical_of_ast (l+1)) tacticals) - | GrafiteAst.First (loc, tacticals) -> - MatitaTacticals.first - ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals) - | GrafiteAst.Try (loc, tactical) -> - MatitaTacticals.try_tactic ~tactic:(tactical_of_ast (l+1) tactical) - | GrafiteAst.Solve (loc, tacticals) -> - MatitaTacticals.solve_tactics - ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals) - - | GrafiteAst.Skip loc -> MatitaTacticals.skip - | GrafiteAst.Dot loc -> MatitaTacticals.dot - | GrafiteAst.Semicolon loc -> MatitaTacticals.semicolon - | GrafiteAst.Branch loc -> MatitaTacticals.branch - | GrafiteAst.Shift loc -> MatitaTacticals.shift - | GrafiteAst.Pos (loc, i) -> MatitaTacticals.pos i - | GrafiteAst.Merge loc -> MatitaTacticals.merge - | GrafiteAst.Focus (loc, goals) -> MatitaTacticals.focus goals - | GrafiteAst.Unfocus loc -> MatitaTacticals.unfocus - in - let status, _, _ = tactical_of_ast 0 tac (status, ~-1) in - let status = (* is proof completed? *) - match status.GrafiteTypes.proof_status with - | GrafiteTypes.Incomplete_proof - { GrafiteTypes.stack = stack; proof = proof } - when Continuationals.Stack.is_empty stack -> - { status with GrafiteTypes.proof_status = GrafiteTypes.Proof proof } - | _ -> status - in - status - -let eval_comment status c = status - -(* since the record syntax allows to declare coercions, we have to put this - * information inside the moo *) -let add_coercions_of_record_to_moo obj lemmas status = - let attributes = CicUtil.attributes_of_obj obj in - let is_record = function `Class (`Record att) -> Some att | _-> None in - match HExtlib.list_findopt is_record attributes with - | None -> status,[] - | Some fields -> - let is_a_coercion uri = - try - let obj,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri in - let attrs = CicUtil.attributes_of_obj obj in - List.mem (`Class `Projection) attrs - with Not_found -> assert false - in - (* looking at the fields we can know the 'wanted' coercions, but not the - * actually generated ones. So, only the intersection between the wanted - * and the actual should be in the moo as coercion, while everithing in - * lemmas should go as aliases *) - let wanted_coercions = - HExtlib.filter_map - (function - | (name,true) -> - Some - (UriManager.uri_of_string - (GrafiteTypes.qualify status name ^ ".con")) - | _ -> None) - fields - in - prerr_endline "wanted coercions:"; - List.iter - (fun u -> prerr_endline (UriManager.string_of_uri u)) - wanted_coercions; - let coercions, moo_content = - List.split - (HExtlib.filter_map - (fun uri -> - let is_a_wanted_coercion = - List.exists (UriManager.eq uri) wanted_coercions in - if is_a_coercion uri && is_a_wanted_coercion then - Some (uri, coercion_moo_statement_of uri) - else - None) - lemmas) - in - prerr_endline "actual coercions:"; - List.iter - (fun u -> prerr_endline (UriManager.string_of_uri u)) - coercions; - let status = GrafiteTypes.add_moo_content moo_content status in - {status with - GrafiteTypes.coercions = coercions @ status.GrafiteTypes.coercions}, - lemmas - -let add_obj uri obj status = - let basedir = Helm_registry.get "matita.basedir" in - let status,lemmas = GrafiteSync.add_obj ~basedir uri obj status in - status, lemmas - -let rec eval_command = {ec_go = fun ~disambiguate_command opts status cmd -> - let status,cmd = disambiguate_command status cmd in - let basedir = Helm_registry.get "matita.basedir" in - let status,uris = - match cmd with - | GrafiteAst.Default (loc, what, uris) as cmd -> - LibraryObjects.set_default what uris; - GrafiteTypes.add_moo_content [cmd] status,[] - | GrafiteAst.Include (loc, baseuri) -> - let moopath = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in - if not (Sys.file_exists moopath) then - raise (IncludedFileNotCompiled moopath); - let status = eval_from_moo.efm_go status moopath in - status,[] - | GrafiteAst.Set (loc, name, value) -> - if name = "baseuri" then begin - let value = - let v = Http_getter_misc.strip_trailing_slash value in - try - ignore (String.index v ' '); - GrafiteTypes.command_error "baseuri can't contain spaces" - with Not_found -> v - in - if Http_getter_storage.is_read_only value then begin - HLog.error (sprintf "uri %s belongs to a read-only repository" value); - raise (ReadOnlyUri value) - end; - if not (GrafiteMisc.is_empty value) && opts.clean_baseuri then begin - HLog.message ("baseuri " ^ value ^ " is not empty"); - HLog.message ("cleaning baseuri " ^ value); - LibraryClean.clean_baseuris ~basedir [value]; - end; - end; - GrafiteTypes.set_option status name value,[] - | GrafiteAst.Drop loc -> raise Drop - | GrafiteAst.Qed loc -> - let uri, metasenv, bo, ty = - match status.GrafiteTypes.proof_status with - | GrafiteTypes.Proof (Some uri, metasenv, body, ty) -> - uri, metasenv, body, ty - | GrafiteTypes.Proof (None, metasenv, body, ty) -> - raise (GrafiteTypes.Command_error - ("Someone allows to start a theorem without giving the "^ - "name/uri. This should be fixed!")) - | _-> - raise - (GrafiteTypes.Command_error "You can't Qed an incomplete theorem") - in - if metasenv <> [] then - raise - (GrafiteTypes.Command_error - "Proof not completed! metasenv is not empty!"); - let name = UriManager.name_of_uri uri in - let obj = Cic.Constant (name,Some bo,ty,[],[]) in - let status, lemmas = add_obj uri obj status in - {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof}, - uri::lemmas - | GrafiteAst.Coercion (loc, uri, add_composites) -> - eval_coercion status ~add_composites uri - | GrafiteAst.Obj (loc,obj) -> - let ext,name = - match obj with - Cic.Constant (name,_,_,_,_) - | Cic.CurrentProof (name,_,_,_,_,_) -> ".con",name - | Cic.InductiveDefinition (types,_,_,_) -> - ".ind", - (match types with (name,_,_,_)::_ -> name | _ -> assert false) - | _ -> assert false in - let uri = - UriManager.uri_of_string (GrafiteTypes.qualify status name ^ ext) - in - let metasenv = GrafiteTypes.get_proof_metasenv status in - match obj with - | Cic.CurrentProof (_,metasenv',bo,ty,_,_) -> - let name = UriManager.name_of_uri uri in - if not(CicPp.check name ty) then - HLog.error ("Bad name: " ^ name); - if opts.do_heavy_checks then - begin - let dbd = LibraryDb.instance () in - let similar = Whelp.match_term ~dbd ty in - let similar_len = List.length similar in - if similar_len> 30 then - (HLog.message - ("Duplicate check will compare your theorem with " ^ - string_of_int similar_len ^ - " theorems, this may take a while.")); - let convertible = - List.filter ( - fun u -> - let t = CicUtil.term_of_uri u in - let ty',g = - CicTypeChecker.type_of_aux' - metasenv' [] t CicUniv.empty_ugraph - in - fst(CicReduction.are_convertible [] ty' ty g)) - similar - in - (match convertible with - | [] -> () - | x::_ -> - HLog.warn - ("Theorem already proved: " ^ UriManager.string_of_uri x ^ - "\nPlease use a variant.")); - end; - assert (metasenv = metasenv'); - let initial_proof = (Some uri, metasenv, bo, ty) in - let initial_stack = Continuationals.Stack.of_metasenv metasenv in - { status with GrafiteTypes.proof_status = - GrafiteTypes.Incomplete_proof - { GrafiteTypes.proof = initial_proof; stack = initial_stack } }, - [] - | _ -> - if metasenv <> [] then - raise (GrafiteTypes.Command_error ( - "metasenv not empty while giving a definition with body: " ^ - CicMetaSubst.ppmetasenv [] metasenv)); - let status, lemmas = add_obj uri obj status in - let status,new_lemmas = - add_coercions_of_record_to_moo obj lemmas status - in - {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof}, - uri::new_lemmas@lemmas - in - match status.GrafiteTypes.proof_status with - GrafiteTypes.Intermediate _ -> - {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},uris - | _ -> status,uris - -} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro opts status ex -> - match ex with - | GrafiteAst.Tactical (_, tac, None) -> - eval_tactical ~disambiguate_tactic status tac,[] - | GrafiteAst.Tactical (_, tac, Some punct) -> - let status = eval_tactical ~disambiguate_tactic status tac in - eval_tactical ~disambiguate_tactic status punct,[] - | GrafiteAst.Command (_, cmd) -> - eval_command.ec_go ~disambiguate_command opts status cmd - | GrafiteAst.Macro (loc, macro) -> - raise (Macro (loc,disambiguate_macro status macro)) - -} and eval_from_moo = {efm_go = fun status fname -> - let ast_of_cmd cmd = - GrafiteAst.Executable (HExtlib.dummy_floc, - GrafiteAst.Command (HExtlib.dummy_floc, - cmd)) - in - let moo = GrafiteMarshal.load_moo fname in - List.fold_left - (fun status ast -> - let ast = ast_of_cmd ast in - let status,lemmas = - eval_ast.ea_go - ~disambiguate_tactic:(fun status _ tactic -> status,tactic) - ~disambiguate_command:(fun status cmd -> status,cmd) - ~disambiguate_macro:(fun _ _ -> assert false) - status ast - in - assert (lemmas=[]); - status) - status moo -} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro ?(do_heavy_checks=false) ?(clean_baseuri=true) status st --> - let opts = { - do_heavy_checks = do_heavy_checks ; - clean_baseuri = clean_baseuri } - in - match st with - | GrafiteAst.Executable (_,ex) -> - eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command - ~disambiguate_macro opts status ex - | GrafiteAst.Comment (_,c) -> eval_comment status c,[] -} - -let eval_ast = eval_ast.ea_go diff --git a/helm/ocaml/grafite_engine/grafiteEngine.mli b/helm/ocaml/grafite_engine/grafiteEngine.mli deleted file mode 100644 index ee5f3a157..000000000 --- a/helm/ocaml/grafite_engine/grafiteEngine.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -exception Drop -exception IncludedFileNotCompiled of string -exception Macro of - GrafiteAst.loc * - (Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) - -val eval_ast : - disambiguate_tactic: - (GrafiteTypes.status -> - ProofEngineTypes.goal -> - ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> - - disambiguate_command: - (GrafiteTypes.status -> - 'obj GrafiteAst.command -> - GrafiteTypes.status * Cic.obj GrafiteAst.command) -> - - disambiguate_macro: - (GrafiteTypes.status -> - 'term GrafiteAst.macro -> - Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -> - - ?do_heavy_checks:bool -> - ?clean_baseuri:bool -> - GrafiteTypes.status -> - ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement -> - (* the new status and generated objects, if any *) - GrafiteTypes.status * UriManager.uri list diff --git a/helm/ocaml/grafite_engine/grafiteMisc.ml b/helm/ocaml/grafite_engine/grafiteMisc.ml deleted file mode 100644 index 5b86293db..000000000 --- a/helm/ocaml/grafite_engine/grafiteMisc.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let is_empty buri = - List.for_all - (function - Http_getter_types.Ls_section _ -> true - | Http_getter_types.Ls_object _ -> false) - (Http_getter.ls (Http_getter_misc.strip_trailing_slash buri ^ "/")) diff --git a/helm/ocaml/grafite_engine/grafiteMisc.mli b/helm/ocaml/grafite_engine/grafiteMisc.mli deleted file mode 100644 index 833bb6360..000000000 --- a/helm/ocaml/grafite_engine/grafiteMisc.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - - (** check whether no objects are defined below a given baseuri *) -val is_empty: string -> bool diff --git a/helm/ocaml/grafite_engine/grafiteSync.ml b/helm/ocaml/grafite_engine/grafiteSync.ml deleted file mode 100644 index 37a3132e7..000000000 --- a/helm/ocaml/grafite_engine/grafiteSync.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let add_obj ~basedir uri obj status = - let lemmas = LibrarySync.add_obj uri obj basedir in - {status with GrafiteTypes.objects = uri::status.GrafiteTypes.objects}, - lemmas - -let add_coercion ~basedir ~add_composites status uri = - let compounds = LibrarySync.add_coercion ~add_composites ~basedir uri in - {status with GrafiteTypes.coercions = uri :: status.GrafiteTypes.coercions}, - compounds - -module OrderedUri = -struct - type t = UriManager.uri * string - let compare (u1, _) (u2, _) = UriManager.compare u1 u2 -end - -module UriSet = Set.Make (OrderedUri) - - (** @return l2 \ l1 *) -let uri_list_diff l2 l1 = - let module S = UriManager.UriSet in - let s1 = List.fold_left (fun set uri -> S.add uri set) S.empty l1 in - let s2 = List.fold_left (fun set uri -> S.add uri set) S.empty l2 in - let diff = S.diff s2 s1 in - S.fold (fun uri uris -> uri :: uris) diff [] - -let time_travel ~present ~past = - let objs_to_remove = - uri_list_diff present.GrafiteTypes.objects past.GrafiteTypes.objects in - let coercions_to_remove = - uri_list_diff present.GrafiteTypes.coercions past.GrafiteTypes.coercions - in - List.iter (fun uri -> LibrarySync.remove_coercion uri) coercions_to_remove; - List.iter LibrarySync.remove_obj objs_to_remove - -let init () = - LibrarySync.remove_all_coercions (); - LibraryObjects.reset_defaults (); - { - GrafiteTypes.moo_content_rev = []; - proof_status = GrafiteTypes.No_proof; - options = GrafiteTypes.no_options; - objects = []; - coercions = []; - } diff --git a/helm/ocaml/grafite_engine/grafiteSync.mli b/helm/ocaml/grafite_engine/grafiteSync.mli deleted file mode 100644 index ce3c04250..000000000 --- a/helm/ocaml/grafite_engine/grafiteSync.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val add_obj: - basedir:string -> UriManager.uri -> Cic.obj -> GrafiteTypes.status -> - GrafiteTypes.status * UriManager.uri list - -val add_coercion: - basedir:string -> add_composites:bool -> GrafiteTypes.status -> - UriManager.uri -> GrafiteTypes.status * UriManager.uri list - -val time_travel: - present:GrafiteTypes.status -> past:GrafiteTypes.status -> unit - - (* also resets the imperative part of the status *) -val init: unit -> GrafiteTypes.status diff --git a/helm/ocaml/grafite_engine/grafiteTypes.ml b/helm/ocaml/grafite_engine/grafiteTypes.ml deleted file mode 100644 index 0c02e1b6c..000000000 --- a/helm/ocaml/grafite_engine/grafiteTypes.ml +++ /dev/null @@ -1,195 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception Option_error of string * string -exception Statement_error of string -exception Command_error of string - -let command_error msg = raise (Command_error msg) - -type incomplete_proof = { - proof: ProofEngineTypes.proof; - stack: Continuationals.Stack.t; -} - -type proof_status = - | No_proof - | Incomplete_proof of incomplete_proof - | Proof of ProofEngineTypes.proof - | Intermediate of Cic.metasenv - (* Status in which the proof could be while it is being processed by the - * engine. No status entering/exiting the engine could be in it. *) - -module StringMap = Map.Make (String) -type option_value = - | String of string - | Int of int -type options = option_value StringMap.t -let no_options = StringMap.empty - -type status = { - moo_content_rev: GrafiteMarshal.moo; - proof_status: proof_status; - options: options; - objects: UriManager.uri list; - coercions: UriManager.uri list; -} - -let get_current_proof status = - match status.proof_status with - | Incomplete_proof { proof = p } -> p - | _ -> raise (Statement_error "no ongoing proof") - -let get_proof_metasenv status = - match status.proof_status with - | No_proof -> [] - | Proof (_, metasenv, _, _) - | Incomplete_proof { proof = (_, metasenv, _, _) } - | Intermediate metasenv -> - metasenv - -let get_stack status = - match status.proof_status with - | Incomplete_proof p -> p.stack - | Proof _ -> Continuationals.Stack.empty - | _ -> assert false - -let set_stack stack status = - match status.proof_status with - | Incomplete_proof p -> - { status with proof_status = Incomplete_proof { p with stack = stack } } - | Proof _ -> - assert (Continuationals.Stack.is_empty stack); - status - | _ -> assert false - -let set_metasenv metasenv status = - let proof_status = - match status.proof_status with - | No_proof -> Intermediate metasenv - | Incomplete_proof ({ proof = (uri, _, proof, ty) } as incomplete_proof) -> - Incomplete_proof - { incomplete_proof with proof = (uri, metasenv, proof, ty) } - | Intermediate _ -> Intermediate metasenv - | Proof (_, metasenv', _, _) -> - assert (metasenv = metasenv'); - status.proof_status - in - { status with proof_status = proof_status } - -let get_proof_context status goal = - match status.proof_status with - | Incomplete_proof { proof = (_, metasenv, _, _) } -> - let (_, context, _) = CicUtil.lookup_meta goal metasenv in - context - | _ -> [] - -let get_proof_conclusion status goal = - match status.proof_status with - | Incomplete_proof { proof = (_, metasenv, _, _) } -> - let (_, _, conclusion) = CicUtil.lookup_meta goal metasenv in - conclusion - | _ -> raise (Statement_error "no ongoing proof") - -let add_moo_content cmds status = - let content = status.moo_content_rev in - let content' = - List.fold_right - (fun cmd acc -> -(* prerr_endline ("adding to moo command: " ^ GrafiteAstPp.pp_command cmd); *) - match cmd with - | GrafiteAst.Default _ -> - if List.mem cmd content then acc - else cmd :: acc - | _ -> cmd :: acc) - cmds content - in -(* prerr_endline ("new moo content: " ^ String.concat " " (List.map - GrafiteAstPp.pp_command content')); *) - { status with moo_content_rev = content' } - -let get_option status name = - try - StringMap.find name status.options - with Not_found -> raise (Option_error (name, "not found")) - -let set_option status name value = - let mangle_dir s = - let s = Str.global_replace (Str.regexp "//+") "/" s in - let s = Str.global_replace (Str.regexp "/$") "" s in - s - in - let types = [ "baseuri", (`String, mangle_dir); ] in - let ty_and_mangler = - try - List.assoc name types - with Not_found -> - command_error (Printf.sprintf "Unknown option \"%s\"" name) - in - let value = - match ty_and_mangler with - | `String, f -> String (f value) - | `Int, f -> - (try - Int (int_of_string (f value)) - with Failure _ -> - command_error (Printf.sprintf "Not an integer value \"%s\"" value)) - in - if StringMap.mem name status.options && name = "baseuri" then - command_error "Redefinition of 'baseuri' is forbidden." - else - { status with options = StringMap.add name value status.options } - - -let get_string_option status name = - match get_option status name with - | String s -> s - | _ -> raise (Option_error (name, "not a string value")) - -let qualify status name = get_string_option status "baseuri" ^ "/" ^ name - -let dump_status status = - HLog.message "status.aliases:\n"; - HLog.message "status.proof_status:"; - HLog.message - (match status.proof_status with - | No_proof -> "no proof\n" - | Incomplete_proof _ -> "incomplete proof\n" - | Proof _ -> "proof\n" - | Intermediate _ -> "Intermediate\n"); - HLog.message "status.options\n"; - StringMap.iter (fun k v -> - let v = - match v with - | String s -> s - | Int i -> string_of_int i - in - HLog.message (k ^ "::=" ^ v)) status.options; - HLog.message "status.coercions\n"; - HLog.message "status.objects:\n"; - List.iter - (fun u -> HLog.message (UriManager.string_of_uri u)) status.objects diff --git a/helm/ocaml/grafite_engine/grafiteTypes.mli b/helm/ocaml/grafite_engine/grafiteTypes.mli deleted file mode 100644 index a8b86c276..000000000 --- a/helm/ocaml/grafite_engine/grafiteTypes.mli +++ /dev/null @@ -1,77 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception Option_error of string * string -exception Statement_error of string -exception Command_error of string - -val command_error: string -> 'a (** @raise Command_error *) - -type incomplete_proof = { - proof: ProofEngineTypes.proof; - stack: Continuationals.Stack.t; -} - -type proof_status = - No_proof - | Incomplete_proof of incomplete_proof - | Proof of ProofEngineTypes.proof - | Intermediate of Cic.metasenv - -type option_value = - | String of string - | Int of int -type options -val no_options: options - -type status = { - moo_content_rev: GrafiteMarshal.moo; - proof_status: proof_status; (** logical status *) - options: options; - objects: UriManager.uri list; (** in-scope objects *) - coercions: UriManager.uri list; (** defined coercions *) -} - -val dump_status : status -> unit - - (** list is not reversed, head command will be the first emitted *) -val add_moo_content: GrafiteMarshal.ast_command list -> status -> status - -val get_option : status -> string -> option_value -val get_string_option : status -> string -> string -val set_option : status -> string -> string -> status - -val qualify: status -> string -> string - -val get_current_proof: status -> ProofEngineTypes.proof -val get_proof_metasenv: status -> Cic.metasenv -val get_stack: status -> Continuationals.Stack.t -val get_proof_context : status -> int -> Cic.context -val get_proof_conclusion : status -> int -> Cic.term - -val set_stack: Continuationals.Stack.t -> status -> status -val set_metasenv: Cic.metasenv -> status -> status diff --git a/helm/ocaml/grafite_parser/.depend b/helm/ocaml/grafite_parser/.depend deleted file mode 100644 index 360429635..000000000 --- a/helm/ocaml/grafite_parser/.depend +++ /dev/null @@ -1,10 +0,0 @@ -dependenciesParser.cmo: dependenciesParser.cmi -dependenciesParser.cmx: dependenciesParser.cmi -grafiteParser.cmo: dependenciesParser.cmi grafiteParser.cmi -grafiteParser.cmx: dependenciesParser.cmx grafiteParser.cmi -cicNotation2.cmo: grafiteParser.cmi cicNotation2.cmi -cicNotation2.cmx: grafiteParser.cmx cicNotation2.cmi -grafiteDisambiguator.cmo: grafiteDisambiguator.cmi -grafiteDisambiguator.cmx: grafiteDisambiguator.cmi -grafiteDisambiguate.cmo: grafiteDisambiguator.cmi grafiteDisambiguate.cmi -grafiteDisambiguate.cmx: grafiteDisambiguator.cmx grafiteDisambiguate.cmi diff --git a/helm/ocaml/grafite_parser/Makefile b/helm/ocaml/grafite_parser/Makefile deleted file mode 100644 index 8482825a6..000000000 --- a/helm/ocaml/grafite_parser/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -PACKAGE = grafite_parser -PREDICATES = - -INTERFACE_FILES = \ - dependenciesParser.mli \ - grafiteParser.mli \ - cicNotation2.mli \ - grafiteDisambiguator.mli \ - grafiteDisambiguate.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -all: test_parser print_grammar test_dep -clean: clean_tests - -# cross compatibility among ocaml 3.09 and ocaml 3.08, to be removed as -# soon as we have ocaml 3.09 everywhere and "loc" occurrences are replaced by -# "_loc" occurrences -UTF8DIR = $(shell $(OCAMLFIND) query helm-utf8_macros) -ULEXDIR = $(shell $(OCAMLFIND) query ulex) -MY_SYNTAXOPTIONS = -pp "camlp4o -I $(UTF8DIR) -I $(ULEXDIR) pa_extend.cmo pa_ulex.cma pa_unicode_macro.cma -loc loc" -grafiteParser.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -grafiteParser.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -depend: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -# -# -grafiteParser.cmo: OCAMLC = $(OCAMLC_P4) -grafiteParser.cmx: OCAMLOPT = $(OCAMLOPT_P4) - -clean_tests: - rm -f test_parser{,.opt} test_dep{,.opt} print_grammar{,.opt} - -LOCAL_LINKOPTS = -package helm-$(PACKAGE) -linkpkg -test: test_parser print_grammar test_dep -test_parser: test_parser.ml $(PACKAGE).cma - @echo " OCAMLC $<" - @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< -print_grammar: print_grammar.ml $(PACKAGE).cma - @echo " OCAMLC $<" - @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< -test_dep: test_dep.ml $(PACKAGE).cma - @echo " OCAMLC $<" - @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/grafite_parser/cicNotation2.ml b/helm/ocaml/grafite_parser/cicNotation2.ml deleted file mode 100644 index 015d426e7..000000000 --- a/helm/ocaml/grafite_parser/cicNotation2.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let load_notation ~include_paths fname = - let ic = open_in fname in - let lexbuf = Ulexing.from_utf8_channel ic in - let status = ref LexiconSync.init in - try - while true do - status := fst (GrafiteParser.parse_statement ~include_paths lexbuf !status) - done; - assert false - with End_of_file -> close_in ic; !status - -let parse_environment ~include_paths str = - let lexbuf = Ulexing.from_utf8_string str in - let status = ref LexiconSync.init in - try - while true do - status := fst (GrafiteParser.parse_statement ~include_paths lexbuf !status) - done; - assert false - with End_of_file -> - !status.LexiconEngine.aliases, - !status.LexiconEngine.multi_aliases diff --git a/helm/ocaml/grafite_parser/cicNotation2.mli b/helm/ocaml/grafite_parser/cicNotation2.mli deleted file mode 100644 index 00f184b3b..000000000 --- a/helm/ocaml/grafite_parser/cicNotation2.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(** Note: notation is also loaded, but it cannot be undone since the - notation_ids part of the status is thrown away; - so far this function is useful only in Whelp *) -val parse_environment: - include_paths:string list -> - string -> - DisambiguateTypes.environment * DisambiguateTypes.multiple_environment - -(** @param fname file from which load notation *) -val load_notation: include_paths:string list -> string -> LexiconEngine.status diff --git a/helm/ocaml/grafite_parser/dependenciesParser.ml b/helm/ocaml/grafite_parser/dependenciesParser.ml deleted file mode 100644 index fc49de600..000000000 --- a/helm/ocaml/grafite_parser/dependenciesParser.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception UnableToInclude of string - - (* statements meaningful for matitadep *) -type dependency = - | IncludeDep of string - | BaseuriDep of string - | UriDep of UriManager.uri - -let pp_dependency = function - | IncludeDep str -> "include \"" ^ str ^ "\"" - | BaseuriDep str -> "set \"baseuri\" \"" ^ str ^ "\"" - | UriDep uri -> "uri \"" ^ UriManager.string_of_uri uri ^ "\"" - -let parse_dependencies lexbuf = - let tok_stream,_ = - CicNotationLexer.level2_ast_lexer.Token.tok_func (Obj.magic lexbuf) - in - let rec parse acc = - (parser - | [< '("URI", u) >] -> - parse (UriDep (UriManager.uri_of_string u) :: acc) - | [< '("IDENT", "include"); '("QSTRING", fname) >] -> - parse (IncludeDep fname :: acc) - | [< '("IDENT", "set"); '("QSTRING", "baseuri"); '("QSTRING", baseuri) >] -> - parse (BaseuriDep baseuri :: acc) - | [< '("EOI", _) >] -> acc - | [< 'tok >] -> parse acc - | [< >] -> acc) tok_stream - in - List.rev (parse []) - -let make_absolute paths path = - let rec aux = function - | [] -> ignore (Unix.stat path); path - | p :: tl -> - let path = p ^ "/" ^ path in - try - ignore (Unix.stat path); path - with Unix.Unix_error _ -> aux tl - in - try - aux paths - with Unix.Unix_error _ -> raise (UnableToInclude path) -;; - -let baseuri_of_script ~include_paths file = - let file = make_absolute include_paths file in - let ic = open_in file in - let istream = Ulexing.from_utf8_channel ic in - let rec find_baseuri = - function - [] -> failwith ("No baseuri defined in " ^ file) - | BaseuriDep s::_ -> s - | _::tl -> find_baseuri tl in - let buri = find_baseuri (parse_dependencies istream) in - let uri = Http_getter_misc.strip_trailing_slash buri in - if String.length uri < 5 || String.sub uri 0 5 <> "cic:/" then - HLog.error (file ^ " sets an incorrect baseuri: " ^ buri); - (try - ignore(Http_getter.resolve uri) - with - | Http_getter_types.Unresolvable_URI _ -> - HLog.error (file ^ " sets an unresolvable baseuri: " ^ buri) - | Http_getter_types.Key_not_found _ -> ()); - uri diff --git a/helm/ocaml/grafite_parser/dependenciesParser.mli b/helm/ocaml/grafite_parser/dependenciesParser.mli deleted file mode 100644 index 882d45fb8..000000000 --- a/helm/ocaml/grafite_parser/dependenciesParser.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -exception UnableToInclude of string - - (* statements meaningful for matitadep *) -type dependency = - | IncludeDep of string - | BaseuriDep of string - | UriDep of UriManager.uri - -val pp_dependency: dependency -> string - - (** @raise End_of_file *) -val parse_dependencies: Ulexing.lexbuf -> dependency list - -val baseuri_of_script : include_paths:string list -> string -> string diff --git a/helm/ocaml/grafite_parser/grafiteDisambiguate.ml b/helm/ocaml/grafite_parser/grafiteDisambiguate.ml deleted file mode 100644 index f5ea66f2f..000000000 --- a/helm/ocaml/grafite_parser/grafiteDisambiguate.ml +++ /dev/null @@ -1,289 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception BaseUriNotSetYet - -let singleton = function - | [x], _ -> x - | _ -> assert false - - (** @param term not meaningful when context is given *) -let disambiguate_term lexicon_status_ref context metasenv term = - let lexicon_status = !lexicon_status_ref in - let (diff, metasenv, cic, _) = - singleton - (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ()) - ~aliases:lexicon_status.LexiconEngine.aliases - ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) - ~context ~metasenv term) - in - let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in - lexicon_status_ref := lexicon_status; - metasenv,cic - - (** disambiguate_lazy_term (circa): term -> (unit -> status) * lazy_term - * rationale: lazy_term will be invoked in different context to obtain a term, - * each invocation will disambiguate the term and can add aliases. Once all - * disambiguations have been performed, the first returned function can be - * used to obtain the resulting aliases *) -let disambiguate_lazy_term lexicon_status_ref term = - (fun context metasenv ugraph -> - let lexicon_status = !lexicon_status_ref in - let (diff, metasenv, cic, ugraph) = - singleton - (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ()) - ~initial_ugraph:ugraph ~aliases:lexicon_status.LexiconEngine.aliases - ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) - ~context ~metasenv - term) in - let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in - lexicon_status_ref := lexicon_status; - cic, metasenv, ugraph) - -let disambiguate_pattern lexicon_status_ref (wanted, hyp_paths, goal_path) = - let interp path = Disambiguate.interpretate_path [] path in - let goal_path = HExtlib.map_option interp goal_path in - let hyp_paths = List.map (fun (name, path) -> name, interp path) hyp_paths in - let wanted = - match wanted with - None -> None - | Some wanted -> - let wanted = disambiguate_lazy_term lexicon_status_ref wanted in - Some wanted - in - (wanted, hyp_paths, goal_path) - -let disambiguate_reduction_kind lexicon_status_ref = function - | `Unfold (Some t) -> - let t = disambiguate_lazy_term lexicon_status_ref t in - `Unfold (Some t) - | `Demodulate - | `Normalize - | `Reduce - | `Simpl - | `Unfold None - | `Whd as kind -> kind - -let disambiguate_tactic lexicon_status_ref context metasenv tactic = - let disambiguate_term = disambiguate_term lexicon_status_ref in - let disambiguate_pattern = disambiguate_pattern lexicon_status_ref in - let disambiguate_reduction_kind = disambiguate_reduction_kind lexicon_status_ref in - let disambiguate_lazy_term = disambiguate_lazy_term lexicon_status_ref in - match tactic with - | GrafiteAst.Absurd (loc, term) -> - let metasenv,cic = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Absurd (loc, cic) - | GrafiteAst.Apply (loc, term) -> - let metasenv,cic = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Apply (loc, cic) - | GrafiteAst.Assumption loc -> - metasenv,GrafiteAst.Assumption loc - | GrafiteAst.Auto (loc,depth,width,paramodulation,full) -> - metasenv,GrafiteAst.Auto (loc,depth,width,paramodulation,full) - | GrafiteAst.Change (loc, pattern, with_what) -> - let with_what = disambiguate_lazy_term with_what in - let pattern = disambiguate_pattern pattern in - metasenv,GrafiteAst.Change (loc, pattern, with_what) - | GrafiteAst.Clear (loc,id) -> - metasenv,GrafiteAst.Clear (loc,id) - | GrafiteAst.ClearBody (loc,id) -> - metasenv,GrafiteAst.ClearBody (loc,id) - | GrafiteAst.Compare (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Compare (loc,term) - | GrafiteAst.Constructor (loc,n) -> - metasenv,GrafiteAst.Constructor (loc,n) - | GrafiteAst.Contradiction loc -> - metasenv,GrafiteAst.Contradiction loc - | GrafiteAst.Cut (loc, ident, term) -> - let metasenv,cic = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Cut (loc, ident, cic) - | GrafiteAst.DecideEquality loc -> - metasenv,GrafiteAst.DecideEquality loc - | GrafiteAst.Decompose (loc, types, what, names) -> - let disambiguate (metasenv,types) = function - | GrafiteAst.Type _ -> assert false - | GrafiteAst.Ident id -> - (match - disambiguate_term context metasenv - (CicNotationPt.Ident(id, None)) - with - | metasenv,Cic.MutInd (uri, tyno, _) -> - metasenv,(GrafiteAst.Type (uri, tyno) :: types) - | _ -> - raise (GrafiteDisambiguator.DisambiguationError - (0,[[None,lazy "Decompose works only on inductive types"]]))) - in - let metasenv,types = - List.fold_left disambiguate (metasenv,[]) types - in - metasenv,GrafiteAst.Decompose (loc, types, what, names) - | GrafiteAst.Discriminate (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Discriminate(loc,term) - | GrafiteAst.Exact (loc, term) -> - let metasenv,cic = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Exact (loc, cic) - | GrafiteAst.Elim (loc, what, Some using, depth, idents) -> - let metasenv,what = disambiguate_term context metasenv what in - let metasenv,using = disambiguate_term context metasenv using in - metasenv,GrafiteAst.Elim (loc, what, Some using, depth, idents) - | GrafiteAst.Elim (loc, what, None, depth, idents) -> - let metasenv,what = disambiguate_term context metasenv what in - metasenv,GrafiteAst.Elim (loc, what, None, depth, idents) - | GrafiteAst.ElimType (loc, what, Some using, depth, idents) -> - let metasenv,what = disambiguate_term context metasenv what in - let metasenv,using = disambiguate_term context metasenv using in - metasenv,GrafiteAst.ElimType (loc, what, Some using, depth, idents) - | GrafiteAst.ElimType (loc, what, None, depth, idents) -> - let metasenv,what = disambiguate_term context metasenv what in - metasenv,GrafiteAst.ElimType (loc, what, None, depth, idents) - | GrafiteAst.Exists loc -> - metasenv,GrafiteAst.Exists loc - | GrafiteAst.Fail loc -> - metasenv,GrafiteAst.Fail loc - | GrafiteAst.Fold (loc,red_kind, term, pattern) -> - let pattern = disambiguate_pattern pattern in - let term = disambiguate_lazy_term term in - let red_kind = disambiguate_reduction_kind red_kind in - metasenv,GrafiteAst.Fold (loc, red_kind, term, pattern) - | GrafiteAst.FwdSimpl (loc, hyp, names) -> - metasenv,GrafiteAst.FwdSimpl (loc, hyp, names) - | GrafiteAst.Fourier loc -> - metasenv,GrafiteAst.Fourier loc - | GrafiteAst.Generalize (loc,pattern,ident) -> - let pattern = disambiguate_pattern pattern in - metasenv,GrafiteAst.Generalize (loc,pattern,ident) - | GrafiteAst.Goal (loc, g) -> - metasenv,GrafiteAst.Goal (loc, g) - | GrafiteAst.IdTac loc -> - metasenv,GrafiteAst.IdTac loc - | GrafiteAst.Injection (loc, term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Injection (loc,term) - | GrafiteAst.Intros (loc, num, names) -> - metasenv,GrafiteAst.Intros (loc, num, names) - | GrafiteAst.Inversion (loc, term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Inversion (loc, term) - | GrafiteAst.LApply (loc, depth, to_what, what, ident) -> - let f term to_what = - let metasenv,term = disambiguate_term context metasenv term in - term :: to_what - in - let to_what = List.fold_right f to_what [] in - let metasenv,what = disambiguate_term context metasenv what in - metasenv,GrafiteAst.LApply (loc, depth, to_what, what, ident) - | GrafiteAst.Left loc -> - metasenv,GrafiteAst.Left loc - | GrafiteAst.LetIn (loc, term, name) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.LetIn (loc,term,name) - | GrafiteAst.Reduce (loc, red_kind, pattern) -> - let pattern = disambiguate_pattern pattern in - let red_kind = disambiguate_reduction_kind red_kind in - metasenv,GrafiteAst.Reduce(loc, red_kind, pattern) - | GrafiteAst.Reflexivity loc -> - metasenv,GrafiteAst.Reflexivity loc - | GrafiteAst.Replace (loc, pattern, with_what) -> - let pattern = disambiguate_pattern pattern in - let with_what = disambiguate_lazy_term with_what in - metasenv,GrafiteAst.Replace (loc, pattern, with_what) - | GrafiteAst.Rewrite (loc, dir, t, pattern) -> - let metasenv,term = disambiguate_term context metasenv t in - let pattern = disambiguate_pattern pattern in - metasenv,GrafiteAst.Rewrite (loc, dir, term, pattern) - | GrafiteAst.Right loc -> - metasenv,GrafiteAst.Right loc - | GrafiteAst.Ring loc -> - metasenv,GrafiteAst.Ring loc - | GrafiteAst.Split loc -> - metasenv,GrafiteAst.Split loc - | GrafiteAst.Symmetry loc -> - metasenv,GrafiteAst.Symmetry loc - | GrafiteAst.Transitivity (loc, term) -> - let metasenv,cic = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Transitivity (loc, cic) - -let disambiguate_obj lexicon_status ~baseuri metasenv obj = - let uri = - match obj with - | CicNotationPt.Inductive (_,(name,_,_,_)::_) - | CicNotationPt.Record (_,name,_,_) -> - (match baseuri with - | Some baseuri -> - Some (UriManager.uri_of_string (baseuri ^ "/" ^ name ^ ".ind")) - | None -> raise BaseUriNotSetYet) - | CicNotationPt.Inductive _ -> assert false - | CicNotationPt.Theorem _ -> None in - let (diff, metasenv, cic, _) = - singleton - (GrafiteDisambiguator.disambiguate_obj ~dbd:(LibraryDb.instance ()) - ~aliases:lexicon_status.LexiconEngine.aliases - ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) ~uri obj) in - let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in - lexicon_status, metasenv, cic - -let disambiguate_command lexicon_status ~baseuri metasenv = - function - | GrafiteAst.Coercion _ - | GrafiteAst.Default _ - | GrafiteAst.Drop _ - | GrafiteAst.Include _ - | GrafiteAst.Qed _ - | GrafiteAst.Set _ as cmd -> - lexicon_status,metasenv,cmd - | GrafiteAst.Obj (loc,obj) -> - let lexicon_status,metasenv,obj = - disambiguate_obj lexicon_status ~baseuri metasenv obj in - lexicon_status, metasenv, GrafiteAst.Obj (loc,obj) - -let disambiguate_macro lexicon_status_ref metasenv context macro = - let disambiguate_term = disambiguate_term lexicon_status_ref in - match macro with - | GrafiteAst.WMatch (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.WMatch (loc,term) - | GrafiteAst.WInstance (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.WInstance (loc,term) - | GrafiteAst.WElim (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.WElim (loc,term) - | GrafiteAst.WHint (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.WHint (loc,term) - | GrafiteAst.Check (loc,term) -> - let metasenv,term = disambiguate_term context metasenv term in - metasenv,GrafiteAst.Check (loc,term) - | GrafiteAst.Hint _ - | GrafiteAst.WLocate _ as macro -> - metasenv,macro - | GrafiteAst.Quit _ - | GrafiteAst.Print _ - | GrafiteAst.Search_pat _ - | GrafiteAst.Search_term _ -> assert false diff --git a/helm/ocaml/grafite_parser/grafiteDisambiguate.mli b/helm/ocaml/grafite_parser/grafiteDisambiguate.mli deleted file mode 100644 index b04aa3cde..000000000 --- a/helm/ocaml/grafite_parser/grafiteDisambiguate.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -exception BaseUriNotSetYet - -val disambiguate_tactic: - LexiconEngine.status ref -> - Cic.context -> - Cic.metasenv -> - (CicNotationPt.term, CicNotationPt.term, CicNotationPt.term GrafiteAst.reduction, string) GrafiteAst.tactic -> - Cic.metasenv * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic - -val disambiguate_command: - LexiconEngine.status -> - baseuri:string option -> - Cic.metasenv -> - CicNotationPt.obj GrafiteAst.command -> - LexiconEngine.status * Cic.metasenv * Cic.obj GrafiteAst.command - -val disambiguate_macro: - LexiconEngine.status ref -> - Cic.metasenv -> - Cic.context -> - CicNotationPt.term GrafiteAst.macro -> - Cic.metasenv * Cic.term GrafiteAst.macro diff --git a/helm/ocaml/grafite_parser/grafiteDisambiguator.ml b/helm/ocaml/grafite_parser/grafiteDisambiguator.ml deleted file mode 100644 index abe8c1de1..000000000 --- a/helm/ocaml/grafite_parser/grafiteDisambiguator.ml +++ /dev/null @@ -1,180 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -exception Ambiguous_input -(* the integer is an offset to be added to each location *) -exception DisambiguationError of - int * (Token.flocation option * string Lazy.t) list list - (** parameters are: option name, error message *) -exception Unbound_identifier of string - -type choose_uris_callback = - id:string -> UriManager.uri list -> UriManager.uri list - -type choose_interp_callback = (string * string) list list -> int list - -let mono_uris_callback ~id = - if Helm_registry.get_opt_default Helm_registry.get_bool ~default:true - "matita.auto_disambiguation" - then - function l -> l - else - raise Ambiguous_input - -let mono_interp_callback _ = raise Ambiguous_input - -let _choose_uris_callback = ref mono_uris_callback -let _choose_interp_callback = ref mono_interp_callback -let set_choose_uris_callback f = _choose_uris_callback := f -let set_choose_interp_callback f = _choose_interp_callback := f - -module Callbacks = - struct - let interactive_user_uri_choice ~selection_mode ?ok - ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = - !_choose_uris_callback ~id uris - - let interactive_interpretation_choice interp = - !_choose_interp_callback interp - - let input_or_locate_uri ~(title:string) ?id = - (* Zack: I try to avoid using this callback. I therefore assume that - * the presence of an identifier that can't be resolved via "locate" - * query is a syntax error *) - let msg = match id with Some id -> id | _ -> "_" in - raise (Unbound_identifier msg) - end - -module Disambiguator = Disambiguate.Make (Callbacks) - -(* implement module's API *) - -let disambiguate_thing ~aliases ~universe - ~(f:?fresh_instances:bool -> - aliases:DisambiguateTypes.environment -> - universe:DisambiguateTypes.multiple_environment option -> - 'a -> 'b) - ~(drop_aliases: 'b -> 'b) - ~(drop_aliases_and_clear_diff: 'b -> 'b) - (thing: 'a) -= - assert (universe <> None); - let library = false, DisambiguateTypes.Environment.empty, None in - let multi_aliases = false, DisambiguateTypes.Environment.empty, universe in - let mono_aliases = true, aliases, Some DisambiguateTypes.Environment.empty in - let passes = (* *) - [ (false, mono_aliases, false); - (false, multi_aliases, false); - (true, mono_aliases, false); - (true, multi_aliases, false); - (true, mono_aliases, true); - (true, multi_aliases, true); - (true, library, true); - ] - in - let try_pass (fresh_instances, (_, aliases, universe), insert_coercions) = - CicRefine.insert_coercions := insert_coercions; - f ~fresh_instances ~aliases ~universe thing - in - let set_aliases (instances,(use_mono_aliases,_,_),_) (_, user_asked as res) = - if use_mono_aliases && not instances then - drop_aliases res - else if user_asked then - drop_aliases res (* one shot aliases *) - else - drop_aliases_and_clear_diff res - in - let rec aux errors = - function - | [ pass ] -> - (try - set_aliases pass (try_pass pass) - with Disambiguate.NoWellTypedInterpretation (offset,newerrors) -> - raise (DisambiguationError (offset, errors @ [newerrors]))) - | hd :: tl -> - (try - set_aliases hd (try_pass hd) - with Disambiguate.NoWellTypedInterpretation (_offset,newerrors) -> - aux (errors @ [newerrors]) tl) - | [] -> assert false - in - let saved_insert_coercions = !CicRefine.insert_coercions in - try - let res = aux [] passes in - CicRefine.insert_coercions := saved_insert_coercions; - res - with exn -> - CicRefine.insert_coercions := saved_insert_coercions; - raise exn - -type disambiguator_thing = - { do_it : - 'a 'b. - aliases:DisambiguateTypes.environment -> - universe:DisambiguateTypes.multiple_environment option -> - f:(?fresh_instances:bool -> - aliases:DisambiguateTypes.environment -> - universe:DisambiguateTypes.multiple_environment option -> - 'a -> 'b * bool) -> - drop_aliases:('b * bool -> 'b * bool) -> - drop_aliases_and_clear_diff:('b * bool -> 'b * bool) -> 'a -> 'b * bool - } - -let disambiguate_thing = - let profiler = HExtlib.profile "disambiguate_thing" in - { do_it = - fun ~aliases ~universe ~f ~drop_aliases ~drop_aliases_and_clear_diff thing - -> profiler.HExtlib.profile - (disambiguate_thing ~aliases ~universe ~f ~drop_aliases - ~drop_aliases_and_clear_diff) thing - } - -let drop_aliases (choices, user_asked) = - (List.map (fun (d, a, b, c) -> d, a, b, c) choices), - user_asked - -let drop_aliases_and_clear_diff (choices, user_asked) = - (List.map (fun (_, a, b, c) -> [], a, b, c) choices), - user_asked - -let disambiguate_term ?fresh_instances ~dbd ~context ~metasenv ?initial_ugraph - ~aliases ~universe term - = - assert (fresh_instances = None); - let f = - Disambiguator.disambiguate_term ~dbd ~context ~metasenv ?initial_ugraph - in - disambiguate_thing.do_it ~aliases ~universe ~f ~drop_aliases - ~drop_aliases_and_clear_diff term - -let disambiguate_obj ?fresh_instances ~dbd ~aliases ~universe ~uri obj = - assert (fresh_instances = None); - let f = Disambiguator.disambiguate_obj ~dbd ~uri in - disambiguate_thing.do_it ~aliases ~universe ~f ~drop_aliases - ~drop_aliases_and_clear_diff obj diff --git a/helm/ocaml/grafite_parser/grafiteDisambiguator.mli b/helm/ocaml/grafite_parser/grafiteDisambiguator.mli deleted file mode 100644 index b7c85f6af..000000000 --- a/helm/ocaml/grafite_parser/grafiteDisambiguator.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** raised when ambiguous input is found but not expected (e.g. in the batch - * compiler) *) -exception Ambiguous_input -(* the integer is an offset to be added to each location *) -exception DisambiguationError of - int * (Token.flocation option * string Lazy.t) list list - -type choose_uris_callback = id:string -> UriManager.uri list -> UriManager.uri list -type choose_interp_callback = (string * string) list list -> int list - -val set_choose_uris_callback: choose_uris_callback -> unit -val set_choose_interp_callback: choose_interp_callback -> unit - -(** @raise Ambiguous_input if called, default value for internal - * choose_uris_callback if not set otherwise with set_choose_uris_callback - * above *) -val mono_uris_callback: choose_uris_callback - -(** @raise Ambiguous_input if called, default value for internal - * choose_interp_callback if not set otherwise with set_choose_interp_callback - * above *) -val mono_interp_callback: choose_interp_callback - -(** for GUI callbacks see MatitaGui.interactive_{interp,user_uri}_choice *) - -include Disambiguate.Disambiguator diff --git a/helm/ocaml/grafite_parser/grafiteParser.ml b/helm/ocaml/grafite_parser/grafiteParser.ml deleted file mode 100644 index e480efd34..000000000 --- a/helm/ocaml/grafite_parser/grafiteParser.ml +++ /dev/null @@ -1,566 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -module Ast = CicNotationPt - -type 'a localized_option = - LSome of 'a - | LNone of Token.flocation - -type statement = - include_paths:string list -> - LexiconEngine.status -> - LexiconEngine.status * - (CicNotationPt.term, CicNotationPt.term, - CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) - GrafiteAst.statement localized_option - -let grammar = CicNotationParser.level2_ast_grammar - -let term = CicNotationParser.term -let statement = Grammar.Entry.create grammar "statement" - -let add_raw_attribute ~text t = Ast.AttributedTerm (`Raw text, t) - -let default_precedence = 50 -let default_associativity = Gramext.NonA - -EXTEND - GLOBAL: term statement; - arg: [ - [ LPAREN; names = LIST1 IDENT SEP SYMBOL ","; - SYMBOL ":"; ty = term; RPAREN -> names,ty - | name = IDENT -> [name],Ast.Implicit - ] - ]; - constructor: [ [ name = IDENT; SYMBOL ":"; typ = term -> (name, typ) ] ]; - tactic_term: [ [ t = term LEVEL "90N" -> t ] ]; - ident_list0: [ [ LPAREN; idents = LIST0 IDENT; RPAREN -> idents ] ]; - tactic_term_list1: [ - [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ] - ]; - reduction_kind: [ - [ IDENT "demodulate" -> `Demodulate - | IDENT "normalize" -> `Normalize - | IDENT "reduce" -> `Reduce - | IDENT "simplify" -> `Simpl - | IDENT "unfold"; t = OPT term -> `Unfold t - | IDENT "whd" -> `Whd ] - ]; - sequent_pattern_spec: [ - [ hyp_paths = - LIST0 - [ id = IDENT ; - path = OPT [SYMBOL ":" ; path = tactic_term -> path ] -> - (id,match path with Some p -> p | None -> Ast.UserInput) ]; - goal_path = OPT [ SYMBOL <:unicode>; term = tactic_term -> term ] -> - let goal_path = - match goal_path, hyp_paths with - None, [] -> Some Ast.UserInput - | None, _::_ -> None - | Some goal_path, _ -> Some goal_path - in - hyp_paths,goal_path - ] - ]; - pattern_spec: [ - [ res = OPT [ - "in"; - wanted_and_sps = - [ "match" ; wanted = tactic_term ; - sps = OPT [ "in"; sps = sequent_pattern_spec -> sps ] -> - Some wanted,sps - | sps = sequent_pattern_spec -> - None,Some sps - ] -> - let wanted,hyp_paths,goal_path = - match wanted_and_sps with - wanted,None -> wanted, [], Some Ast.UserInput - | wanted,Some (hyp_paths,goal_path) -> wanted,hyp_paths,goal_path - in - wanted, hyp_paths, goal_path ] -> - match res with - None -> None,[],Some Ast.UserInput - | Some ps -> ps] - ]; - direction: [ - [ SYMBOL ">" -> `LeftToRight - | SYMBOL "<" -> `RightToLeft ] - ]; - int: [ [ num = NUMBER -> int_of_string num ] ]; - intros_spec: [ - [ num = OPT [ num = int -> num ]; idents = OPT ident_list0 -> - let idents = match idents with None -> [] | Some idents -> idents in - num, idents - ] - ]; - using: [ [ using = OPT [ IDENT "using"; t = tactic_term -> t ] -> using ] ]; - tactic: [ - [ IDENT "absurd"; t = tactic_term -> - GrafiteAst.Absurd (loc, t) - | IDENT "apply"; t = tactic_term -> - GrafiteAst.Apply (loc, t) - | IDENT "assumption" -> - GrafiteAst.Assumption loc - | IDENT "auto"; - depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ]; - width = OPT [ IDENT "width"; SYMBOL "="; i = int -> i ]; - paramodulation = OPT [ IDENT "paramodulation" ]; - full = OPT [ IDENT "full" ] -> (* ALB *) - GrafiteAst.Auto (loc,depth,width,paramodulation,full) - | IDENT "clear"; id = IDENT -> - GrafiteAst.Clear (loc,id) - | IDENT "clearbody"; id = IDENT -> - GrafiteAst.ClearBody (loc,id) - | IDENT "change"; what = pattern_spec; "with"; t = tactic_term -> - GrafiteAst.Change (loc, what, t) - | IDENT "compare"; t = tactic_term -> - GrafiteAst.Compare (loc,t) - | IDENT "constructor"; n = int -> - GrafiteAst.Constructor (loc, n) - | IDENT "contradiction" -> - GrafiteAst.Contradiction loc - | IDENT "cut"; t = tactic_term; ident = OPT [ "as"; id = IDENT -> id] -> - GrafiteAst.Cut (loc, ident, t) - | IDENT "decide"; IDENT "equality" -> - GrafiteAst.DecideEquality loc - | IDENT "decompose"; types = OPT ident_list0; what = IDENT; - (num, idents) = intros_spec -> - let types = match types with None -> [] | Some types -> types in - let to_spec id = GrafiteAst.Ident id in - GrafiteAst.Decompose (loc, List.rev_map to_spec types, what, idents) - | IDENT "discriminate"; t = tactic_term -> - GrafiteAst.Discriminate (loc, t) - | IDENT "elim"; what = tactic_term; using = using; - (num, idents) = intros_spec -> - GrafiteAst.Elim (loc, what, using, num, idents) - | IDENT "elimType"; what = tactic_term; using = using; - (num, idents) = intros_spec -> - GrafiteAst.ElimType (loc, what, using, num, idents) - | IDENT "exact"; t = tactic_term -> - GrafiteAst.Exact (loc, t) - | IDENT "exists" -> - GrafiteAst.Exists loc - | IDENT "fail" -> GrafiteAst.Fail loc - | IDENT "fold"; kind = reduction_kind; t = tactic_term; p = pattern_spec -> - let (pt,_,_) = p in - if pt <> None then - raise (HExtlib.Localized (loc, CicNotationParser.Parse_error - ("the pattern cannot specify the term to replace, only its" - ^ " paths in the hypotheses and in the conclusion"))) - else - GrafiteAst.Fold (loc, kind, t, p) - | IDENT "fourier" -> - GrafiteAst.Fourier loc - | IDENT "fwd"; hyp = IDENT; idents = OPT ident_list0 -> - let idents = match idents with None -> [] | Some idents -> idents in - GrafiteAst.FwdSimpl (loc, hyp, idents) - | IDENT "generalize"; p=pattern_spec; id = OPT ["as" ; id = IDENT -> id] -> - GrafiteAst.Generalize (loc,p,id) - | IDENT "goal"; n = int -> - GrafiteAst.Goal (loc, n) - | IDENT "id" -> GrafiteAst.IdTac loc - | IDENT "injection"; t = tactic_term -> - GrafiteAst.Injection (loc, t) - | IDENT "intro"; ident = OPT IDENT -> - let idents = match ident with None -> [] | Some id -> [id] in - GrafiteAst.Intros (loc, Some 1, idents) - | IDENT "intros"; (num, idents) = intros_spec -> - GrafiteAst.Intros (loc, num, idents) - | IDENT "inversion"; t = tactic_term -> - GrafiteAst.Inversion (loc, t) - | IDENT "lapply"; - depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ]; - what = tactic_term; - to_what = OPT [ "to" ; t = tactic_term_list1 -> t ]; - ident = OPT [ IDENT "using" ; ident = IDENT -> ident ] -> - let to_what = match to_what with None -> [] | Some to_what -> to_what in - GrafiteAst.LApply (loc, depth, to_what, what, ident) - | IDENT "left" -> GrafiteAst.Left loc - | IDENT "letin"; where = IDENT ; SYMBOL <:unicode> ; t = tactic_term -> - GrafiteAst.LetIn (loc, t, where) - | kind = reduction_kind; p = pattern_spec -> - GrafiteAst.Reduce (loc, kind, p) - | IDENT "reflexivity" -> - GrafiteAst.Reflexivity loc - | IDENT "replace"; p = pattern_spec; "with"; t = tactic_term -> - GrafiteAst.Replace (loc, p, t) - | IDENT "rewrite" ; d = direction; t = tactic_term ; p = pattern_spec -> - let (pt,_,_) = p in - if pt <> None then - raise - (HExtlib.Localized (loc, - (CicNotationParser.Parse_error - "the pattern cannot specify the term to rewrite, only its paths in the hypotheses and in the conclusion"))) - else - GrafiteAst.Rewrite (loc, d, t, p) - | IDENT "right" -> - GrafiteAst.Right loc - | IDENT "ring" -> - GrafiteAst.Ring loc - | IDENT "split" -> - GrafiteAst.Split loc - | IDENT "symmetry" -> - GrafiteAst.Symmetry loc - | IDENT "transitivity"; t = tactic_term -> - GrafiteAst.Transitivity (loc, t) - ] - ]; - atomic_tactical: - [ "sequence" LEFTA - [ t1 = SELF; SYMBOL ";"; t2 = SELF -> - let ts = - match t1 with - | GrafiteAst.Seq (_, l) -> l @ [ t2 ] - | _ -> [ t1; t2 ] - in - GrafiteAst.Seq (loc, ts) - ] - | "then" NONA - [ tac = SELF; SYMBOL ";"; - SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"-> - (GrafiteAst.Then (loc, tac, tacs)) - ] - | "loops" RIGHTA - [ IDENT "do"; count = int; tac = SELF; IDENT "end" -> - GrafiteAst.Do (loc, count, tac) - | IDENT "repeat"; tac = SELF; IDENT "end" -> GrafiteAst.Repeat (loc, tac) - ] - | "simple" NONA - [ IDENT "first"; - SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"-> - GrafiteAst.First (loc, tacs) - | IDENT "try"; tac = SELF -> GrafiteAst.Try (loc, tac) - | IDENT "solve"; - SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"-> - GrafiteAst.Solve (loc, tacs) - | LPAREN; tac = SELF; RPAREN -> tac - | tac = tactic -> GrafiteAst.Tactic (loc, tac) - ] - ]; - punctuation_tactical: - [ - [ SYMBOL "[" -> GrafiteAst.Branch loc - | SYMBOL "|" -> GrafiteAst.Shift loc - | i = int; SYMBOL ":" -> GrafiteAst.Pos (loc, i) - | SYMBOL "]" -> GrafiteAst.Merge loc - | SYMBOL ";" -> GrafiteAst.Semicolon loc - | SYMBOL "." -> GrafiteAst.Dot loc - ] - ]; - tactical: - [ "simple" NONA - [ IDENT "focus"; goals = LIST1 int -> GrafiteAst.Focus (loc, goals) - | IDENT "unfocus" -> GrafiteAst.Unfocus loc - | IDENT "skip" -> GrafiteAst.Skip loc - | tac = atomic_tactical LEVEL "loops" -> tac - ] - ]; - theorem_flavour: [ - [ [ IDENT "definition" ] -> `Definition - | [ IDENT "fact" ] -> `Fact - | [ IDENT "lemma" ] -> `Lemma - | [ IDENT "remark" ] -> `Remark - | [ IDENT "theorem" ] -> `Theorem - ] - ]; - inductive_spec: [ [ - fst_name = IDENT; params = LIST0 [ arg=arg -> arg ]; - SYMBOL ":"; fst_typ = term; SYMBOL <:unicode>; OPT SYMBOL "|"; - fst_constructors = LIST0 constructor SEP SYMBOL "|"; - tl = OPT [ "with"; - types = LIST1 [ - name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode>; - OPT SYMBOL "|"; constructors = LIST0 constructor SEP SYMBOL "|" -> - (name, true, typ, constructors) ] SEP "with" -> types - ] -> - let params = - List.fold_right - (fun (names, typ) acc -> - (List.map (fun name -> (name, typ)) names) @ acc) - params [] - in - let fst_ind_type = (fst_name, true, fst_typ, fst_constructors) in - let tl_ind_types = match tl with None -> [] | Some types -> types in - let ind_types = fst_ind_type :: tl_ind_types in - (params, ind_types) - ] ]; - - record_spec: [ [ - name = IDENT; params = LIST0 [ arg = arg -> arg ] ; - SYMBOL ":"; typ = term; SYMBOL <:unicode>; SYMBOL "{" ; - fields = LIST0 [ - name = IDENT ; - coercion = [ SYMBOL ":" -> false | SYMBOL ":"; SYMBOL ">" -> true ] ; - ty = term -> (name,ty,coercion) - ] SEP SYMBOL ";"; SYMBOL "}" -> - let params = - List.fold_right - (fun (names, typ) acc -> - (List.map (fun name -> (name, typ)) names) @ acc) - params [] - in - (params,name,typ,fields) - ] ]; - - macro: [ - [ [ IDENT "quit" ] -> GrafiteAst.Quit loc -(* | [ IDENT "abort" ] -> GrafiteAst.Abort loc *) -(* | [ IDENT "undo" ]; steps = OPT NUMBER -> - GrafiteAst.Undo (loc, int_opt steps) - | [ IDENT "redo" ]; steps = OPT NUMBER -> - GrafiteAst.Redo (loc, int_opt steps) *) - | [ IDENT "check" ]; t = term -> - GrafiteAst.Check (loc, t) - | [ IDENT "hint" ] -> GrafiteAst.Hint loc - | [ IDENT "whelp"; "match" ] ; t = term -> - GrafiteAst.WMatch (loc,t) - | [ IDENT "whelp"; IDENT "instance" ] ; t = term -> - GrafiteAst.WInstance (loc,t) - | [ IDENT "whelp"; IDENT "locate" ] ; id = IDENT -> - GrafiteAst.WLocate (loc,id) - | [ IDENT "whelp"; IDENT "elim" ] ; t = term -> - GrafiteAst.WElim (loc, t) - | [ IDENT "whelp"; IDENT "hint" ] ; t = term -> - GrafiteAst.WHint (loc,t) - | [ IDENT "print" ]; name = QSTRING -> GrafiteAst.Print (loc, name) - ] - ]; - alias_spec: [ - [ IDENT "id"; id = QSTRING; SYMBOL "="; uri = QSTRING -> - let alpha = "[a-zA-Z]" in - let num = "[0-9]+" in - let ident_cont = "\\("^alpha^"\\|"^num^"\\|_\\|\\\\\\)" in - let ident = "\\("^alpha^ident_cont^"*\\|_"^ident_cont^"+\\)" in - let rex = Str.regexp ("^"^ident^"$") in - if Str.string_match rex id 0 then - if (try ignore (UriManager.uri_of_string uri); true - with UriManager.IllFormedUri _ -> false) - then - LexiconAst.Ident_alias (id, uri) - else - raise - (HExtlib.Localized (loc, CicNotationParser.Parse_error (sprintf "Not a valid uri: %s" uri))) - else - raise (HExtlib.Localized (loc, CicNotationParser.Parse_error ( - sprintf "Not a valid identifier: %s" id))) - | IDENT "symbol"; symbol = QSTRING; - instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ]; - SYMBOL "="; dsc = QSTRING -> - let instance = - match instance with Some i -> i | None -> 0 - in - LexiconAst.Symbol_alias (symbol, instance, dsc) - | IDENT "num"; - instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ]; - SYMBOL "="; dsc = QSTRING -> - let instance = - match instance with Some i -> i | None -> 0 - in - LexiconAst.Number_alias (instance, dsc) - ] - ]; - argument: [ - [ l = LIST0 [ SYMBOL <:unicode> (* η *); SYMBOL "." -> () ]; - id = IDENT -> - Ast.IdentArg (List.length l, id) - ] - ]; - associativity: [ - [ IDENT "left"; IDENT "associative" -> Gramext.LeftA - | IDENT "right"; IDENT "associative" -> Gramext.RightA - | IDENT "non"; IDENT "associative" -> Gramext.NonA - ] - ]; - precedence: [ - [ "with"; IDENT "precedence"; n = NUMBER -> int_of_string n ] - ]; - notation: [ - [ dir = OPT direction; s = QSTRING; - assoc = OPT associativity; prec = OPT precedence; - IDENT "for"; - p2 = - [ blob = UNPARSED_AST -> - add_raw_attribute ~text:(sprintf "@{%s}" blob) - (CicNotationParser.parse_level2_ast - (Ulexing.from_utf8_string blob)) - | blob = UNPARSED_META -> - add_raw_attribute ~text:(sprintf "${%s}" blob) - (CicNotationParser.parse_level2_meta - (Ulexing.from_utf8_string blob)) - ] -> - let assoc = - match assoc with - | None -> default_associativity - | Some assoc -> assoc - in - let prec = - match prec with - | None -> default_precedence - | Some prec -> prec - in - let p1 = - add_raw_attribute ~text:s - (CicNotationParser.parse_level1_pattern - (Ulexing.from_utf8_string s)) - in - (dir, p1, assoc, prec, p2) - ] - ]; - level3_term: [ - [ u = URI -> Ast.UriPattern (UriManager.uri_of_string u) - | id = IDENT -> Ast.VarPattern id - | SYMBOL "_" -> Ast.ImplicitPattern - | LPAREN; terms = LIST1 SELF; RPAREN -> - (match terms with - | [] -> assert false - | [term] -> term - | terms -> Ast.ApplPattern terms) - ] - ]; - interpretation: [ - [ s = CSYMBOL; args = LIST0 argument; SYMBOL "="; t = level3_term -> - (s, args, t) - ] - ]; - - include_command: [ [ - IDENT "include" ; path = QSTRING -> loc,path - ]]; - - grafite_command: [ [ - IDENT "set"; n = QSTRING; v = QSTRING -> - GrafiteAst.Set (loc, n, v) - | IDENT "drop" -> GrafiteAst.Drop loc - | IDENT "qed" -> GrafiteAst.Qed loc - | IDENT "variant" ; name = IDENT; SYMBOL ":"; - typ = term; SYMBOL <:unicode> ; newname = IDENT -> - GrafiteAst.Obj (loc, - Ast.Theorem - (`Variant,name,typ,Some (Ast.Ident (newname, None)))) - | flavour = theorem_flavour; name = IDENT; SYMBOL ":"; typ = term; - body = OPT [ SYMBOL <:unicode> (* ≝ *); body = term -> body ] -> - GrafiteAst.Obj (loc, Ast.Theorem (flavour, name, typ, body)) - | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode> (* ≝ *); - body = term -> - GrafiteAst.Obj (loc, - Ast.Theorem (flavour, name, Ast.Implicit, Some body)) - | "let"; ind_kind = [ "corec" -> `CoInductive | "rec"-> `Inductive ]; - defs = CicNotationParser.let_defs -> - let name,ty = - match defs with - | ((Ast.Ident (name, None), Some ty),_,_) :: _ -> name,ty - | ((Ast.Ident (name, None), None),_,_) :: _ -> - name, Ast.Implicit - | _ -> assert false - in - let body = Ast.Ident (name,None) in - GrafiteAst.Obj (loc, Ast.Theorem(`Definition, name, ty, - Some (Ast.LetRec (ind_kind, defs, body)))) - | IDENT "inductive"; spec = inductive_spec -> - let (params, ind_types) = spec in - GrafiteAst.Obj (loc, Ast.Inductive (params, ind_types)) - | IDENT "coinductive"; spec = inductive_spec -> - let (params, ind_types) = spec in - let ind_types = (* set inductive flags to false (coinductive) *) - List.map (fun (name, _, term, ctors) -> (name, false, term, ctors)) - ind_types - in - GrafiteAst.Obj (loc, Ast.Inductive (params, ind_types)) - | IDENT "coercion" ; suri = URI -> - GrafiteAst.Coercion (loc, UriManager.uri_of_string suri, true) - | IDENT "record" ; (params,name,ty,fields) = record_spec -> - GrafiteAst.Obj (loc, Ast.Record (params,name,ty,fields)) - | IDENT "default" ; what = QSTRING ; uris = LIST1 URI -> - let uris = List.map UriManager.uri_of_string uris in - GrafiteAst.Default (loc,what,uris) - ]]; - lexicon_command: [ [ - IDENT "alias" ; spec = alias_spec -> - LexiconAst.Alias (loc, spec) - | IDENT "notation"; (dir, l1, assoc, prec, l2) = notation -> - LexiconAst.Notation (loc, dir, l1, assoc, prec, l2) - | IDENT "interpretation"; id = QSTRING; - (symbol, args, l3) = interpretation -> - LexiconAst.Interpretation (loc, id, (symbol, args), l3) - ]]; - executable: [ - [ cmd = grafite_command; SYMBOL "." -> GrafiteAst.Command (loc, cmd) - | tac = tactical; punct = punctuation_tactical -> - GrafiteAst.Tactical (loc, tac, Some punct) - | punct = punctuation_tactical -> GrafiteAst.Tactical (loc, punct, None) - | mac = macro; SYMBOL "." -> GrafiteAst.Macro (loc, mac) - ] - ]; - comment: [ - [ BEGINCOMMENT ; ex = executable ; ENDCOMMENT -> - GrafiteAst.Code (loc, ex) - | str = NOTE -> - GrafiteAst.Note (loc, str) - ] - ]; - statement: [ - [ ex = executable -> - fun ~include_paths status -> status,LSome(GrafiteAst.Executable (loc,ex)) - | com = comment -> - fun ~include_paths status -> status,LSome (GrafiteAst.Comment (loc, com)) - | (iloc,fname) = include_command ; SYMBOL "." -> - fun ~include_paths status -> - let path = DependenciesParser.baseuri_of_script ~include_paths fname in - let status = - LexiconEngine.eval_command status (LexiconAst.Include (iloc,path)) - in - status, - LSome - (GrafiteAst.Executable - (loc,GrafiteAst.Command - (loc,GrafiteAst.Include (iloc,path)))) - | scom = lexicon_command ; SYMBOL "." -> - fun ~include_paths status -> - let status = LexiconEngine.eval_command status scom in - status,LNone loc - | EOI -> raise End_of_file - ] - ]; -END - -let exc_located_wrapper f = - try - f () - with - | Stdpp.Exc_located (_, End_of_file) -> raise End_of_file - | Stdpp.Exc_located (floc, Stream.Error msg) -> - raise (HExtlib.Localized (floc,CicNotationParser.Parse_error msg)) - | Stdpp.Exc_located (floc, exn) -> - raise - (HExtlib.Localized (floc,CicNotationParser.Parse_error (Printexc.to_string exn))) - -let parse_statement lexbuf = - exc_located_wrapper - (fun () -> (Grammar.Entry.parse statement (Obj.magic lexbuf))) diff --git a/helm/ocaml/grafite_parser/grafiteParser.mli b/helm/ocaml/grafite_parser/grafiteParser.mli deleted file mode 100644 index 6a1980011..000000000 --- a/helm/ocaml/grafite_parser/grafiteParser.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -type 'a localized_option = - LSome of 'a - | LNone of Token.flocation - -type statement = - include_paths:string list -> - LexiconEngine.status -> - LexiconEngine.status * - (CicNotationPt.term, CicNotationPt.term, - CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) - GrafiteAst.statement localized_option - -val parse_statement: Ulexing.lexbuf -> statement (** @raise End_of_file *) - -val statement: statement Grammar.Entry.e - diff --git a/helm/ocaml/grafite_parser/print_grammar.ml b/helm/ocaml/grafite_parser/print_grammar.ml deleted file mode 100644 index 6a05865de..000000000 --- a/helm/ocaml/grafite_parser/print_grammar.ml +++ /dev/null @@ -1,287 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Gramext - -let tex_of_unicode s = - let contractions = ("\\Longrightarrow","=>") :: [] in - if String.length s <= 1 then s - else (* probably an extended unicode symbol *) - let s = Utf8Macro.tex_of_unicode s in - try List.assoc s contractions with Not_found -> s - -let needs_brackets t = - let rec count_brothers = function - | Node {brother = brother} -> 1 + count_brothers brother - | _ -> 0 - in - count_brothers t > 1 - -let visit_description desc fmt self = - let skip s = List.mem s [ ] in - let inline s = List.mem s [ "int" ] in - - let rec visit_entry e todo is_son nesting = - let { ename = ename; edesc = desc } = e in - if inline ename then - visit_desc desc todo is_son nesting - else - begin - Format.fprintf fmt "%s " ename; - if skip ename then - todo - else - todo @ [e] - end - - and visit_desc d todo is_son nesting = - match d with - | Dlevels [] -> todo - | Dlevels [lev] -> visit_level lev todo is_son nesting - | Dlevels (lev::levels) -> - let todo = visit_level lev todo is_son nesting in - List.fold_left - (fun acc l -> - Format.fprintf fmt "@ | "; - visit_level l acc is_son nesting) - todo levels; - | _ -> todo - - and visit_level l todo is_son nesting = - let { lsuffix = suff ; lprefix = pref } = l in - let todo = visit_tree suff todo is_son nesting in - visit_tree pref todo is_son nesting - - and visit_tree t todo is_son nesting = - match t with - | Node node -> visit_node node todo is_son nesting - | _ -> todo - - and visit_node n todo is_son nesting = - let is_tree_printable t = - match t with - | Node _ -> true - | _ -> false - in - let { node = symbol; son = son ; brother = brother } = n in - let todo = visit_symbol symbol todo is_son nesting in - let todo = - if is_tree_printable son then - begin - let need_b = needs_brackets son in - if not is_son then - Format.fprintf fmt "@["; - if need_b then - Format.fprintf fmt "( "; - let todo = visit_tree son todo true nesting in - if need_b then - Format.fprintf fmt ")"; - if not is_son then - Format.fprintf fmt "@]"; - todo - end - else - todo - in - if is_tree_printable brother then - begin - Format.fprintf fmt "@ | "; - visit_tree brother todo is_son nesting - end - else - todo - - and visit_symbol s todo is_son nesting = - match s with - | Smeta (name, sl, _) -> - Format.fprintf fmt "%s " name; - List.fold_left ( - fun acc s -> - let todo = visit_symbol s acc is_son nesting in - if is_son then - Format.fprintf fmt "@ "; - todo) - todo sl - | Snterm entry -> visit_entry entry todo is_son nesting - | Snterml (entry,_) -> visit_entry entry todo is_son nesting - | Slist0 symbol -> - Format.fprintf fmt "{@[ "; - let todo = visit_symbol symbol todo is_son (nesting+1) in - Format.fprintf fmt "@]} @ "; - todo - | Slist0sep (symbol,sep) -> - Format.fprintf fmt "[@[ "; - let todo = visit_symbol symbol todo is_son (nesting + 1) in - Format.fprintf fmt "{@[ "; - let todo = visit_symbol sep todo is_son (nesting + 2) in - Format.fprintf fmt " "; - let todo = visit_symbol symbol todo is_son (nesting + 2) in - Format.fprintf fmt "@]} @]] @ "; - todo - | Slist1 symbol -> - Format.fprintf fmt "{@[ "; - let todo = visit_symbol symbol todo is_son (nesting + 1) in - Format.fprintf fmt "@]}+ @ "; - todo - | Slist1sep (symbol,sep) -> - let todo = visit_symbol symbol todo is_son nesting in - Format.fprintf fmt "{@[ "; - let todo = visit_symbol sep todo is_son (nesting + 1) in - let todo = visit_symbol symbol todo is_son (nesting + 1) in - Format.fprintf fmt "@]} @ "; - todo - | Sopt symbol -> - Format.fprintf fmt "[@[ "; - let todo = visit_symbol symbol todo is_son (nesting + 1) in - Format.fprintf fmt "@]] @ "; - todo - | Sself -> Format.fprintf fmt "%s " self; todo - | Snext -> Format.fprintf fmt "next "; todo - | Stoken pattern -> - let constructor, keyword = pattern in - if keyword = "" then - Format.fprintf fmt "`%s' " constructor - else - Format.fprintf fmt "\"%s\" " (tex_of_unicode keyword); - todo - | Stree tree -> - if needs_brackets tree then - begin - Format.fprintf fmt "@[( "; - let todo = visit_tree tree todo is_son (nesting + 1) in - Format.fprintf fmt ")@] @ "; - todo - end - else - visit_tree tree todo is_son (nesting + 1) - in - visit_desc desc [] false 0 -;; - -let rec clean_dummy_desc = function - | Dlevels l -> Dlevels (clean_levels l) - | x -> x - -and clean_levels = function - | [] -> [] - | l :: tl -> clean_level l @ clean_levels tl - -and clean_level = function - | x -> - let pref = clean_tree x.lprefix in - let suff = clean_tree x.lsuffix in - match pref,suff with - | DeadEnd, DeadEnd -> [] - | _ -> [{x with lprefix = pref; lsuffix = suff}] - -and clean_tree = function - | Node n -> clean_node n - | x -> x - -and clean_node = function - | {node=node;son=son;brother=brother} -> - let bn = is_symbol_dummy node in - let bs = is_tree_dummy son in - let bb = is_tree_dummy brother in - let son = if bs then DeadEnd else son in - let brother = if bb then DeadEnd else brother in - if bb && bs && bn then - DeadEnd - else - if bn then - Node {node=Sself;son=son;brother=brother} - else - Node {node=node;son=son;brother=brother} - -and is_level_dummy = function - | {lsuffix=lsuffix;lprefix=lprefix} -> - is_tree_dummy lsuffix && is_tree_dummy lprefix - -and is_desc_dummy = function - | Dlevels l -> List.for_all is_level_dummy l - | Dparser _ -> true - -and is_entry_dummy = function - | {edesc=edesc} -> is_desc_dummy edesc - -and is_symbol_dummy = function - | Stoken ("DUMMY", _) -> true - | Stoken _ -> false - | Smeta (_, lt, _) -> List.for_all is_symbol_dummy lt - | Snterm e | Snterml (e, _) -> is_entry_dummy e - | Slist1 x | Slist0 x -> is_symbol_dummy x - | Slist1sep (x,y) | Slist0sep (x,y) -> is_symbol_dummy x && is_symbol_dummy y - | Sopt x -> is_symbol_dummy x - | Sself | Snext -> false - | Stree t -> is_tree_dummy t - -and is_tree_dummy = function - | Node {node=node} -> is_symbol_dummy node - | _ -> true -;; - - -let rec visit_entries todo pped = - let fmt = Format.std_formatter in - match todo with - | [] -> () - | hd :: tl -> - let todo = - if not (List.memq hd pped) then - begin - let { ename = ename; edesc = desc } = hd in - Format.fprintf fmt "@[%s ::=@ " ename; - let desc = clean_dummy_desc desc in - let todo = visit_description desc fmt ename @ todo in - Format.fprintf fmt "@]"; - Format.pp_print_newline fmt (); - Format.pp_print_newline fmt (); - todo - end - else - todo - in - let clean_todo todo = - let name_of_entry e = e.ename in - let pped = hd :: pped in - let todo = tl @ todo in - let todo = List.filter (fun e -> not(List.memq e pped)) todo in - HExtlib.list_uniq - ~eq:(fun e1 e2 -> (name_of_entry e1) = (name_of_entry e2)) - (List.sort - (fun e1 e2 -> - Pervasives.compare (name_of_entry e1) (name_of_entry e2)) - todo), - pped - in - let todo,pped = clean_todo todo in - visit_entries todo pped -;; - -let _ = - let g_entry = Grammar.Entry.obj GrafiteParser.statement in - visit_entries [g_entry] [] diff --git a/helm/ocaml/grafite_parser/test_dep.ml b/helm/ocaml/grafite_parser/test_dep.ml deleted file mode 100644 index 2d0f7813f..000000000 --- a/helm/ocaml/grafite_parser/test_dep.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let _ = - let ic = ref stdin in - let usage = "test_coarse_parser [ file ]" in - let open_file fname = - if !ic <> stdin then close_in !ic; - ic := open_in fname - in - Arg.parse [] open_file usage; - let deps = - DependenciesParser.parse_dependencies (Ulexing.from_utf8_channel !ic) - in - List.iter (fun dep -> print_endline (DependenciesParser.pp_dependency dep)) deps - diff --git a/helm/ocaml/grafite_parser/test_parser.ml b/helm/ocaml/grafite_parser/test_parser.ml deleted file mode 100644 index 2deef1bd5..000000000 --- a/helm/ocaml/grafite_parser/test_parser.ml +++ /dev/null @@ -1,133 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let _ = Helm_registry.load_from "test_parser.conf.xml" - -let xml_stream_of_markup = - let rec print_box (t: CicNotationPres.boxml_markup) = - Box.box2xml print_mpres t - and print_mpres (t: CicNotationPres.mathml_markup) = - Mpresentation.print_mpres print_box t - in - print_mpres - -let dump_xml t id_to_uri fname = - prerr_endline (sprintf "dumping MathML to %s ..." fname); - flush stdout; - let oc = open_out fname in - let markup = CicNotationPres.render id_to_uri t in - let xml_stream = CicNotationPres.print_xml markup in - Xml.pp_to_outchan xml_stream oc; - close_out oc - -let extract_loc = - function - | GrafiteAst.Executable (loc, _) - | GrafiteAst.Comment (loc, _) -> loc - -let pp_associativity = function - | Gramext.LeftA -> "left" - | Gramext.RightA -> "right" - | Gramext.NonA -> "non" - -let pp_precedence = string_of_int - -(* let last_rule_id = ref None *) - -let process_stream istream = - let char_count = ref 0 in - let module P = CicNotationPt in - let module G = GrafiteAst in - let status = - ref - (CicNotation2.load_notation - ~include_paths:[] (Helm_registry.get "notation.core_file")) - in - try - while true do - try - match - GrafiteParser.parse_statement ~include_paths:[] istream !status - with - newstatus, GrafiteParser.LNone _ -> status := newstatus - | newstatus, GrafiteParser.LSome statement -> - status := newstatus; - let floc = extract_loc statement in - let (_, y) = HExtlib.loc_of_floc floc in - char_count := y + !char_count; - match statement with - (* | G.Executable (_, G.Macro (_, G.Check (_, - P.AttributedTerm (_, P.Ident _)))) -> - prerr_endline "mega hack"; - (match !last_rule_id with - | None -> () - | Some id -> - prerr_endline "removing last notation rule ..."; - CicNotationParser.delete id) *) - | G.Executable (_, G.Macro (_, G.Check (_, t))) -> - prerr_endline (sprintf "ast: %s" (CicNotationPp.pp_term t)); - let t' = TermContentPres.pp_ast t in - prerr_endline (sprintf "rendered ast: %s" - (CicNotationPp.pp_term t')); - let tbl = Hashtbl.create 0 in - dump_xml t' tbl "out.xml" - | statement -> - prerr_endline - ("Unsupported statement: " ^ - GrafiteAstPp.pp_statement - ~term_pp:CicNotationPp.pp_term - ~lazy_term_pp:(fun _ -> "_lazy_term_here_") - ~obj_pp:(fun _ -> "_obj_here_") - statement) - with - | End_of_file -> raise End_of_file - | HExtlib.Localized (floc,CicNotationParser.Parse_error msg) -> - let (x, y) = HExtlib.loc_of_floc floc in -(* let before = String.sub line 0 x in - let error = String.sub line x (y - x) in - let after = String.sub line y (String.length line - y) in - eprintf "%s%s%s\n" before error after; - prerr_endline (sprintf "at character %d-%d: %s" x y msg) *) - prerr_endline (sprintf "Parse error at character %d-%d: %s" - (!char_count + x) (!char_count + y) msg) - | exn -> - prerr_endline - (sprintf "Uncaught exception: %s" (Printexc.to_string exn)) - done - with End_of_file -> () - -let _ = - let arg_spec = [ ] in - let usage = "" in - Arg.parse arg_spec (fun _ -> raise (Arg.Bad usage)) usage; - print_endline "Loading builtin notation ..."; - print_endline "done."; - flush stdout; - process_stream (Ulexing.from_utf8_channel stdin) - diff --git a/helm/ocaml/hbugs/.depend b/helm/ocaml/hbugs/.depend deleted file mode 100644 index d6a85b905..000000000 --- a/helm/ocaml/hbugs/.depend +++ /dev/null @@ -1,20 +0,0 @@ -hbugs_common.cmi: hbugs_types.cmi -hbugs_id_generator.cmi: hbugs_types.cmi -hbugs_messages.cmi: hbugs_types.cmi -hbugs_client.cmi: hbugs_types.cmi -hbugs_misc.cmo: hbugs_misc.cmi -hbugs_misc.cmx: hbugs_misc.cmi -hbugs_common.cmo: hbugs_types.cmi hbugs_common.cmi -hbugs_common.cmx: hbugs_types.cmi hbugs_common.cmi -hbugs_id_generator.cmo: hbugs_id_generator.cmi -hbugs_id_generator.cmx: hbugs_id_generator.cmi -hbugs_messages.cmo: hbugs_types.cmi hbugs_misc.cmi hbugs_messages.cmi -hbugs_messages.cmx: hbugs_types.cmi hbugs_misc.cmx hbugs_messages.cmi -hbugs_client_gui.cmo: hbugs_client_gui.cmi -hbugs_client_gui.cmx: hbugs_client_gui.cmi -hbugs_client.cmo: hbugs_types.cmi hbugs_misc.cmi hbugs_messages.cmi \ - hbugs_id_generator.cmi hbugs_common.cmi hbugs_client_gui.cmi \ - hbugs_client.cmi -hbugs_client.cmx: hbugs_types.cmi hbugs_misc.cmx hbugs_messages.cmx \ - hbugs_id_generator.cmx hbugs_common.cmx hbugs_client_gui.cmx \ - hbugs_client.cmi diff --git a/helm/ocaml/hbugs/Makefile b/helm/ocaml/hbugs/Makefile deleted file mode 100644 index 4170d8081..000000000 --- a/helm/ocaml/hbugs/Makefile +++ /dev/null @@ -1,98 +0,0 @@ - -# Targets description: -# all (default) -> builds hbugs bytecode library hbugs.cma -# opt -> builds hbugs native library hbugs.cmxa -# daemons -> builds hbugs broker and tutors executables -# -# start -> starts up broker and tutors -# stop -> stop broker and tutors -# -# broker -> builds broker executable -# tutors -> builds tutors executables -# client -> builds hbugs client - -PACKAGE = hbugs - -IMPLEMENTATION_FILES = \ - hbugs_misc.ml \ - hbugs_common.ml \ - hbugs_id_generator.ml \ - hbugs_messages.ml \ - hbugs_client_gui.ml \ - hbugs_client.ml -INTERFACE_FILES = \ - hbugs_types.mli \ - $(patsubst %.ml, %.mli, $(IMPLEMENTATION_FILES)) - -include ../../Makefile.defs -include ../Makefile.common -include .tutors.ml -include .generated_tutors.ml - -.tutors.ml: - echo -n "TUTORS_ML = " > $@ - scripts/ls_tutors.ml | xargs >> $@ -.generated_tutors.ml: - echo -n "GENERATED_TUTORS_ML = " > $@ - scripts/ls_tutors.ml -auto | xargs >> $@ - -TUTORS = $(patsubst %.ml, %, $(TUTORS_ML)) -TUTORS_OPT = $(patsubst %, %.opt, $(TUTORS)) -GENERATED_TUTORS = $(patsubst %.ml, %, $(GENERATED_TUTORS_ML)) - -hbugs_client_gui.ml hbugs_client_gui.mli: hbugs_client_gui.glade - lablgladecc2 $< > hbugs_client_gui.ml - $(OCAMLC) -i hbugs_client_gui.ml > hbugs_client_gui.mli - -clean: clean_mains -.PHONY: clean_mains -clean_mains: - rm -f $(TUTORS) $(TUTORS_OPT) broker{,.opt} client{,.opt} -distclean: clean - rm -f $(GENERATED_TUTORS_ML) hbugs_client_gui.ml{,i} - rm -f .tutors.ml .generated_tutors.ml - -MAINS_DEPS = \ - hbugs_misc.cmo \ - hbugs_messages.cmo \ - hbugs_id_generator.cmo -TUTOR_DEPS = $(MAINS_DEPS) \ - hbugs_tutors.cmo -BROKER_DEPS = $(MAINS_DEPS) \ - hbugs_broker_registry.cmo -CLIENT_DEPS = $(MAINS_DEPS) \ - hbugs_client_gui.cmo \ - hbugs_common.cmo \ - hbugs_client.cmo -TUTOR_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(TUTOR_DEPS)) -BROKER_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(BROKER_DEPS)) -CLIENT_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(CLIENT_DEPS)) -$(GENERATED_TUTORS_ML): scripts/build_tutors.ml data/tutors_index.xml data/hbugs_tutor.TPL.ml - scripts/build_tutors.ml -hbugs_tutors.cmo: hbugs_tutors.cmi -hbugs_broker_registry.cmo: hbugs_broker_registry.cmi -.PHONY: daemons -daemons: tutors broker -.PHONY: tutors -tutors: all $(TUTORS) -%_tutor: $(TUTOR_DEPS) %_tutor.ml - $(OCAMLC) -linkpkg -o $@ $^ -%_tutor.opt: $(TUTOR_DEPS_OPT) %_tutor.ml - $(OCAMLOPT) -linkpkg -o $@ $^ -broker: $(BROKER_DEPS) broker.ml - $(OCAMLC) -linkpkg -o $@ $^ -broker.opt: $(BROKER_DEPS_OPT) broker.ml - $(OCAMLOPT) -linkpkg -o $@ $^ -client: $(CLIENT_DEPS) client.ml - $(OCAMLC) -linkpkg -o $@ $^ -client.opt: $(CLIENT_DEPS_OPT) client.ml - $(OCAMLOPT) -linkpkg -o $@ $^ - -.PHONY: start stop -start: - scripts/brokerctl.sh start - scripts/sabba.sh start -stop: - scripts/brokerctl.sh stop - scripts/sabba.sh stop - diff --git a/helm/ocaml/hbugs/broker.ml b/helm/ocaml/hbugs/broker.ml deleted file mode 100644 index 691f9d11a..000000000 --- a/helm/ocaml/hbugs/broker.ml +++ /dev/null @@ -1,293 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_types;; -open Printf;; - -let debug = true ;; -let debug_print s = if debug then prerr_endline (Lazy.force s) ;; - -let daemon_name = "H-Bugs Broker" ;; -let default_port = 49081 ;; -let port_env_var = "HELM_HBUGS_BROKER_PORT" ;; -let port = - try - int_of_string (Sys.getenv port_env_var) - with - | Not_found -> default_port - | Failure "int_of_string" -> - prerr_endline "Warning: invalid port, reverting to default"; - default_port -;; -let usage_string = "HBugs Broker: usage string not yet written :-(";; - -exception Unexpected_msg of message;; - -let return_xml_msg body outchan = - Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan -;; -let parse_musing_id = function - | Musing_started (_, musing_id) -> - prerr_endline ("#### Started musing ID: " ^ musing_id); - musing_id - | Musing_aborted (_, musing_id) -> musing_id - | msg -> - prerr_endline (sprintf "Assertion failed, received msg: %s" - (Hbugs_messages.string_of_msg msg)); - assert false -;; - -let do_critical = - let mutex = Mutex.create () in - fun action -> - try -(* debug_print (lazy "Acquiring lock ..."); *) - Mutex.lock mutex; -(* debug_print (lazy "Lock Acquired!"); *) - let res = Lazy.force action in -(* debug_print (lazy "Releaseing lock ..."); *) - Mutex.unlock mutex; -(* debug_print (lazy "Lock released!"); *) - res - with e -> Mutex.unlock mutex; raise e -;; - - (* registries *) -let clients = new Hbugs_broker_registry.clients in -let tutors = new Hbugs_broker_registry.tutors in -let musings = new Hbugs_broker_registry.musings in -let registries = - [ (clients :> Hbugs_broker_registry.registry); - (tutors :> Hbugs_broker_registry.registry); - (musings :> Hbugs_broker_registry.registry) ] -in - -let my_own_id = Hbugs_id_generator.new_broker_id () in - - (* debugging: dump broker internal status, used by '/dump' method *) -let dump_registries () = - assert debug; - String.concat "\n" (List.map (fun o -> o#dump) registries) -in - -let handle_msg outchan msg = - (* messages from clients *) - (match msg with - - | Help -> - Hbugs_messages.respond_msg (Usage usage_string) outchan - | Register_client (client_id, client_url) -> do_critical (lazy ( - try - clients#register client_id client_url; - Hbugs_messages.respond_msg (Client_registered my_own_id) outchan - with Hbugs_broker_registry.Client_already_in id -> - Hbugs_messages.respond_exc "already_registered" id outchan - )) - | Unregister_client client_id -> do_critical (lazy ( - if clients#isAuthenticated client_id then begin - clients#unregister client_id; - Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan - end else - Hbugs_messages.respond_exc "forbidden" client_id outchan - )) - | List_tutors client_id -> do_critical (lazy ( - if clients#isAuthenticated client_id then begin - Hbugs_messages.respond_msg - (Tutor_list (my_own_id, tutors#index)) - outchan - end else - Hbugs_messages.respond_exc "forbidden" client_id outchan - )) - | Subscribe (client_id, tutor_ids) -> do_critical (lazy ( - if clients#isAuthenticated client_id then begin - if List.length tutor_ids <> 0 then begin (* at least one tutor id *) - if List.for_all tutors#exists tutor_ids then begin - clients#subscribe client_id tutor_ids; - Hbugs_messages.respond_msg - (Subscribed (my_own_id, tutor_ids)) outchan - end else (* required subscription to at least one unexistent tutor *) - let missing_tutors = - List.filter (fun id -> not (tutors#exists id)) tutor_ids - in - Hbugs_messages.respond_exc - "tutor_not_found" (String.concat " " missing_tutors) outchan - end else (* no tutor id specified *) - Hbugs_messages.respond_exc "no_tutor_specified" "" outchan - end else - Hbugs_messages.respond_exc "forbidden" client_id outchan - )) - | State_change (client_id, new_state) -> do_critical (lazy ( - if clients#isAuthenticated client_id then begin - let active_musings = musings#getByClientId client_id in - prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings)); - if List.length active_musings = 0 then - prerr_endline ("No active musings for client " ^ client_id); - prerr_endline "CSC: State change!!!" ; - let stop_answers = - List.map (* collect Abort_musing message's responses *) - (fun id -> (* musing id *) - let tutor = snd (musings#getByMusingId id) in - Hbugs_messages.submit_req - ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id))) - active_musings - in - let stopped_musing_ids = List.map parse_musing_id stop_answers in - List.iter musings#unregister active_musings; - (match new_state with - | Some new_state -> (* need to start new musings *) - let subscriptions = clients#getSubscription client_id in - if List.length subscriptions = 0 then - prerr_endline ("No subscriptions for client " ^ client_id); - let started_musing_ids = - List.map (* register new musings and collect their ids *) - (fun tutor_id -> - let res = - Hbugs_messages.submit_req - ~url:(tutors#getUrl tutor_id) - (Start_musing (my_own_id, new_state)) - in - let musing_id = parse_musing_id res in - musings#register musing_id client_id tutor_id; - musing_id) - subscriptions - in - Hbugs_messages.respond_msg - (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids)) - outchan - | None -> (* no need to start new musings *) - Hbugs_messages.respond_msg - (State_accepted (my_own_id, stopped_musing_ids, [])) - outchan) - end else - Hbugs_messages.respond_exc "forbidden" client_id outchan - )) - - (* messages from tutors *) - - | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy ( - try - tutors#register tutor_id tutor_url hint_type dsc; - Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan - with Hbugs_broker_registry.Tutor_already_in id -> - Hbugs_messages.respond_exc "already_registered" id outchan - )) - | Unregister_tutor tutor_id -> do_critical (lazy ( - if tutors#isAuthenticated tutor_id then begin - tutors#unregister tutor_id; - Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan - end else - Hbugs_messages.respond_exc "forbidden" tutor_id outchan - )) - - | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy ( - if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *) - Hbugs_messages.respond_exc "forbidden" tutor_id outchan; - end else if not (musings#isActive musing_id) then begin (* too late *) - Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan; - end else begin (* all is ok: autorhized and on time *) - (match result with - | Sorry -> () - | Eureka hint -> - let client_url = - clients#getUrl (fst (musings#getByMusingId musing_id)) - in - let res = - Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint)) - in - (match res with - | Wow _ -> () (* ok: client is happy with our hint *) - | unexpected_msg -> - prerr_endline - (sprintf - "Warning: unexpected msg from client: %s\nExpected was: Wow" - (Hbugs_messages.string_of_msg msg)))); - Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan; - musings#unregister musing_id - end - )) - - | msg -> (* unexpected message *) - debug_print (lazy "Unknown message!"); - Hbugs_messages.respond_exc - "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan) -in -(* (* DEBUGGING wrapper around 'handle_msg' *) -let handle_msg outchan = - if debug then - (fun msg -> (* filter handle_msg through a function which dumps input - messages *) - debug_print (lazy (Hbugs_messages.string_of_msg msg)); - handle_msg outchan msg) - else - handle_msg outchan -in -*) - - (* thread action *) -let callback (req: Http_types.request) outchan = - try - debug_print (lazy ("Connection from " ^ req#clientAddr)); - debug_print (lazy ("Received request: " ^ req#path)); - (match req#path with - (* TODO write help message *) - | "/help" -> return_xml_msg " not yet written " outchan - | "/act" -> - let msg = Hbugs_messages.msg_of_string req#body in - handle_msg outchan msg - | "/dump" -> - if debug then - Http_daemon.respond ~body:(dump_registries ()) outchan - else - Http_daemon.respond_error ~code:400 outchan - | _ -> Http_daemon.respond_error ~code:400 outchan); - debug_print (lazy "Done!\n") - with - | Http_types.Param_not_found attr_name -> - Hbugs_messages.respond_exc "missing_parameter" attr_name outchan - | exc -> - Hbugs_messages.respond_exc - "uncaught_exception" (Printexc.to_string exc) outchan -in - - (* thread who cleans up ancient client/tutor/musing registrations *) -let ragman () = - let delay = 3600.0 in (* 1 hour delay *) - while true do - Thread.delay delay; - List.iter (fun o -> o#purge) registries - done -in - - (* start daemon *) -printf "Listening on port %d ...\n" port; -flush stdout; -ignore (Thread.create ragman ()); -Http_daemon.start' ~port ~mode:`Thread callback - diff --git a/helm/ocaml/hbugs/client.ml b/helm/ocaml/hbugs/client.ml deleted file mode 100644 index 93114b305..000000000 --- a/helm/ocaml/hbugs/client.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_common;; -open Printf;; - -let client = - new Hbugs_client.hbugsClient - ~use_hint_callback: - (fun hint -> - prerr_endline (sprintf "Using hint: %s" (string_of_hint hint))) - ~describe_hint_callback: - (fun hint -> - prerr_endline (sprintf "Describing hint: %s" (string_of_hint hint))) - () -in -client#show (); -GtkThread.main () - diff --git a/helm/ocaml/hbugs/data/hbugs_tutor.TPL.ml b/helm/ocaml/hbugs/data/hbugs_tutor.TPL.ml deleted file mode 100644 index 947e351c7..000000000 --- a/helm/ocaml/hbugs/data/hbugs_tutor.TPL.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -module TutorDescription = - struct - let addr = "@ADDR@" - let port = @PORT@ - let tactic = @TACTIC@ - let hint = @HINT@ - let hint_type = "@HINT_TYPE@" - let description = "@DESCRIPTION@" - let environment_file = "@ENVIRONMENT_FILE@" - end -;; -module Tutor = Hbugs_tutors.BuildTutor (TutorDescription) ;; -Tutor.start () ;; - diff --git a/helm/ocaml/hbugs/data/tutors_index.xml b/helm/ocaml/hbugs/data/tutors_index.xml deleted file mode 100644 index bd4baad45..000000000 --- a/helm/ocaml/hbugs/data/tutors_index.xml +++ /dev/null @@ -1,140 +0,0 @@ - - - - - - - - - 127.0.0.1 - 50001 - Ring.ring_tac - Hbugs_types.Use_ring_Luke - Use Ring Luke - Ring tutor - ring.environment - - - 127.0.0.1 - 50002 - FourierR.fourier_tac - Hbugs_types.Use_fourier_Luke - Use Fourier Luke - Fourier tutor - fourier.environment - - - 127.0.0.1 - 50003 - EqualityTactics.reflexivity_tac - Hbugs_types.Use_reflexivity_Luke - Use Reflexivity Luke - Reflexivity tutor - reflexivity.environment - - - 127.0.0.1 - 50004 - EqualityTactics.symmetry_tac - Hbugs_types.Use_symmetry_Luke - Use Symmetry Luke - Symmetry tutor - symmetry.environment - - - 127.0.0.1 - 50005 - VariousTactics.assumption_tac - Hbugs_types.Use_assumption_Luke - Use Assumption Luke - Assumption tutor - assumption.environment - - - 127.0.0.1 - 50006 - NegationTactics.contradiction_tac - Hbugs_types.Use_contradiction_Luke - Use Contradiction Luke - Contradiction tutor - contradiction.environment - - - 127.0.0.1 - 50007 - IntroductionTactics.exists_tac - Hbugs_types.Use_exists_Luke - Use Exists Luke - Exists tutor - exists.environment - - - 127.0.0.1 - 50008 - IntroductionTactics.split_tac - Hbugs_types.Use_split_Luke - Use Split Luke - Split tutor - split.environment - - - 127.0.0.1 - 50009 - IntroductionTactics.left_tac - Hbugs_types.Use_left_Luke - Use Left Luke - Left tutor - left.environment - - - 127.0.0.1 - 50010 - IntroductionTactics.right_tac - Hbugs_types.Use_right_Luke - Use Right Luke - Right tutor - right.environment - - - - 127.0.0.1 - 50011 - PrimitiveTactics.apply_tac - Hbugs_types.Use_apply_Luke - Use Apply Luke (with argument) - Search pattern apply tutor - search_pattern_apply.environment - - - diff --git a/helm/ocaml/hbugs/doc/hbugs.dia b/helm/ocaml/hbugs/doc/hbugs.dia deleted file mode 100644 index b1c4e64e2..000000000 Binary files a/helm/ocaml/hbugs/doc/hbugs.dia and /dev/null differ diff --git a/helm/ocaml/hbugs/hbugs_broker_registry.ml b/helm/ocaml/hbugs/hbugs_broker_registry.ml deleted file mode 100644 index 4670b5eca..000000000 --- a/helm/ocaml/hbugs/hbugs_broker_registry.ml +++ /dev/null @@ -1,317 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_misc;; -open Hbugs_types;; -open Printf;; - -exception Client_already_in of client_id;; -exception Client_not_found of client_id;; -exception Musing_already_in of musing_id;; -exception Musing_not_found of musing_id;; -exception Tutor_already_in of tutor_id;; -exception Tutor_not_found of tutor_id;; - -class type registry = - object - method dump: string - method purge: unit - end - -let expire_time = 1800. (* 30 minutes *) - -class clients = - object (self) - - inherit ThreadSafe.threadSafe -(* - (* *) - method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - (* *) -*) - - val timetable: (client_id, float) Hashtbl.t = Hashtbl.create 17 - val urls: (client_id, string) Hashtbl.t = Hashtbl.create 17 - val subscriptions: (client_id, tutor_id list) Hashtbl.t = Hashtbl.create 17 - - (** INVARIANT: each client registered has an entry in 'urls' hash table - _and_ in 'subscriptions hash table even if it hasn't yet invoked - 'subscribe' method *) - - method register id url = self#doWriter (lazy ( - if Hashtbl.mem urls id then - raise (Client_already_in id) - else begin - Hashtbl.add urls id url; - Hashtbl.add subscriptions id []; - Hashtbl.add timetable id (Unix.time ()) - end - )) - method private remove id = - Hashtbl.remove urls id; - Hashtbl.remove subscriptions id; - Hashtbl.remove timetable id - method unregister id = self#doWriter (lazy ( - if Hashtbl.mem urls id then - self#remove id - else - raise (Client_not_found id) - )) - method isAuthenticated id = self#doReader (lazy ( - Hashtbl.mem urls id - )) - method subscribe client_id tutor_ids = self#doWriter (lazy ( - if Hashtbl.mem urls client_id then - Hashtbl.replace subscriptions client_id tutor_ids - else - raise (Client_not_found client_id) - )) - method getUrl id = self#doReader (lazy ( - if Hashtbl.mem urls id then - Hashtbl.find urls id - else - raise (Client_not_found id) - )) - method getSubscription id = self#doReader (lazy ( - if Hashtbl.mem urls id then - Hashtbl.find subscriptions id - else - raise (Client_not_found id) - )) - - method dump = self#doReader (lazy ( - "\n" ^ - (Hashtbl.fold - (fun id url dump -> - (dump ^ - (sprintf "\n" id url) ^ - "\n" ^ - (String.concat "\n" (* id's subscriptions *) - (List.map - (fun tutor_id -> sprintf "\n" tutor_id) - (Hashtbl.find subscriptions id))) ^ - "\n\n")) - urls "") ^ - "" - )) - method purge = self#doWriter (lazy ( - let now = Unix.time () in - Hashtbl.iter - (fun id birthday -> - if now -. birthday > expire_time then - self#remove id) - timetable - )) - - end - -class tutors = - object (self) - - inherit ThreadSafe.threadSafe -(* - (* *) - method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - (* *) -*) - - val timetable: (tutor_id, float) Hashtbl.t = Hashtbl.create 17 - val tbl: (tutor_id, string * hint_type * string) Hashtbl.t = - Hashtbl.create 17 - - method register id url hint_type dsc = self#doWriter (lazy ( - if Hashtbl.mem tbl id then - raise (Tutor_already_in id) - else begin - Hashtbl.add tbl id (url, hint_type, dsc); - Hashtbl.add timetable id (Unix.time ()) - end - )) - method private remove id = - Hashtbl.remove tbl id; - Hashtbl.remove timetable id - method unregister id = self#doWriter (lazy ( - if Hashtbl.mem tbl id then - self#remove id - else - raise (Tutor_not_found id) - )) - method isAuthenticated id = self#doReader (lazy ( - Hashtbl.mem tbl id - )) - method exists id = self#doReader (lazy ( - Hashtbl.mem tbl id - )) - method getTutor id = self#doReader (lazy ( - if Hashtbl.mem tbl id then - Hashtbl.find tbl id - else - raise (Tutor_not_found id) - )) - method getUrl id = - let (url, _, _) = self#getTutor id in - url - method getHintType id = - let (_, hint_type, _) = self#getTutor id in - hint_type - method getDescription id = - let (_, _, dsc) = self#getTutor id in - dsc - method index = self#doReader (lazy ( - Hashtbl.fold - (fun id (url, hint_type, dsc) idx -> (id, dsc) :: idx) tbl [] - )) - - method dump = self#doReader (lazy ( - "\n" ^ - (Hashtbl.fold - (fun id (url, hint_type, dsc) dump -> - dump ^ - (sprintf -"\n%s\n%s\n" - id url hint_type dsc)) - tbl "") ^ - "" - )) - method purge = self#doWriter (lazy ( - let now = Unix.time () in - Hashtbl.iter - (fun id birthday -> - if now -. birthday > expire_time then - self#remove id) - timetable - )) - - end - -class musings = - object (self) - - inherit ThreadSafe.threadSafe -(* - (* *) - method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act - (* *) -*) - - val timetable: (musing_id, float) Hashtbl.t = Hashtbl.create 17 - val musings: (musing_id, client_id * tutor_id) Hashtbl.t = Hashtbl.create 17 - val clients: (client_id, musing_id list) Hashtbl.t = Hashtbl.create 17 - val tutors: (tutor_id, musing_id list) Hashtbl.t = Hashtbl.create 17 - - (** INVARIANT: each registered musing has - an entry in 'musings' table, an entry in 'clients' (i.e. one of the - musings for client_id is musing_id) table, an entry in 'tutors' table - (i.e. one of the musings for tutor_id is musing_id) and an entry in - 'timetable' table *) - - - method register musing_id client_id tutor_id = self#doWriter (lazy ( - if Hashtbl.mem musings musing_id then - raise (Musing_already_in musing_id) - else begin - Hashtbl.add musings musing_id (client_id, tutor_id); - (* now add this musing as the first one of musings list for client and - tutor *) - Hashtbl.replace clients client_id - (musing_id :: - (try Hashtbl.find clients client_id with Not_found -> [])); - Hashtbl.replace tutors tutor_id - (musing_id :: - (try Hashtbl.find tutors tutor_id with Not_found -> [])); - Hashtbl.add timetable musing_id (Unix.time ()) - end - )) - method private remove id = - (* ASSUMPTION: this method is invoked under a 'writer' lock *) - let (client_id, tutor_id) = self#getByMusingId' id in - Hashtbl.remove musings id; - (* now remove this musing from the list of musings for client and tutor - *) - Hashtbl.replace clients client_id - (List.filter ((<>) id) - (try Hashtbl.find clients client_id with Not_found -> [])); - Hashtbl.replace tutors tutor_id - (List.filter ((<>) id) - (try Hashtbl.find tutors tutor_id with Not_found -> [])); - Hashtbl.remove timetable id - method unregister id = self#doWriter (lazy ( - if Hashtbl.mem musings id then - self#remove id - )) - method private getByMusingId' id = - (* ASSUMPTION: this method is invoked under a 'reader' lock *) - try - Hashtbl.find musings id - with Not_found -> raise (Musing_not_found id) - method getByMusingId id = self#doReader (lazy ( - self#getByMusingId' id - )) - method getByClientId id = self#doReader (lazy ( - try - Hashtbl.find clients id - with Not_found -> [] - )) - method getByTutorId id = self#doReader (lazy ( - try - Hashtbl.find tutors id - with Not_found -> [] - )) - method isActive id = self#doReader (lazy ( - Hashtbl.mem musings id - )) - - method dump = self#doReader (lazy ( - "\n" ^ - (Hashtbl.fold - (fun mid (cid, tid) dump -> - dump ^ - (sprintf "\n" - mid cid tid)) - musings "") ^ - "" - )) - method purge = self#doWriter (lazy ( - let now = Unix.time () in - Hashtbl.iter - (fun id birthday -> - if now -. birthday > expire_time then - self#remove id) - timetable - )) - - end - diff --git a/helm/ocaml/hbugs/hbugs_broker_registry.mli b/helm/ocaml/hbugs/hbugs_broker_registry.mli deleted file mode 100644 index ece9e07cf..000000000 --- a/helm/ocaml/hbugs/hbugs_broker_registry.mli +++ /dev/null @@ -1,87 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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;; - -exception Client_already_in of client_id -exception Client_not_found of client_id -exception Musing_already_in of musing_id -exception Musing_not_found of musing_id -exception Tutor_already_in of tutor_id -exception Tutor_not_found of tutor_id - -class type registry = - object - method dump: string - method purge: unit - end - -class clients: - object - (** 'register client_id client_url' *) - method register: client_id -> string -> unit - method unregister: client_id -> unit - method isAuthenticated: client_id -> bool - (** subcribe a client to a set of tutor removing previous subcriptions *) - method subscribe: client_id -> tutor_id list -> unit - method getUrl: client_id -> string - method getSubscription: client_id -> tutor_id list - - method dump: string - method purge: unit - end - -class tutors: - object - method register: tutor_id -> string -> hint_type -> string -> unit - method unregister: tutor_id -> unit - method isAuthenticated: tutor_id -> bool - method exists: tutor_id -> bool - method getTutor: tutor_id -> string * hint_type * string - method getUrl: tutor_id -> string - method getHintType: tutor_id -> hint_type - method getDescription: tutor_id -> string - method index: tutor_dsc list - - method dump: string - method purge: unit - end - -class musings: - object - method register: musing_id -> client_id -> tutor_id -> unit - method unregister: musing_id -> unit - method getByMusingId: musing_id -> client_id * tutor_id - method getByClientId: client_id -> musing_id list - method getByTutorId: tutor_id -> musing_id list - method isActive: musing_id -> bool - - method dump: string - method purge: unit - end - diff --git a/helm/ocaml/hbugs/hbugs_client.ml b/helm/ocaml/hbugs/hbugs_client.ml deleted file mode 100644 index c7b5fae75..000000000 --- a/helm/ocaml/hbugs/hbugs_client.ml +++ /dev/null @@ -1,526 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_common;; -open Hbugs_types;; -open Printf;; - -exception Invalid_URL of string;; - -let do_nothing _ = ();; - -module SmartHbugs_client_gui = - struct - class ['a] oneColumnCList gtree_view ~column_type ~column_title - = - let obj = - ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in - let columns = new GTree.column_list in - let col = columns#add column_type in - let vcol = GTree.view_column ~title:column_title () - ~renderer:(GTree.cell_renderer_text[], ["text",col]) in - let store = GTree.list_store columns in - object(self) - inherit GTree.view obj - method clear = store#clear - method append (v : 'a) = - let row = store#append () in - store#set ~row ~column:col v; - method column = col - initializer - self#set_model (Some (store :> GTree.model)) ; - ignore (self#append_column vcol) - end - - class ['a,'b] twoColumnsCList gtree_view ~column1_type ~column2_type - ~column1_title ~column2_title - = - let obj = - ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in - let columns = new GTree.column_list in - let col1 = columns#add column1_type in - let vcol1 = GTree.view_column ~title:column1_title () - ~renderer:(GTree.cell_renderer_text[], ["text",col1]) in - let col2 = columns#add column2_type in - let vcol2 = GTree.view_column ~title:column2_title () - ~renderer:(GTree.cell_renderer_text[], ["text",col2]) in - let store = GTree.list_store columns in - object(self) - inherit GTree.view obj - method clear = store#clear - method append (v1 : 'a) (v2 : 'b) = - let row = store#append () in - store#set ~row ~column:col1 v1; - store#set ~row ~column:col2 v2 - method column1 = col1 - method column2 = col2 - initializer - self#set_model (Some (store :> GTree.model)) ; - ignore (self#append_column vcol1) ; - ignore (self#append_column vcol2) ; - end - - class subscribeWindow () = - object(self) - inherit Hbugs_client_gui.subscribeWindow () - val mutable tutorsSmartCList = None - method tutorsSmartCList = - match tutorsSmartCList with - None -> assert false - | Some w -> w - initializer - tutorsSmartCList <- - Some - (new twoColumnsCList self#tutorsCList - ~column1_type:Gobject.Data.string ~column2_type:Gobject.Data.string - ~column1_title:"Id" ~column2_title:"Description") - end - - class hbugsMainWindow () = - object(self) - inherit Hbugs_client_gui.hbugsMainWindow () - val mutable subscriptionSmartCList = None - val mutable hintsSmartCList = None - method subscriptionSmartCList = - match subscriptionSmartCList with - None -> assert false - | Some w -> w - method hintsSmartCList = - match hintsSmartCList with - None -> assert false - | Some w -> w - initializer - subscriptionSmartCList <- - Some - (new oneColumnCList self#subscriptionCList - ~column_type:Gobject.Data.string ~column_title:"Description") - initializer - hintsSmartCList <- - Some - (new oneColumnCList self#hintsCList - ~column_type:Gobject.Data.string ~column_title:"Description") - end - - end -;; - -class hbugsClient - ?(use_hint_callback: hint -> unit = do_nothing) - ?(describe_hint_callback: hint -> unit = do_nothing) - ?(destroy_callback: unit -> unit = do_nothing) - () - = - - let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in - let port_of_http_url url = - try - let subs = Pcre.extract ~rex:http_url_RE url in - int_of_string subs.(3) - with e -> raise (Invalid_URL url) - in - - object (self) - - val mainWindow = new SmartHbugs_client_gui.hbugsMainWindow () - val subscribeWindow = new SmartHbugs_client_gui.subscribeWindow () - val messageDialog = new Hbugs_client_gui.messageDialog () - val myOwnId = Hbugs_id_generator.new_client_id () - val mutable use_hint_callback = use_hint_callback - val mutable myOwnUrl = "localhost:49082" - val mutable brokerUrl = "localhost:49081" - val mutable brokerId: broker_id option = None - (* all available tutors, saved last time a List_tutors message was sent to - broker *) - val mutable availableTutors: tutor_dsc list = [] - val mutable statusContext = None - val mutable subscribeWindowStatusContext = None - val mutable debug = false (* enable/disable debugging buttons *) - val mutable hints = [] (* actually available hints *) - - initializer - self#initGui; - self#startLocalHttpDaemon (); - self#testLocalHttpDaemon (); - self#testBroker (); - self#registerToBroker (); - self#reconfigDebuggingButtons - - method show = mainWindow#hbugsMainWindow#show - method hide = mainWindow#hbugsMainWindow#misc#hide - - method setUseHintCallback callback = - use_hint_callback <- callback - - method private debugButtons = - List.map - (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget) - [ mainWindow#startLocalHttpDaemonButton; - mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ] - - method private initGui = - - (* GUI: main window *) - - (* ignore delete events so that hbugs window is closable only using - menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked - *) - - ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true)); - ignore (mainWindow#hbugsMainWindow#event#connect#destroy - (fun _ -> self#quit (); false)); - - (* GUI main window's menu *) - mainWindow#toggleDebuggingMenuItem#set_active debug; - ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled - self#toggleDebug); - - (* GUI: local HTTP daemon settings *) - ignore (mainWindow#clientUrlEntry#connect#changed - (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text)); - mainWindow#clientUrlEntry#set_text myOwnUrl; - ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked - self#startLocalHttpDaemon); - ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked - self#testLocalHttpDaemon); - - (* GUI: broker choice *) - ignore (mainWindow#brokerUrlEntry#connect#changed - (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text)); - mainWindow#brokerUrlEntry#set_text brokerUrl; - ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker); - mainWindow#clientIdLabel#set_text myOwnId; - - (* GUI: client registration *) - ignore (mainWindow#registerClientButton#connect#clicked - self#registerToBroker); - - (* GUI: subscriptions *) - ignore (mainWindow#showSubscriptionWindowButton#connect#clicked - (fun () -> - self#listTutors (); - subscribeWindow#subscribeWindow#show ())); - - let get_selected_row_index () = - match mainWindow#hintsCList#selection#get_selected_rows with - [path] -> - (match GTree.Path.get_indices path with - [|n|] -> n - | _ -> assert false) - | _ -> assert false - in - (* GUI: hints list *) - ignore ( - let event_ops = new GObj.event_ops mainWindow#hintsCList#as_widget in - event_ops#connect#button_press - (fun event -> - if GdkEvent.get_type event = `TWO_BUTTON_PRESS then - use_hint_callback (self#hint (get_selected_row_index ())) ; - false)); - - ignore (mainWindow#hintsCList#selection#connect#changed - (fun () -> - describe_hint_callback (self#hint (get_selected_row_index ())))) ; - - (* GUI: main status bar *) - let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in - statusContext <- Some ctxt; - ignore (ctxt#push "Ready"); - - (* GUI: subscription window *) - subscribeWindow#tutorsCList#selection#set_mode `MULTIPLE; - ignore (subscribeWindow#subscribeWindow#event#connect#delete - (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true)); - ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors); - ignore (subscribeWindow#subscribeButton#connect#clicked - self#subscribeSelected); - ignore (subscribeWindow#subscribeAllButton#connect#clicked - self#subscribeAll); - (subscribeWindow#tutorsCList#get_column 0)#set_visible false; - let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in - subscribeWindowStatusContext <- Some ctxt; - ignore (ctxt#push "Ready"); - - (* GUI: message dialog *) - ignore (messageDialog#messageDialog#event#connect#delete - (fun _ -> messageDialog#messageDialog#misc#hide (); true)); - ignore (messageDialog#okDialogButton#connect#clicked - (fun _ -> messageDialog#messageDialog#misc#hide ())) - - (* accessory methods *) - - (** pop up a (modal) dialog window showing msg to the user *) - method private showDialog msg = - messageDialog#dialogLabel#set_text msg; - messageDialog#messageDialog#show () - (** use showDialog to display an hbugs message to the user *) - method private showMsgInDialog msg = - self#showDialog (Hbugs_messages.string_of_msg msg) - - (** create a new thread which sends msg to broker, wait for an answer and - invoke callback passing response message as argument *) - method private sendReq ?(wait = false) ~msg callback = - let thread () = - try - callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg) - with - | (Hbugs_messages.Parse_error (subj, reason)) as e -> - self#showDialog - (sprintf -"Parse_error, unable to fullfill request. Details follow. -Request: %s -Error: %s" - (Hbugs_messages.string_of_msg msg) (Printexc.to_string e)); - | (Unix.Unix_error _) as e -> - self#showDialog - (sprintf -"Can't connect to HBugs Broker -Url: %s -Error: %s" - brokerUrl (Printexc.to_string e)) - | e -> - self#showDialog - (sprintf "hbugsClient#sendReq: Uncaught exception: %s" - (Printexc.to_string e)) - in - let th = Thread.create thread () in - if wait then - Thread.join th - else () - - (** check if a broker is authenticated using its broker_id - [ Background: during client registration, client save broker_id of its - broker, further messages from broker are accepted only if they carry the - same broker id ] *) - method private isAuthenticated id = - match brokerId with - | None -> false - | Some broker_id -> (id = broker_id) - - (* actions *) - - method private startLocalHttpDaemon = - (* flatten an hint tree to an hint list *) - let rec flatten_hint = function - | Hints hints -> List.concat (List.map flatten_hint hints) - | hint -> [hint] - in - fun () -> - let callback req outchan = - try - (match Hbugs_messages.msg_of_string req#body with - | Help -> - Hbugs_messages.respond_msg - (Usage "Local Http Daemon up and running!") outchan - | Hint (broker_id, hint) -> - if self#isAuthenticated broker_id then begin - let received_hints = flatten_hint hint in - List.iter - (fun h -> - (match h with Hints _ -> assert false | _ -> ()); - ignore(mainWindow#hintsSmartCList#append(string_of_hint h))) - received_hints; - hints <- hints @ received_hints; - Hbugs_messages.respond_msg (Wow myOwnId) outchan - end else (* msg from unauthorized broker *) - Hbugs_messages.respond_exc "forbidden" broker_id outchan - | msg -> - Hbugs_messages.respond_exc - "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan) - with (Hbugs_messages.Parse_error _) as e -> - Hbugs_messages.respond_exc - "parse_error" (Printexc.to_string e) outchan - in - let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used - only as a value to be sent to broker, local HTTP - daemon will listen on "0.0.0.0", port is parsed - from My URL though *) - let httpDaemonThread () = - try - Http_daemon.start' - ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback - with - | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url) - | e -> - self#showDialog (sprintf "Can't start local HTTP daemon: %s" - (Printexc.to_string e)) - in - ignore (Thread.create httpDaemonThread ()) - - method private testLocalHttpDaemon () = - try - let msg = - Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help) - myOwnUrl - in - ignore msg -(* self#showDialog msg *) - with - | Hbugs_misc.Malformed_URL url -> - self#showDialog - (sprintf - "Handshake with local HTTP daemon failed, Invalid URL: \"%s\"" - url) - | Hbugs_misc.Malformed_HTTP_response res -> - self#showDialog - (sprintf - "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\"" - res) - | (Unix.Unix_error _) as e -> - self#showDialog - (sprintf - "Handshake with local HTTP daemon failed, can't connect: \"%s\"" - (Printexc.to_string e)) - - method private testBroker () = - self#sendReq ~msg:Help - (function - | Usage _ -> () - | unexpected_msg -> - self#showDialog - (sprintf - "Handshake with HBugs Broker failed, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) - - method registerToBroker () = - (match brokerId with (* undo previous registration, if any *) - | Some id -> self#unregisterFromBroker () - | _ -> ()); - self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl)) - (function - | Client_registered broker_id -> (brokerId <- Some broker_id) - | unexpected_msg -> - self#showDialog - (sprintf "Client NOT registered, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) - - method unregisterFromBroker () = - self#sendReq ~wait:true ~msg:(Unregister_client myOwnId) - (function - | Client_unregistered _ -> (brokerId <- None) - | unexpected_msg -> ()) -(* - self#showDialog - (sprintf "Client NOT unregistered, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) -*) - - method stateChange new_state = - mainWindow#hintsSmartCList#clear (); - hints <- []; - self#sendReq - ~msg:(State_change (myOwnId, new_state)) - (function - | State_accepted _ -> () - | unexpected_msg -> - self#showDialog - (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) - - method hint = List.nth hints - - method private listTutors () = - (* wait is set to true just to make sure that after invoking listTutors - "availableTutors" is correctly filled *) - self#sendReq ~wait:true ~msg:(List_tutors myOwnId) - (function - | Tutor_list (_, descriptions) -> - availableTutors <- (* sort accordingly to tutor description *) - List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions; - subscribeWindow#tutorsSmartCList#clear (); - List.iter - (fun (id, dsc) -> - ignore (subscribeWindow#tutorsSmartCList#append id dsc)) - availableTutors - | unexpected_msg -> - self#showDialog - (sprintf "Can't list tutors, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) - - (* low level used by subscribeSelected and subscribeAll *) - method private subscribe' tutors_id = - self#sendReq ~msg:(Subscribe (myOwnId, tutors_id)) - (function - | (Subscribed (_, subscribedTutors)) as msg -> - let sort = List.sort compare in - mainWindow#subscriptionSmartCList#clear (); - List.iter - (fun tutor_id -> - ignore - (mainWindow#subscriptionSmartCList#append - ( try - List.assoc tutor_id availableTutors - with Not_found -> assert false ))) - tutors_id; - subscribeWindow#subscribeWindow#misc#hide (); - if sort subscribedTutors <> sort tutors_id then - self#showDialog - (sprintf "Subscription mismatch\n: %s" - (Hbugs_messages.string_of_msg msg)) - | unexpected_msg -> - mainWindow#subscriptionSmartCList#clear (); - self#showDialog - (sprintf "Subscription FAILED, unexpected message:\n%s" - (Hbugs_messages.string_of_msg unexpected_msg))) - - method private subscribeSelected () = - let tutorsSmartCList = subscribeWindow#tutorsSmartCList in - let selectedTutors = - List.map - (fun p -> - tutorsSmartCList#model#get - ~row:(tutorsSmartCList#model#get_iter p) - ~column:tutorsSmartCList#column1) - tutorsSmartCList#selection#get_selected_rows - in - self#subscribe' selectedTutors - - method subscribeAll () = - self#listTutors (); (* this fills 'availableTutors' field *) - self#subscribe' (List.map fst availableTutors) - - method private quit () = - self#unregisterFromBroker (); - destroy_callback () - - (** enable/disable debugging *) - method private setDebug value = debug <- value - - method private reconfigDebuggingButtons = - List.iter (* debug value changed, reconfigure buttons *) - (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ()) - self#debugButtons; - - method private toggleDebug () = - self#setDebug (not debug); - self#reconfigDebuggingButtons - - end -;; - diff --git a/helm/ocaml/hbugs/hbugs_client.mli b/helm/ocaml/hbugs/hbugs_client.mli deleted file mode 100644 index 0c2e93d80..000000000 --- a/helm/ocaml/hbugs/hbugs_client.mli +++ /dev/null @@ -1,33 +0,0 @@ - -open Hbugs_types - -exception Invalid_URL of string - - (* - @param use_hint_callback is called when the user double click on a hint - (default: do nothing) - @param describe_hint_callback is called when the user click on a hint - (default: do nothing) - *) -class hbugsClient : - ?use_hint_callback: (hint -> unit) -> - ?describe_hint_callback: (hint -> unit) -> - ?destroy_callback: (unit -> unit) -> - unit -> - object - - method show : unit -> unit - method hide : unit -> unit - - method setUseHintCallback : (hint -> unit) -> unit - method registerToBroker : unit -> unit - method unregisterFromBroker : unit -> unit - method subscribeAll : unit -> unit - - method stateChange : state option -> unit - - (** @return an hint by index *) - method hint : int -> hint - - end - diff --git a/helm/ocaml/hbugs/hbugs_client_gui.glade b/helm/ocaml/hbugs/hbugs_client_gui.glade deleted file mode 100644 index f88a8c388..000000000 --- a/helm/ocaml/hbugs/hbugs_client_gui.glade +++ /dev/null @@ -1,672 +0,0 @@ - - - - - - - - Hbugs: your personal proof trainer! - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - False - True - False - - - - True - False - 0 - - - - - - - True - Tools - True - - - - True - - - - True - Debugging - True - False - - - - - - - - - 0 - False - False - - - - - - True - False - 2 - - - - True - My URL: - False - False - GTK_JUSTIFY_CENTER - False - False - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - Local HTTP daemon URL - True - False - True - 0 - - True - * - False - - - 0 - True - True - - - - - - True - Start the local HTTP daemon listening on the specified URL - True - Start! - True - GTK_RELIEF_NORMAL - - - 0 - False - False - - - - - - True - True - Test! - True - GTK_RELIEF_NORMAL - - - 0 - False - False - - - - - 0 - False - False - - - - - - True - False - 0 - - - - True - False - 2 - - - - True - Broker: - False - False - GTK_JUSTIFY_CENTER - False - False - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - True - HBugs broker URL - True - False - True - 0 - - True - * - False - - - 0 - True - True - - - - - - True - True - Test! - True - GTK_RELIEF_NORMAL - - - 0 - False - False - - - - - 0 - False - False - - - - - - True - False - 2 - - - - Client ID: - False - False - GTK_JUSTIFY_CENTER - False - False - 0.5 - 0.5 - 0 - 0 - - - 0 - False - False - - - - - - - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - - - 0 - True - True - - - - - - True - True - (Re)Register - True - GTK_RELIEF_NORMAL - - - 0 - False - False - - - - - 0 - False - False - - - - - 0 - False - True - - - - - - True - 0 - - - - 4 - True - 0 - 0.5 - GTK_SHADOW_ETCHED_IN - - - - True - False - 2 - - - - True - GTK_POLICY_ALWAYS - GTK_POLICY_ALWAYS - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - True - False - False - True - - - - - 0 - True - True - - - - - - True - - - - 0 - 0 - True - True - Subscribe ... - True - GTK_RELIEF_NORMAL - - - 0 - 0 - - - - - 0 - False - False - - - - - - - - True - Subscriptions - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - - - label_item - - - - - False - False - - - - - - 4 - True - 0 - 0.5 - GTK_SHADOW_ETCHED_IN - - - - True - False - 0 - - - - True - GTK_POLICY_ALWAYS - GTK_POLICY_ALWAYS - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - True - False - False - True - - - - - 0 - True - True - - - - - - - - True - Hints - False - False - GTK_JUSTIFY_LEFT - False - False - 0.5 - 0.5 - 0 - 0 - - - label_item - - - - - True - True - - - - - 0 - True - True - - - - - - True - - - 0 - False - False - - - - - - - - Hbugs: subscribe ... - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - False - True - False - - - - True - False - 0 - - - - True - True - Refresh - True - GTK_RELIEF_NORMAL - - - 0 - False - False - - - - - - True - GTK_POLICY_ALWAYS - GTK_POLICY_ALWAYS - GTK_SHADOW_IN - GTK_CORNER_TOP_LEFT - - - - True - True - True - False - False - True - - - - - 0 - True - True - - - - - - True - False - 0 - - - - True - True - Subscribe to Selected - True - GTK_RELIEF_NORMAL - - - 0 - True - True - - - - - - True - True - Subscribe to All - True - GTK_RELIEF_NORMAL - - - 0 - True - True - - - - - 0 - False - False - - - - - - True - True - - - 0 - False - False - - - - - - - - Message - GTK_WINDOW_TOPLEVEL - GTK_WIN_POS_NONE - True - 220 - 150 - True - False - True - - - - True - False - 0 - - - - True - GTK_BUTTONBOX_END - - - - True - True - OK - True - GTK_RELIEF_NORMAL - 0 - - - - - 0 - False - True - GTK_PACK_END - - - - - - 5 - True - 1 - 1 - False - 0 - 0 - - - - True - - False - False - GTK_JUSTIFY_CENTER - True - False - 0.5 - 0.5 - 0 - 0 - - - 0 - 1 - 0 - 1 - - - - - 0 - True - True - - - - - - - diff --git a/helm/ocaml/hbugs/hbugs_common.ml b/helm/ocaml/hbugs/hbugs_common.ml deleted file mode 100644 index fe2ecfcae..000000000 --- a/helm/ocaml/hbugs/hbugs_common.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_types;; -open Printf;; - -let rec string_of_hint = function - | Use_ring -> "Use Ring, Luke!" - | Use_fourier -> "Use Fourier, Luke!" - | Use_reflexivity -> "Use reflexivity, Luke!" - | Use_symmetry -> "Use symmetry, Luke!" - | Use_assumption -> "Use assumption, Luke!" - | Use_contradiction -> "Use contradiction, Luke!" - | Use_exists -> "Use exists, Luke!" - | Use_split -> "Use split, Luke!" - | Use_left -> "Use left, Luke!" - | Use_right -> "Use right, Luke!" - | Use_apply term -> sprintf "Apply %s, Luke!" term - | Hints hints -> String.concat "; " (List.map string_of_hint hints) -;; - diff --git a/helm/ocaml/hbugs/hbugs_common.mli b/helm/ocaml/hbugs/hbugs_common.mli deleted file mode 100644 index 2d51075f3..000000000 --- a/helm/ocaml/hbugs/hbugs_common.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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;; - -val string_of_hint: hint -> string - diff --git a/helm/ocaml/hbugs/hbugs_id_generator.ml b/helm/ocaml/hbugs/hbugs_id_generator.ml deleted file mode 100644 index 5b1998ac2..000000000 --- a/helm/ocaml/hbugs/hbugs_id_generator.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -let _ = Random.self_init () - -let id_length = 32 -let min_ascii = 33 -let max_ascii = 126 - (* characters forbidden inside an XML attribute value. Well, '>' and ''' - aren't really forbidden, but are listed here ... just to be sure *) -let forbidden_chars = (* i.e. [ '"'; '&'; '\''; '<'; '>' ] *) - [ 34; 38; 39; 60; 62 ] (* assumption: is sorted! *) -let chars_range = max_ascii - min_ascii + 1 - (List.length forbidden_chars) - - (* return a random id char c such that - (min_ascii <= Char.code c) && - (Char.code c <= max_ascii) && - (not (List.mem (Char.code c) forbidden_chars)) - *) -let random_id_char () = - let rec nth_char ascii shifts = function - | [] -> Char.chr (ascii + shifts) - | hd::tl when ascii + shifts < hd -> Char.chr (ascii + shifts) - | hd::tl (* when ascii + shifts >= hd *) -> nth_char ascii (shifts + 1) tl - in - nth_char (Random.int chars_range + min_ascii) 0 forbidden_chars - - (* return a random id string which have length id_length *) -let new_id () = - let str = String.create id_length in - for i = 0 to id_length - 1 do - String.set str i (random_id_char ()) - done; - str - -let new_broker_id = new_id -let new_client_id = new_id -let new_musing_id = new_id -let new_tutor_id = new_id - diff --git a/helm/ocaml/hbugs/hbugs_id_generator.mli b/helm/ocaml/hbugs/hbugs_id_generator.mli deleted file mode 100644 index dad0c9391..000000000 --- a/helm/ocaml/hbugs/hbugs_id_generator.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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;; - -val new_broker_id: unit -> broker_id -val new_client_id: unit -> client_id -val new_musing_id: unit -> musing_id -val new_tutor_id: unit -> tutor_id - diff --git a/helm/ocaml/hbugs/hbugs_messages.ml b/helm/ocaml/hbugs/hbugs_messages.ml deleted file mode 100644 index 4767b2aee..000000000 --- a/helm/ocaml/hbugs/hbugs_messages.ml +++ /dev/null @@ -1,368 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_types;; -open Printf;; -open Pxp_document;; -open Pxp_dtd;; -open Pxp_types;; -open Pxp_yacc;; - -let debug = 2;; (* 0 -> no debug - 1 -> waiting for an answer / answer received - 2 -> XML messages dumping - *) - -exception Attribute_not_found of string;; -exception Empty_node;; (** found a node with no _element_ children *) -exception No_element_found of string;; -exception Parse_error of string * string;; (* parsing subject, reason *) -exception Unexpected_message of message;; - -let is_xml_element n = match n#node_type with T_element _ -> true | _ -> false -let get_attr node name = - try - (match node#attribute name with - | Value s -> s - | _ -> raise Not_found) - with Not_found -> raise (Attribute_not_found name) -let assert_element n name = - match n#node_type with - | T_element n when n = name -> - () - | _ -> raise (Parse_error ("", "Expected node: " ^ name)) - - (** given a string representation of a proof asistant state (e.g. the first - child of the XML root of a State_change or Start_musing message), build from - it an HBugs view of a proof assistant state *) -let parse_state (root: ('a node extension as 'a) node) = - if (List.filter is_xml_element root#sub_nodes) = [] then - raise Empty_node; - let buf = Buffer.create 10240 in - let node_to_string (node: ('a node extension as 'a) node) = - Buffer.clear buf; - node#write (`Out_buffer buf) `Enc_utf8; - let res = Buffer.contents buf in - Buffer.clear buf; - res - in - let (goal_node, type_node, body_node) = - try - (find_element "CurrentGoal" root, - find_element "ConstantType" root, - find_element "CurrentProof" root) - with Not_found -> - raise (Parse_error ("", "Malformed HBugs status XML document")) - in - assert_element root "gTopLevelStatus"; - assert_element goal_node "CurrentGoal"; - assert_element type_node "ConstantType"; - assert_element body_node "CurrentProof"; - goal_node#write (`Out_buffer buf) `Enc_utf8; - let (type_string, body_string) = - (node_to_string type_node, node_to_string body_node) - in - let goal = - try - int_of_string (goal_node#data) - with Failure "int_of_string" -> - raise (Parse_error (goal_node#data, "can't parse goal")) - in - (type_string, body_string, goal) - - (** parse an hint from an XML node, XML node should have type 'T_element _' - (the name is ignored), attributes on it are ignored *) -let parse_hint node = - let rec parse_hint_node node = - match node#node_type with - | T_element "ring" -> Use_ring - | T_element "fourier" -> Use_fourier - | T_element "reflexivity" -> Use_reflexivity - | T_element "symmetry" -> Use_symmetry - | T_element "assumption" -> Use_assumption - | T_element "contradiction" -> Use_contradiction - | T_element "exists" -> Use_exists - | T_element "split" -> Use_split - | T_element "left" -> Use_left - | T_element "right" -> Use_right - | T_element "apply" -> Use_apply node#data - | T_element "hints" -> - Hints - (List.map parse_hint_node (List.filter is_xml_element node#sub_nodes)) - | _ -> assert false (* CSC: should this assert false be a raise something? *) - in - match List.filter is_xml_element node#sub_nodes with - [node] -> parse_hint_node node - | _ -> assert false (* CSC: should this assert false be a raise something? *) - -let parse_hint_type n = n#data (* TODO parsare il possibile tipo di suggerimento *) -let parse_tutor_dscs n = - List.map - (fun n -> (get_attr n "id", n#data)) - (List.filter is_xml_element n#sub_nodes) -let parse_tutor_ids node = - List.map - (fun n -> get_attr n "id") (List.filter is_xml_element node#sub_nodes) - -let tutors_sep = Pcre.regexp ",\\s*" - -let pxp_config = PxpHelmConf.pxp_config -let msg_of_string' s = - let root = (* xml tree's root *) - parse_wfcontent_entity pxp_config (from_string s) PxpHelmConf.pxp_spec - in - match root#node_type with - - (* general purpose *) - | T_element "help" -> Help - | T_element "usage" -> Usage root#data - | T_element "exception" -> Exception (get_attr root "name", root#data) - - (* client -> broker *) - | T_element "register_client" -> - Register_client (get_attr root "id", get_attr root "url") - | T_element "unregister_client" -> Unregister_client (get_attr root "id") - | T_element "list_tutors" -> List_tutors (get_attr root "id") - | T_element "subscribe" -> - Subscribe (get_attr root "id", parse_tutor_ids root) - | T_element "state_change" -> - let state_node = - try - Some (find_element ~deeply:false "gTopLevelStatus" root) - with Not_found -> None - in - State_change - (get_attr root "id", - match state_node with - | Some n -> (try Some (parse_state n) with Empty_node -> None) - | None -> None) - | T_element "wow" -> Wow (get_attr root "id") - - (* tutor -> broker *) - | T_element "register_tutor" -> - let hint_node = find_element "hint_type" root in - let dsc_node = find_element "description" root in - Register_tutor - (get_attr root "id", get_attr root "url", - parse_hint_type hint_node, dsc_node#data) - | T_element "unregister_tutor" -> Unregister_tutor (get_attr root "id") - | T_element "musing_started" -> - Musing_started (get_attr root "id", get_attr root "musing_id") - | T_element "musing_aborted" -> - Musing_started (get_attr root "id", get_attr root "musing_id") - | T_element "musing_completed" -> - let main_node = - try - find_element "eureka" root - with Not_found -> find_element "sorry" root - in - Musing_completed - (get_attr root "id", get_attr root "musing_id", - (match main_node#node_type with - | T_element "eureka" -> - Eureka (parse_hint main_node) - | T_element "sorry" -> Sorry - | _ -> assert false)) (* can't be there, see 'find_element' above *) - - (* broker -> client *) - | T_element "client_registered" -> Client_registered (get_attr root "id") - | T_element "client_unregistered" -> Client_unregistered (get_attr root "id") - | T_element "tutor_list" -> - Tutor_list (get_attr root "id", parse_tutor_dscs root) - | T_element "subscribed" -> - Subscribed (get_attr root "id", parse_tutor_ids root) - | T_element "state_accepted" -> - State_accepted - (get_attr root "id", - List.map - (fun n -> get_attr n "id") - (List.filter is_xml_element (find_element "stopped" root)#sub_nodes), - List.map - (fun n -> get_attr n "id") - (List.filter is_xml_element (find_element "started" root)#sub_nodes)) - | T_element "hint" -> Hint (get_attr root "id", parse_hint root) - - (* broker -> tutor *) - | T_element "tutor_registered" -> Tutor_registered (get_attr root "id") - | T_element "tutor_unregistered" -> Tutor_unregistered (get_attr root "id") - | T_element "start_musing" -> - let state_node = - try - find_element ~deeply:false "gTopLevelStatus" root - with Not_found -> raise (No_element_found "gTopLevelStatus") - in - Start_musing (get_attr root "id", parse_state state_node) - | T_element "abort_musing" -> - Abort_musing (get_attr root "id", get_attr root "musing_id") - | T_element "thanks" -> Thanks (get_attr root "id", get_attr root "musing_id") - | T_element "too_late" -> - Too_late (get_attr root "id", get_attr root "musing_id") - - | _ -> raise (No_element_found s) - -let msg_of_string s = - try - msg_of_string' s - with e -> raise (Parse_error (s, Printexc.to_string e)) - -let pp_state = function - | Some (type_string, body_string, goal) -> - (* ASSUMPTION: type_string and body_string are well formed XML document - contents (i.e. they don't contain heading declaration nor - DOCTYPE one *) - "\n" ^ - (sprintf "%d\n" goal) ^ - type_string ^ "\n" ^ - body_string ^ "\n" ^ - "\n" - | None -> "\n" - -let rec pp_hint = function - | Use_ring -> sprintf "" - | Use_fourier -> sprintf "" - | Use_reflexivity -> sprintf "" - | Use_symmetry -> sprintf "" - | Use_assumption -> sprintf "" - | Use_contradiction -> sprintf "" - | Use_exists -> sprintf "" - | Use_split -> sprintf "" - | Use_left -> sprintf "" - | Use_right -> sprintf "" - | Use_apply term -> sprintf "%s" term - | Hints hints -> - sprintf "\n%s\n" - (String.concat "\n" (List.map pp_hint hints)) - -let pp_hint_type s = s (* TODO pretty print hint_type *) -let pp_tutor_dscs = - List.fold_left - (fun s (id, dsc) -> - sprintf "%s%s" s id dsc) - "" -let pp_tutor_ids = - List.fold_left (fun s id -> sprintf "%s" s id) "" - -let string_of_msg = function - | Help -> "" - | Usage usage_string -> sprintf "%s" usage_string - | Exception (name, value) -> - sprintf "%s" name value - | Register_client (id, url) -> - sprintf "" id url - | Unregister_client id -> sprintf "" id - | List_tutors id -> sprintf "" id - | Subscribe (id, tutor_ids) -> - sprintf "%s" - id (pp_tutor_ids tutor_ids) - | State_change (id, state) -> - sprintf "%s" - id (pp_state state) - | Wow id -> sprintf "" id - | Register_tutor (id, url, hint_type, dsc) -> - sprintf -" -%s -%s -" - id url (pp_hint_type hint_type) dsc - | Unregister_tutor id -> sprintf "" id - | Musing_started (id, musing_id) -> - sprintf "" id musing_id - | Musing_aborted (id, musing_id) -> - sprintf "" id musing_id - | Musing_completed (id, musing_id, result) -> - sprintf - "%s" - id musing_id - (match result with - | Sorry -> "" - | Eureka hint -> sprintf "%s" (pp_hint hint)) - | Client_registered id -> sprintf "" id - | Client_unregistered id -> sprintf "" id - | Tutor_list (id, tutor_dscs) -> - sprintf "%s" - id (pp_tutor_dscs tutor_dscs) - | Subscribed (id, tutor_ids) -> - sprintf "%s" - id (pp_tutor_ids tutor_ids) - | State_accepted (id, stop_ids, start_ids) -> - sprintf -" -%s -%s -" - id - (String.concat "" - (List.map (fun id -> sprintf "" id) stop_ids)) - (String.concat "" - (List.map (fun id -> sprintf "" id) start_ids)) - | Hint (id, hint) -> sprintf "%s" id (pp_hint hint) - | Tutor_registered id -> sprintf "" id - | Tutor_unregistered id -> sprintf "" id - | Start_musing (id, state) -> - sprintf "%s" - id (pp_state (Some state)) - | Abort_musing (id, musing_id) -> - sprintf "" id musing_id - | Thanks (id, musing_id) -> - sprintf "" id musing_id - | Too_late (id, musing_id) -> - sprintf "" id musing_id -;; - - (* debugging function that dump on stderr the sent messages *) -let dump_msg msg = - if debug >= 2 then - prerr_endline - (sprintf "\n%s\n" - (match msg with - | State_change _ -> "omissis ..." - | msg -> string_of_msg msg)) -;; - -let submit_req ~url msg = - dump_msg msg; - if debug >= 1 then (prerr_string "Waiting for an answer ... "; flush stderr); - let res = - msg_of_string (Hbugs_misc.http_post ~body:(string_of_msg msg) url) - in - if debug >= 1 then (prerr_string "answer received!\n"; flush stderr); - res -;; -let return_xml_msg body outchan = - Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan -;; -let respond_msg msg outchan = - dump_msg msg; - return_xml_msg (string_of_msg msg) outchan -(* close_out outchan *) -;; -let respond_exc name value = respond_msg (Exception (name, value));; - diff --git a/helm/ocaml/hbugs/hbugs_messages.mli b/helm/ocaml/hbugs/hbugs_messages.mli deleted file mode 100644 index 642c0b0e2..000000000 --- a/helm/ocaml/hbugs/hbugs_messages.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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;; - -exception Parse_error of string * string (* parsing subject, reason *) -exception Unexpected_message of message;; - -val msg_of_string: string -> message -val string_of_msg: message -> string - -val submit_req: url:string -> message -> message - (** close outchan afterwards *) -val respond_msg: message -> out_channel -> unit - (** close outchan afterwards *) - (* exception_name, exception_value, output_channel *) -val respond_exc: string -> string -> out_channel -> unit - -(* TODO the below functions are for debugging only and shouldn't be exposed *) -val parse_state: - ('a Pxp_document.node Pxp_document.extension as 'a) Pxp_document.node -> - (string * string * int) -val pp_state: (string * string * int) option -> string - diff --git a/helm/ocaml/hbugs/hbugs_misc.ml b/helm/ocaml/hbugs/hbugs_misc.ml deleted file mode 100644 index 32b8e8b46..000000000 --- a/helm/ocaml/hbugs/hbugs_misc.ml +++ /dev/null @@ -1,122 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Printf;; - -let rec hashtbl_remove_all tbl key = - if Hashtbl.mem tbl key then begin - Hashtbl.remove tbl key; - hashtbl_remove_all tbl key - end else - () - - (** follows cut and paste from zack's Http_client_smart module *) - -exception Malformed_URL of string;; -exception Malformed_HTTP_response of string;; - -let bufsiz = 16384;; -let tcp_bufsiz = 4096;; - -let body_sep_RE = Pcre.regexp "\r\n\r\n";; -let http_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "^http://";; -let url_RE = Pcre.regexp "^([\\w.]+)(:(\\d+))?(/.*)?$";; -let parse_url url = - try - let subs = - Pcre.extract ~rex:url_RE (Pcre.replace ~rex:http_scheme_RE url) - in - (subs.(1), - (if subs.(2) = "" then 80 else int_of_string subs.(3)), - (if subs.(4) = "" then "/" else subs.(4))) - with exc -> raise (Malformed_URL url) -;; -let get_body answer = - match Pcre.split ~rex:body_sep_RE answer with - | [_; body] -> body - | _ -> raise (Malformed_HTTP_response answer) -;; - -let init_socket addr port = - let inet_addr = (Unix.gethostbyname addr).Unix.h_addr_list.(0) in - let sockaddr = Unix.ADDR_INET (inet_addr, port) in - let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Unix.connect suck sockaddr; - let outchan = Unix.out_channel_of_descr suck in - let inchan = Unix.in_channel_of_descr suck in - (inchan, outchan) -;; -let rec retrieve inchan buf = - Buffer.add_string buf (input_line inchan ^ "\n"); - retrieve inchan buf -;; - -let http_get_iter_buf ~callback url = - let (address, port, path) = parse_url url in - let buf = String.create tcp_bufsiz in - let (inchan, outchan) = init_socket address port in - output_string outchan (sprintf "GET %s\r\n" path); - flush outchan; - (try - while true do - match input inchan buf 0 tcp_bufsiz with - | 0 -> raise End_of_file - | bytes when bytes = tcp_bufsiz -> (* buffer full, no need to slice it *) - callback buf - | bytes when bytes < tcp_bufsiz -> (* buffer not full, slice it *) - callback (String.sub buf 0 bytes) - | _ -> (* ( bytes < 0 ) || ( bytes > tcp_bufsiz ) *) - assert false - done - with End_of_file -> ()); - close_in inchan (* close also outchan, same fd *) -;; - -let http_get url = - let buf = Buffer.create (tcp_bufsiz * 10) in - http_get_iter_buf (fun data -> Buffer.add_string buf data) url; - get_body (Buffer.contents buf) -;; - -let http_post ?(body = "") url = - let (address, port, path) = parse_url url in - let (inchan, outchan) = init_socket address port in - output_string outchan (sprintf "POST %s HTTP/1.0\r\n" path); - output_string outchan (sprintf "Content-Length: %d\r\n" (String.length body)); - output_string outchan "\r\n"; - output_string outchan body; - flush outchan; - let buf = Buffer.create bufsiz in - (try - retrieve inchan buf - with End_of_file -> close_in inchan); (* close also outchan, same fd *) - get_body (Buffer.contents buf) -;; - diff --git a/helm/ocaml/hbugs/hbugs_misc.mli b/helm/ocaml/hbugs/hbugs_misc.mli deleted file mode 100644 index b0ef59719..000000000 --- a/helm/ocaml/hbugs/hbugs_misc.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - - (** helpers *) - - (** remove all bindings of a given key from an hash table *) -val hashtbl_remove_all: ('a, 'b) Hashtbl.t -> 'a -> unit - - (** follows cut and paste from zack's Http_client_smart module *) - - (** can't parse an HTTP url *) -exception Malformed_URL of string - (** can't parse an HTTP response *) -exception Malformed_HTTP_response of string - - (** HTTP GET request for a given url, return http response's body *) -val http_get: string -> string - (** HTTP POST request for a given url, return http response's body, - body argument, if specified, is sent as body along with request *) -val http_post: ?body:string -> string -> string - - (** perform an HTTP GET request and apply a given function on each - 'slice' of HTTP response read from server *) -val http_get_iter_buf: callback:(string -> unit) -> string -> unit - diff --git a/helm/ocaml/hbugs/hbugs_tutors.ml b/helm/ocaml/hbugs/hbugs_tutors.ml deleted file mode 100644 index 6a73e2cc2..000000000 --- a/helm/ocaml/hbugs/hbugs_tutors.ml +++ /dev/null @@ -1,266 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -open Hbugs_types;; -open Printf;; - -let broker_url = "localhost:49081/act";; -let dump_environment_on_exit = false;; - -let init_tutor = Hbugs_id_generator.new_tutor_id;; - - (** register a tutor to broker *) -let register_to_broker id url hint_type dsc = - try - let res = - Hbugs_messages.submit_req - ~url:broker_url (Register_tutor (id, url, hint_type, dsc)) - in - (match res with - | Tutor_registered id -> - prerr_endline (sprintf "Tutor registered, broker id: %s" id); - id - | unexpected_msg -> - raise (Hbugs_messages.Unexpected_message unexpected_msg)) - with e -> - failwith (sprintf "Can't register tutor to broker: uncaught exception: %s" - (Printexc.to_string e)) -;; - (** unregister a tutor from the broker *) -let unregister_from_broker id = - let res = Hbugs_messages.submit_req ~url:broker_url (Unregister_tutor id) in - match res with - | Tutor_unregistered _ -> prerr_endline "Tutor unregistered!" - | unexpected_msg -> - failwith - (sprintf "Can't unregister from broker, received unexpected msg: %s" - (Hbugs_messages.string_of_msg unexpected_msg)) -;; - - (* typecheck a loaded proof *) - (* TODO this is a cut and paste from gTopLevel.ml *) -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) -;; - -type xml_kind = Body | Type;; -let mk_dtdname ~ask_dtd_to_the_getter dtd = - if ask_dtd_to_the_getter then - Helm_registry.get "getter.url" ^ "getdtd?uri=" ^ dtd - else - "http://mowgli.cs.unibo.it/dtd/" ^ dtd -;; - (** this function must be the inverse function of GTopLevel.strip_xml_headings - *) -let add_xml_headings ~kind s = - let dtdname = mk_dtdname ~ask_dtd_to_the_getter:true "cic.dtd" in - let root = - match kind with - | Body -> "CurrentProof" - | Type -> "ConstantType" - in - "\n\n" ^ - "\n\n" ^ - s -;; - -let load_state (type_string, body_string, goal) = - prerr_endline "a0"; - let ((tmp1, oc1), (tmp2, oc2)) = - (Filename.open_temp_file "" "", Filename.open_temp_file "" "") - in - prerr_endline "a1"; - output_string oc1 (add_xml_headings ~kind:Type type_string); - output_string oc2 (add_xml_headings ~kind:Body body_string); - close_out oc1; close_out oc2; - prerr_endline (sprintf "Proof Type available in %s" tmp1); - prerr_endline (sprintf "Proof Body available in %s" tmp2); - let (proof, goal) = - prerr_endline "a2"; - (match CicParser.obj_of_xml tmp1 (Some tmp2) with - | Cic.CurrentProof (_,metasenv,bo,ty,_) -> (* TODO il primo argomento e' una URI valida o e' casuale? *) - prerr_endline "a3"; - let uri = UriManager.uri_of_string "cic:/foo.con" in - prerr_endline "a4"; - typecheck_loaded_proof metasenv bo ty; - prerr_endline "a5"; - ((uri, metasenv, bo, ty), goal) - | _ -> assert false) - in - prerr_endline "a6"; - Sys.remove tmp1; Sys.remove tmp2; - (proof, goal) - -(* tutors creation stuff from now on *) - -module type HbugsTutor = - sig - val start: unit -> unit - end - -module type HbugsTutorDescription = - sig - val addr: string - val port: int - val tactic: ProofEngineTypes.tactic - val hint: hint - val hint_type: hint_type - val description: string - val environment_file: string - end - -module BuildTutor (Dsc: HbugsTutorDescription) : HbugsTutor = - struct - let broker_id = ref None - let my_own_id = init_tutor () - let my_own_addr, my_own_port = Dsc.addr, Dsc.port - let my_own_url = sprintf "%s:%d" my_own_addr my_own_port - - let is_authenticated id = - match !broker_id with - | None -> false - | Some broker_id -> id = broker_id - - (* thread who do the dirty work *) - let slave (state, musing_id) = - prerr_endline (sprintf "Hi, I'm the slave for musing %s" musing_id); - let (proof, goal) = load_state state in - let success = - try - ignore (Dsc.tactic (proof, goal)); - true - with e -> false - in - let answer = - Musing_completed - (my_own_id, musing_id, (if success then Eureka Dsc.hint else Sorry)) - in - ignore (Hbugs_messages.submit_req ~url:broker_url answer); - prerr_endline - (sprintf "Bye, I've completed my duties (success = %b)" success) - - let hbugs_callback = - (* hashtbl mapping musings ids to PID of threads doing the related (dirty) - work *) - let slaves = Hashtbl.create 17 in - let forbidden () = - prerr_endline "ignoring request from unauthorized broker"; - Exception ("forbidden", "") - in - function (* _the_ callback *) - | Start_musing (broker_id, state) -> - if is_authenticated broker_id then begin - prerr_endline "received Start_musing"; - let new_musing_id = Hbugs_id_generator.new_musing_id () in - prerr_endline - (sprintf "starting a new musing (id = %s)" new_musing_id); -(* let slave_thread = Thread.create slave (state, new_musing_id) in *) - let slave_thread = - ExtThread.create slave (state, new_musing_id) - in - Hashtbl.add slaves new_musing_id slave_thread; - Musing_started (my_own_id, new_musing_id) - end else (* broker unauthorized *) - forbidden (); - | Abort_musing (broker_id, musing_id) -> - if is_authenticated broker_id then begin - (try (* kill thread responsible for "musing_id" *) - let slave_thread = Hashtbl.find slaves musing_id in - ExtThread.kill slave_thread; - Hashtbl.remove slaves musing_id - with - | ExtThread.Can_t_kill (_, reason) -> - prerr_endline (sprintf "Unable to kill slave: %s" reason) - | Not_found -> - prerr_endline (sprintf - "Can't find slave corresponding to musing %s, can't kill it" - musing_id)); - Musing_aborted (my_own_id, musing_id) - end else (* broker unauthorized *) - forbidden (); - | unexpected_msg -> - Exception ("unexpected_msg", - Hbugs_messages.string_of_msg unexpected_msg) - - let callback (req: Http_types.request) outchan = - try - let req_msg = Hbugs_messages.msg_of_string req#body in - let answer = hbugs_callback req_msg in - Http_daemon.respond ~body:(Hbugs_messages.string_of_msg answer) outchan - with Hbugs_messages.Parse_error (subj, reason) -> - Http_daemon.respond - ~body:(Hbugs_messages.string_of_msg - (Exception ("parse_error", reason))) - outchan - - let restore_environment () = - let ic = open_in Dsc.environment_file in - prerr_endline "Restoring environment ..."; - CicEnvironment.restore_from_channel - ~callback:(fun uri -> prerr_endline uri) ic; - prerr_endline "... done!"; - close_in ic - - let dump_environment () = - let oc = open_out Dsc.environment_file in - prerr_endline "Dumping environment ..."; - CicEnvironment.dump_to_channel - ~callback:(fun uri -> prerr_endline uri) oc; - prerr_endline "... done!"; - close_out oc - - let main () = - try - Sys.catch_break true; - at_exit (fun () -> - if dump_environment_on_exit then - dump_environment (); - unregister_from_broker my_own_id); - broker_id := - Some (register_to_broker - my_own_id my_own_url Dsc.hint_type Dsc.description); - if Sys.file_exists Dsc.environment_file then - restore_environment (); - Http_daemon.start' - ~addr:my_own_addr ~port:my_own_port ~mode:`Thread callback - with Sys.Break -> () (* exit nicely, invoking at_exit functions *) - - let start = main - - end - diff --git a/helm/ocaml/hbugs/hbugs_tutors.mli b/helm/ocaml/hbugs/hbugs_tutors.mli deleted file mode 100644 index 43cd99cce..000000000 --- a/helm/ocaml/hbugs/hbugs_tutors.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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;; - -val broker_url: string - -val register_to_broker: - tutor_id -> string -> hint_type -> string -> - broker_id -val unregister_from_broker: tutor_id -> unit - -val init_tutor: unit -> tutor_id -val load_state: - Hbugs_types.state -> - ProofEngineTypes.proof * ProofEngineTypes.goal - -module type HbugsTutor = - sig - val start: unit -> unit - end - -module type HbugsTutorDescription = - sig - val addr: string - val port: int - val tactic: ProofEngineTypes.tactic - val hint: hint - val hint_type: hint_type - val description: string - val environment_file: string - end - -module BuildTutor (Dsc: HbugsTutorDescription) : HbugsTutor - diff --git a/helm/ocaml/hbugs/hbugs_types.mli b/helm/ocaml/hbugs/hbugs_types.mli deleted file mode 100644 index e3067f2e9..000000000 --- a/helm/ocaml/hbugs/hbugs_types.mli +++ /dev/null @@ -1,104 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -type broker_id = string -type client_id = string -type musing_id = string -type tutor_id = string -type tutor_dsc = tutor_id * string (* tutor id, tutor description *) - -type state = (* proof assitant's state: proof type, proof body, goal *) - string * string * int - -type hint = - (* tactics usage related hints *) - | Use_ring - | Use_fourier - | Use_reflexivity - | Use_symmetry - | Use_assumption - | Use_contradiction - | Use_exists - | Use_split - | Use_left - | Use_right - | Use_apply of string (* use apply tactic on embedded term *) - (* hints list *) - | Hints of hint list - -type hint_type = string (* TODO tipo di consiglio per l'utente *) - -type musing_result = - | Eureka of hint (* extra information, if any, parsed depending - on tutor's hint_type *) - | Sorry - - (* for each message, first component is an ID that identify the sender *) -type message = - - (* general purpose *) - | Help (* help request *) - | Usage of string (* help response *) (* usage string *) - | Exception of string * string (* name, value *) - - (* client -> broker *) - | Register_client of client_id * string (* client id, client url *) - | Unregister_client of client_id (* client id *) - | List_tutors of client_id (* client_id *) - | Subscribe of client_id * tutor_id list (* client id, tutor id list *) - | State_change of client_id * state option (* client_id, new state *) - | Wow of client_id (* client_id *) - - (* tutor -> broker *) - | Register_tutor of tutor_id * string * hint_type * string - (* tutor id, tutor url, hint type, - tutor description *) - | Unregister_tutor of tutor_id (* tutor id *) - | Musing_started of tutor_id * musing_id (* tutor id, musing id *) - | Musing_aborted of tutor_id * musing_id (* tutor id, musing id *) - | Musing_completed of tutor_id * musing_id * musing_result - (* tutor id, musing id, result *) - - (* broker -> client *) - | Client_registered of broker_id (* broker id *) - | Client_unregistered of broker_id (* broker id *) - | Tutor_list of broker_id * tutor_dsc list (* broker id, tutor list *) - | Subscribed of broker_id * tutor_id list (* broker id, tutor list *) - | State_accepted of broker_id * musing_id list * musing_id list - (* broker id, stopped musing ids, - started musing ids *) - | Hint of broker_id * hint (* broker id, hint *) - - (* broker -> tutor *) - | Tutor_registered of broker_id (* broker id *) - | Tutor_unregistered of broker_id (* broker id *) - | Start_musing of broker_id * state (* broker id, state *) - | Abort_musing of broker_id * musing_id (* broker id, musing id *) - | Thanks of broker_id * musing_id (* broker id, musing id *) - | Too_late of broker_id * musing_id (* broker id, musing id *) - diff --git a/helm/ocaml/hbugs/scripts/brokerctl.sh b/helm/ocaml/hbugs/scripts/brokerctl.sh deleted file mode 100755 index 3da998d6c..000000000 --- a/helm/ocaml/hbugs/scripts/brokerctl.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/sh -daemon="broker" -if [ "$1" = "--help" -o "$1" = "" ]; then - echo "ctl.sh { start | stop | --help }" - exit 0 -fi -if [ "$1" = "start" ]; then - echo -n "Starting HBugs broker ... " - ./$daemon &> run/$daemon.log & - echo "done!" -elif [ "$1" = "stop" ]; then - echo -n "Stopping HBugs broker ... " - killall -9 $daemon - echo "done!" -fi diff --git a/helm/ocaml/hbugs/scripts/build_tutors.ml b/helm/ocaml/hbugs/scripts/build_tutors.ml deleted file mode 100755 index 9b742d84d..000000000 --- a/helm/ocaml/hbugs/scripts/build_tutors.ml +++ /dev/null @@ -1,112 +0,0 @@ -#!/usr/bin/ocamlrun /usr/bin/ocaml -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) -#use "topfind" -#require "pcre" -#require "pxp" -open Printf -open Pxp_document -open Pxp_dtd -open Pxp_types -open Pxp_yacc - -let index = "data/tutors_index.xml" -let template = "data/hbugs_tutor.TPL.ml" - - (* apply a set of regexp substitutions specified as a list of pairs - to a string *) -let rec apply_subst ~fill s = - match fill with - | [] -> s - | (pat, templ)::rest -> - apply_subst ~fill:rest (Pcre.replace ~pat ~templ s) - (* fill a ~template file with substitutions specified in ~fill (see - apply_subst) and save output to ~output *) -let fill_template ~template ~fill ~output = - printf "Creating %s ... " output; flush stdout; - let (ic, oc) = (open_in template, open_out output) in - let rec fill_template' () = - output_string oc ((apply_subst ~fill (input_line ic)) ^ "\n"); - fill_template' () - in - try - output_string oc (sprintf -"(* - THIS CODE IS GENERATED - DO NOT MODIFY! - - the source of this code is template \"%s\" - the template was filled with data read from \"%s\" -*)\n" - template index); - fill_template' () - with End_of_file -> - close_in ic; - close_out oc; - printf "done!\n"; flush stdout -let parse_xml fname = - parse_wfdocument_entity default_config (from_file fname) default_spec -let is_tutor node = - match node#node_type with T_element "tutor" -> true | _ -> false -let is_element node = - match node#node_type with T_element _ -> true | _ -> false -let main () = - (parse_xml index)#root#iter_nodes - (fun node -> - try - (match node with - | node when is_tutor node -> - (try (* skip hand-written tutors *) - ignore (find_element "no_auto" node); - raise Exit - with Not_found -> ()); - let output = - try - (match node#attribute "source" with - | Value s -> s - | _ -> assert false) - with Not_found -> assert false - in - let fill = - List.map (* create substitution list from index data *) - (fun node -> - let name = (* node name *) - (match node#node_type with - | T_element s -> s - | _ -> assert false) - in - let value = node#data in (* node value *) - (sprintf "@%s@" (String.uppercase name), (* pattern *) - value)) (* substitution *) - (List.filter is_element node#sub_nodes) - in - fill_template ~fill ~template ~output - | _ -> ()) - with Exit -> ()) - -let _ = main () - diff --git a/helm/ocaml/hbugs/scripts/ls_tutors.ml b/helm/ocaml/hbugs/scripts/ls_tutors.ml deleted file mode 100755 index 5fe796ca1..000000000 --- a/helm/ocaml/hbugs/scripts/ls_tutors.ml +++ /dev/null @@ -1,68 +0,0 @@ -#!/usr/bin/ocamlrun /usr/bin/ocaml -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* Usage: ls_tutors.ml # lists all tutors - * ls_tutors.ml -auto # lists only generated tutors - *) - -#use "topfind" -#require "pxp" -open Printf -open Pxp_document -open Pxp_dtd -open Pxp_types -open Pxp_yacc - -let index = "data/tutors_index.xml" -let auto_only = - try - (match Sys.argv.(1) with "-auto" -> true | _ -> false) - with Invalid_argument _ -> false -let parse_xml fname = - parse_wfdocument_entity default_config (from_file fname) default_spec -let is_tutor node = - match node#node_type with T_element "tutor" -> true | _ -> false -let main () = - List.iter - (fun tutor -> - try - (match tutor#attribute "source" with - | Value s -> - if not auto_only then - print_endline s - else (* we should print only generated tutors *) - (try - ignore (find_element "no_auto" tutor); - with Not_found -> - print_endline s) - | _ -> assert false) - with Not_found -> assert false) - (List.filter is_tutor (parse_xml index)#root#sub_nodes) -let _ = main () - diff --git a/helm/ocaml/hbugs/scripts/sabba.sh b/helm/ocaml/hbugs/scripts/sabba.sh deleted file mode 100755 index 2031e295f..000000000 --- a/helm/ocaml/hbugs/scripts/sabba.sh +++ /dev/null @@ -1,47 +0,0 @@ -#!/bin/sh -# Copyright (C) 2003: -# Stefano Zacchiroli -# 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/ -if [ "$1" = "--help" -o "$1" = "" ]; then - echo "sabba.sh { start | stop | --help }" - exit 0 -fi - -./scripts/ls_tutors.ml | -while read line; do - tutor=`echo $line | sed 's/\.ml//'` - if [ "$1" = "stop" ]; then - echo -n "Stopping HBugs tutor $tutor ... " - killall -9 $tutor - echo "done!" - elif [ "$1" = "start" ]; then - echo -n "Starting HBugs tutor $tutor ... " - nice -n 19 ./$tutor &> run/$tutor.log & - echo "done!" - else - echo "Uh? Try --help" - exit 1 - fi -done diff --git a/helm/ocaml/hbugs/search_pattern_apply_tutor.ml b/helm/ocaml/hbugs/search_pattern_apply_tutor.ml deleted file mode 100644 index 79c94beed..000000000 --- a/helm/ocaml/hbugs/search_pattern_apply_tutor.ml +++ /dev/null @@ -1,147 +0,0 @@ -(* $Id$ *) - -open Hbugs_types;; -open Printf;; - -exception Empty_must;; - -module MQI = MQueryInterpreter -module MQIC = MQIConn - -let broker_id = ref None -let my_own_id = Hbugs_tutors.init_tutor () -let my_own_addr, my_own_port = "127.0.0.1", 50011 -let my_own_url = sprintf "%s:%d" my_own_addr my_own_port -let environment_file = "search_pattern_apply.environment" -let dump_environment_on_exit = false - -let is_authenticated id = - match !broker_id with - | None -> false - | Some broker_id -> id = broker_id - - (* thread who do the dirty work *) -let slave mqi_handle (state, musing_id) = - try - prerr_endline (sprintf "Hi, I'm the slave for musing %s" musing_id); - let (proof, goal) = Hbugs_tutors.load_state state in - let hint = - try - let choose_must must only = (* euristic: use 2nd precision level - 1st is more precise but is more slow *) - match must with - | [] -> raise Empty_must - | _::hd::tl -> hd - | hd::tl -> hd - in - let uris = - TacticChaser.matchConclusion mqi_handle - ~output_html:prerr_endline ~choose_must () ~status:(proof, goal) - in - if uris = [] then - Sorry - else - Eureka (Hints (List.map (fun uri -> Use_apply uri) uris)) - with Empty_must -> Sorry - in - let answer = Musing_completed (my_own_id, musing_id, hint) in - ignore (Hbugs_messages.submit_req ~url:Hbugs_tutors.broker_url answer); - prerr_endline - (sprintf "Bye, I've completed my duties (success = %b)" (hint <> Sorry)) - with - (Pxp_types.At _) as e -> - let rec unbox_exception = - function - Pxp_types.At (_,e) -> unbox_exception e - | e -> e - in - prerr_endline ("Uncaught PXP exception: " ^ Pxp_types.string_of_exn e) ; - (* e could be the Thread.exit exception; otherwise we will release an *) - (* uncaught exception and the Pxp_types.At was already an uncaught *) - (* exception ==> no additional arm *) - raise (unbox_exception e) - -let hbugs_callback mqi_handle = - let ids = Hashtbl.create 17 in - let forbidden () = - prerr_endline "ignoring request from unauthorized broker"; - Exception ("forbidden", "") - in - function - | Start_musing (broker_id, state) -> - if is_authenticated broker_id then begin - prerr_endline "received Start_musing"; - let new_musing_id = Hbugs_id_generator.new_musing_id () in - let id = ExtThread.create (slave mqi_handle) (state, new_musing_id) in - prerr_endline (sprintf "starting a new musing (id = %s)" new_musing_id); - Hashtbl.add ids new_musing_id id; - (*ignore (Thread.create slave (state, new_musing_id));*) - Musing_started (my_own_id, new_musing_id) - end else (* broker unauthorized *) - forbidden (); - | Abort_musing (broker_id, musing_id) -> - prerr_endline "CSC: Abort_musing received" ; - if is_authenticated broker_id then begin - (* prerr_endline "Ignoring 'Abort_musing' message ..."; *) - (try - ExtThread.kill (Hashtbl.find ids musing_id) ; - Hashtbl.remove ids musing_id ; - with - Not_found - | ExtThread.Can_t_kill _ -> - prerr_endline ("Can not kill slave " ^ musing_id)) ; - Musing_aborted (my_own_id, musing_id) - end else (* broker unauthorized *) - forbidden (); - | unexpected_msg -> - Exception ("unexpected_msg", - Hbugs_messages.string_of_msg unexpected_msg) - -let callback mqi_handle (req: Http_types.request) outchan = - try - let req_msg = Hbugs_messages.msg_of_string req#body in - let answer = hbugs_callback mqi_handle req_msg in - Http_daemon.respond ~body:(Hbugs_messages.string_of_msg answer) outchan - with Hbugs_messages.Parse_error (subj, reason) -> - Http_daemon.respond - ~body:(Hbugs_messages.string_of_msg - (Exception ("parse_error", reason))) - outchan - -let restore_environment () = - let ic = open_in environment_file in - prerr_endline "Restoring environment ..."; - CicEnvironment.restore_from_channel - ~callback:(fun uri -> prerr_endline uri) ic; - prerr_endline "... done!"; - close_in ic - -let dump_environment () = - let oc = open_out environment_file in - prerr_endline "Dumping environment ..."; - CicEnvironment.dump_to_channel - ~callback:(fun uri -> prerr_endline uri) oc; - prerr_endline "... done!"; - close_out oc - -let main () = - try - Sys.catch_break true; - at_exit (fun () -> - if dump_environment_on_exit then - dump_environment (); - Hbugs_tutors.unregister_from_broker my_own_id); - broker_id := - Some (Hbugs_tutors.register_to_broker - my_own_id my_own_url "FOO" "Search_pattern_apply tutor"); - let mqi_handle = MQIC.init ~log:prerr_string () in - if Sys.file_exists environment_file then - restore_environment (); - Http_daemon.start' - ~addr:my_own_addr ~port:my_own_port ~mode:`Thread (callback mqi_handle); - MQIC.close mqi_handle - with Sys.Break -> () (* exit nicely, invoking at_exit functions *) -;; - -main () - diff --git a/helm/ocaml/hbugs/test/HBUGS_MESSAGES.xml b/helm/ocaml/hbugs/test/HBUGS_MESSAGES.xml deleted file mode 100644 index cf15dde3d..000000000 --- a/helm/ocaml/hbugs/test/HBUGS_MESSAGES.xml +++ /dev/null @@ -1,144 +0,0 @@ - - - - - - - usage string - - corpo dell'exc - - - - - - - - - - - - - - - - - - - 0 - - - - - - - - - - - - - - - - - - - - - descrizione del tutor - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - description 1 - description 2 - - description N - - - - description 1 - description 2 - - description N - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 0 - - - - - - - - - - - - - - diff --git a/helm/ocaml/hbugs/test/Makefile b/helm/ocaml/hbugs/test/Makefile deleted file mode 100644 index 0b3debf74..000000000 --- a/helm/ocaml/hbugs/test/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -all: test_serialization -test_serialization: test_serialization.ml - OCAMLPATH="../meta" ocamlfind ocamlc -linkpkg -package hbugs-common -o test_serialization test_serialization.ml -clean: - rm -f *.cm[io] test_serialization diff --git a/helm/ocaml/hbugs/test/test_serialization.ml b/helm/ocaml/hbugs/test/test_serialization.ml deleted file mode 100644 index 1afd74379..000000000 --- a/helm/ocaml/hbugs/test/test_serialization.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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 Pxp_document;; -open Pxp_dtd;; -open Pxp_types;; -open Pxp_yacc;; - -open Printf;; - -let test_data = "HBUGS_MESSAGES.xml" ;; - -let test_message (n:('a Pxp_document.extension as 'b) Pxp_document.node as 'a) = - try - let msg_string = - let buf = Buffer.create 1000 in - n#write (`Out_buffer buf) `Enc_utf8; - Buffer.contents buf - in - let msg = Hbugs_messages.msg_of_string msg_string in - let pp = Hbugs_messages.string_of_msg msg in - let msg' = Hbugs_messages.msg_of_string pp in - if (msg <> msg') then - prerr_endline - (sprintf "Failure with msg %s" - (match n#node_type with T_element name -> name | _ -> assert false)) - with e -> - prerr_endline - (sprintf "Failure with msg %s: uncaught exception %s" - (match n#node_type with T_element name -> name | _ -> assert false) - (Printexc.to_string e)) -;; - -let is_xml_element n = - match n#node_type with T_element _ -> true | _ -> false -;; - -let root = - parse_wfcontent_entity default_config (from_file test_data) default_spec -in -printf "Testing all messages from %s ...\n" test_data; flush stdout; -List.iter test_message (List.filter is_xml_element root#sub_nodes); -printf "Done!\n" -;; - diff --git a/helm/ocaml/hgdome/.depend b/helm/ocaml/hgdome/.depend deleted file mode 100644 index bf9c09af7..000000000 --- a/helm/ocaml/hgdome/.depend +++ /dev/null @@ -1,4 +0,0 @@ -domMisc.cmo: domMisc.cmi -domMisc.cmx: domMisc.cmi -xml2Gdome.cmo: xml2Gdome.cmi -xml2Gdome.cmx: xml2Gdome.cmi diff --git a/helm/ocaml/hgdome/Makefile b/helm/ocaml/hgdome/Makefile deleted file mode 100644 index 9630da26a..000000000 --- a/helm/ocaml/hgdome/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -PACKAGE = hgdome - -# modules which have both a .ml and a .mli -INTERFACE_FILES = \ - domMisc.mli \ - xml2Gdome.mli \ - $(NULL) - -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/hgdome/domMisc.ml b/helm/ocaml/hgdome/domMisc.ml deleted file mode 100644 index 97a15b7f8..000000000 --- a/helm/ocaml/hgdome/domMisc.ml +++ /dev/null @@ -1,43 +0,0 @@ -(* 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 *) -(* 06/01/2002 *) -(* *) -(* *) -(******************************************************************************) - -(* $Id$ *) - -let domImpl = Gdome.domImplementation () -let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm" -let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink" -let mathml_ns = Gdome.domString "http://www.w3.org/1998/Math/MathML" -let boxml_ns = Gdome.domString "http://helm.cs.unibo.it/2003/BoxML" - diff --git a/helm/ocaml/hgdome/domMisc.mli b/helm/ocaml/hgdome/domMisc.mli deleted file mode 100644 index 25d642bc5..000000000 --- a/helm/ocaml/hgdome/domMisc.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* 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 *) -(* 15/01/2003 *) -(* *) -(* *) -(******************************************************************************) - -val domImpl : Gdome.domImplementation - -val helm_ns : Gdome.domString (** HELM namespace *) -val xlink_ns : Gdome.domString (** XLink namespace *) -val mathml_ns : Gdome.domString (** MathML namespace *) -val boxml_ns : Gdome.domString (** BoxML namespace *) - diff --git a/helm/ocaml/hgdome/xml2Gdome.ml b/helm/ocaml/hgdome/xml2Gdome.ml deleted file mode 100644 index eb6a7641c..000000000 --- a/helm/ocaml/hgdome/xml2Gdome.ml +++ /dev/null @@ -1,135 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let document_of_xml (domImplementation : Gdome.domImplementation) strm = - let module G = Gdome in - let module X = Xml in - let rec update_namespaces ((defaultns,bindings) as namespaces) = - function - [] -> namespaces - | (None,"xmlns",value)::tl -> - update_namespaces (Some (Gdome.domString value),bindings) tl - | (prefix,name,value)::tl when prefix = Some "xmlns" -> - update_namespaces (defaultns,(name,Gdome.domString value)::bindings) tl - | _::tl -> update_namespaces namespaces tl in - let rec namespace_of_prefix (defaultns,bindings) = - function - None -> None - | Some "xmlns" -> Some (Gdome.domString "xml-ns") - | Some p' -> - try - Some (List.assoc p' bindings) - with - Not_found -> - raise - (Failure ("The prefix " ^ p' ^ " is not bound to any namespace")) in - let get_qualified_name p n = - match p with - None -> Gdome.domString n - | Some p' -> Gdome.domString (p' ^ ":" ^ n) in - let root_prefix,root_name,root_attributes,root_content = - ignore (Stream.next strm) ; (* to skip the declaration *) - ignore (Stream.next strm) ; (* to skip the DOCTYPE declaration *) - match Stream.next strm with - X.Empty(p,n,l) -> p,n,l,[<>] - | X.NEmpty(p,n,l,c) -> p,n,l,c - | _ -> assert false - in - let namespaces = update_namespaces (None,[]) root_attributes in - let namespaceURI = namespace_of_prefix namespaces root_prefix in - let document = - domImplementation#createDocument ~namespaceURI - ~qualifiedName:(get_qualified_name root_prefix root_name) - ~doctype:None - in - let rec aux namespaces (node : Gdome.node) = - parser - [< 'X.Str a ; s >] -> - let textnode = document#createTextNode ~data:(Gdome.domString a) in - ignore (node#appendChild ~newChild:(textnode :> Gdome.node)) ; - aux namespaces node s - | [< 'X.Empty(p,n,l) ; s >] -> - let namespaces' = update_namespaces namespaces l in - let namespaceURI = namespace_of_prefix namespaces' p in - let element = - document#createElementNS ~namespaceURI - ~qualifiedName:(get_qualified_name p n) - in - List.iter - (function (p,n,v) -> - if p = None then - element#setAttribute ~name:(Gdome.domString n) - ~value:(Gdome.domString v) - else - let namespaceURI = namespace_of_prefix namespaces' p in - element#setAttributeNS - ~namespaceURI - ~qualifiedName:(get_qualified_name p n) - ~value:(Gdome.domString v) - ) l ; - ignore - (node#appendChild - ~newChild:(element : Gdome.element :> Gdome.node)) ; - aux namespaces node s - | [< 'X.NEmpty(p,n,l,c) ; s >] -> - let namespaces' = update_namespaces namespaces l in - let namespaceURI = namespace_of_prefix namespaces' p in - let element = - document#createElementNS ~namespaceURI - ~qualifiedName:(get_qualified_name p n) - in - List.iter - (function (p,n,v) -> - if p = None then - element#setAttribute ~name:(Gdome.domString n) - ~value:(Gdome.domString v) - else - let namespaceURI = namespace_of_prefix namespaces' p in - element#setAttributeNS ~namespaceURI - ~qualifiedName:(get_qualified_name p n) - ~value:(Gdome.domString v) - ) l ; - ignore (node#appendChild ~newChild:(element :> Gdome.node)) ; - aux namespaces' (element :> Gdome.node) c ; - aux namespaces node s - | [< >] -> () - in - let root = document#get_documentElement in - List.iter - (function (p,n,v) -> - if p = None then - root#setAttribute ~name:(Gdome.domString n) - ~value:(Gdome.domString v) - else - let namespaceURI = namespace_of_prefix namespaces p in - root#setAttributeNS ~namespaceURI - ~qualifiedName:(get_qualified_name p n) - ~value:(Gdome.domString v) - ) root_attributes ; - aux namespaces (root : Gdome.element :> Gdome.node) root_content ; - document -;; diff --git a/helm/ocaml/hgdome/xml2Gdome.mli b/helm/ocaml/hgdome/xml2Gdome.mli deleted file mode 100644 index 45d0e9532..000000000 --- a/helm/ocaml/hgdome/xml2Gdome.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* 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 document_of_xml : - Gdome.domImplementation -> Xml.token Stream.t -> Gdome.document diff --git a/helm/ocaml/hmysql/.depend b/helm/ocaml/hmysql/.depend deleted file mode 100644 index e67a0660c..000000000 --- a/helm/ocaml/hmysql/.depend +++ /dev/null @@ -1,2 +0,0 @@ -hMysql.cmo: hMysql.cmi -hMysql.cmx: hMysql.cmi diff --git a/helm/ocaml/hmysql/Makefile b/helm/ocaml/hmysql/Makefile deleted file mode 100644 index 8a83eb23e..000000000 --- a/helm/ocaml/hmysql/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -PACKAGE = hmysql -PREDICATES = - -INTERFACE_FILES = \ - hMysql.mli -IMPLEMENTATION_FILES = \ - $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/hmysql/hMysql.ml b/helm/ocaml/hmysql/hMysql.ml deleted file mode 100644 index 94f3efe03..000000000 --- a/helm/ocaml/hmysql/hMysql.ml +++ /dev/null @@ -1,80 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -type dbd = Mysql.dbd option -type result = Mysql.result option -type error_code = Mysql.error_code - -let profiler = HExtlib.profile "mysql" - -let use_real_db () = - not (Helm_registry.get_opt_default Helm_registry.bool - ~default:false "db.nodb") - -let quick_connect ?host ?database ?port ?password ?user () = - profiler.HExtlib.profile - (fun () -> - if use_real_db () then - (Some (Mysql.quick_connect ?host ?database ?port ?password ?user ())) - else - None) - () - -let disconnect = function - | None -> () - | Some dbd -> profiler.HExtlib.profile Mysql.disconnect dbd - -let escape s = - profiler.HExtlib.profile Mysql.escape s - -let exec dbd s = - match dbd with - | None -> None - | Some dbd -> Some (profiler.HExtlib.profile (Mysql.exec dbd) s) - -let map res ~f = - match res with - | None -> [] - | Some res -> - let map f = Mysql.map res ~f in - profiler.HExtlib.profile map f - -let iter res ~f = - match res with - | None -> () - | Some res -> - let iter f = Mysql.iter res ~f in - profiler.HExtlib.profile iter f - -let errno = function - | None -> Mysql.Connection_error - | Some dbd -> profiler.HExtlib.profile Mysql.errno dbd - -let status = function - | None -> Mysql.StatusError Mysql.Connection_error - | Some dbd -> profiler.HExtlib.profile Mysql.status dbd - diff --git a/helm/ocaml/hmysql/hMysql.mli b/helm/ocaml/hmysql/hMysql.mli deleted file mode 100644 index a5b90593e..000000000 --- a/helm/ocaml/hmysql/hMysql.mli +++ /dev/null @@ -1,56 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(** - * {2 Proxy module around MySQL conection} - * - * The behaviour of this module is influenced by the Helm_registry boolean value - * of the "db.nodb" key. When set to "false" the module works as expected. When - * set to "true" all functions perform dummy action: connect and disconnect do - * nothing; exec, iter, and map work like the empty set of results has been - * returned; errno and status return Mysql.Connection_error - *) - -type dbd -type result - -(* the exceptions raised are from the Mysql module *) - -val quick_connect : - ?host:string -> - ?database:string -> - ?port:int -> ?password:string -> ?user:string -> unit -> dbd - -val disconnect : dbd -> unit - -val exec: dbd -> string -> result -val map : result -> f:(string option array -> 'a) -> 'a list -val iter : result -> f:(string option array -> unit) -> unit - -val errno : dbd -> Mysql.error_code -val status : dbd -> Mysql.status - -val escape: string -> string - diff --git a/helm/ocaml/lexicon/.depend b/helm/ocaml/lexicon/.depend deleted file mode 100644 index 452167c72..000000000 --- a/helm/ocaml/lexicon/.depend +++ /dev/null @@ -1,20 +0,0 @@ -lexiconAstPp.cmi: lexiconAst.cmo -disambiguatePp.cmi: lexiconAst.cmo -lexiconMarshal.cmi: lexiconAst.cmo -cicNotation.cmi: lexiconAst.cmo -lexiconEngine.cmi: lexiconMarshal.cmi lexiconAst.cmo cicNotation.cmi -lexiconSync.cmi: lexiconEngine.cmi -lexiconAstPp.cmo: lexiconAst.cmo lexiconAstPp.cmi -lexiconAstPp.cmx: lexiconAst.cmx lexiconAstPp.cmi -disambiguatePp.cmo: lexiconAstPp.cmi lexiconAst.cmo disambiguatePp.cmi -disambiguatePp.cmx: lexiconAstPp.cmx lexiconAst.cmx disambiguatePp.cmi -lexiconMarshal.cmo: lexiconAstPp.cmi lexiconAst.cmo lexiconMarshal.cmi -lexiconMarshal.cmx: lexiconAstPp.cmx lexiconAst.cmx lexiconMarshal.cmi -cicNotation.cmo: lexiconAst.cmo cicNotation.cmi -cicNotation.cmx: lexiconAst.cmx cicNotation.cmi -lexiconEngine.cmo: lexiconMarshal.cmi lexiconAst.cmo disambiguatePp.cmi \ - cicNotation.cmi lexiconEngine.cmi -lexiconEngine.cmx: lexiconMarshal.cmx lexiconAst.cmx disambiguatePp.cmx \ - cicNotation.cmx lexiconEngine.cmi -lexiconSync.cmo: lexiconEngine.cmi cicNotation.cmi lexiconSync.cmi -lexiconSync.cmx: lexiconEngine.cmx cicNotation.cmx lexiconSync.cmi diff --git a/helm/ocaml/lexicon/Makefile b/helm/ocaml/lexicon/Makefile deleted file mode 100644 index b8582baca..000000000 --- a/helm/ocaml/lexicon/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -PACKAGE = lexicon -PREDICATES = - -INTERFACE_FILES = \ - lexiconAstPp.mli \ - disambiguatePp.mli \ - lexiconMarshal.mli \ - cicNotation.mli \ - lexiconEngine.mli \ - lexiconSync.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - lexiconAst.ml \ - $(INTERFACE_FILES:%.mli=%.ml) - - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/lexicon/cicNotation.ml b/helm/ocaml/lexicon/cicNotation.ml deleted file mode 100644 index 1d18691ff..000000000 --- a/helm/ocaml/lexicon/cicNotation.ml +++ /dev/null @@ -1,83 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open LexiconAst - -type notation_id = - | RuleId of CicNotationParser.rule_id - | InterpretationId of TermAcicContent.interpretation_id - | PrettyPrinterId of TermContentPres.pretty_printer_id - -let process_notation st = - match st with - | Notation (loc, dir, l1, associativity, precedence, l2) -> - let rule_id = - if dir <> Some `RightToLeft then - [ RuleId (CicNotationParser.extend l1 ?precedence ?associativity - (fun env loc -> - CicNotationPt.AttributedTerm - (`Loc loc,TermContentPres.instantiate_level2 env l2))) ] - else - [] - in - let pp_id = - if dir <> Some `LeftToRight then - [ PrettyPrinterId - (TermContentPres.add_pretty_printer ?precedence ?associativity - l2 l1) ] - else - [] - in - rule_id @ pp_id - | Interpretation (loc, dsc, l2, l3) -> - let interp_id = TermAcicContent.add_interpretation dsc l2 l3 in - [InterpretationId interp_id] - | st -> [] - -let remove_notation = function - | RuleId id -> CicNotationParser.delete id - | PrettyPrinterId id -> TermContentPres.remove_pretty_printer id - | InterpretationId id -> TermAcicContent.remove_interpretation id - -let get_all_notations () = - List.map - (fun (interp_id, dsc) -> - InterpretationId interp_id, "interpretation: " ^ dsc) - (TermAcicContent.get_all_interpretations ()) - -let get_active_notations () = - List.map (fun id -> InterpretationId id) - (TermAcicContent.get_active_interpretations ()) - -let set_active_notations ids = - let interp_ids = - HExtlib.filter_map - (function InterpretationId interp_id -> Some interp_id | _ -> None) - ids - in - TermAcicContent.set_active_interpretations interp_ids - diff --git a/helm/ocaml/lexicon/cicNotation.mli b/helm/ocaml/lexicon/cicNotation.mli deleted file mode 100644 index 944438df8..000000000 --- a/helm/ocaml/lexicon/cicNotation.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -type notation_id - -val process_notation: LexiconAst.command -> notation_id list - -val remove_notation: notation_id -> unit - -(** {2 Notation enabling/disabling} - * Right now, only disabling of notation during pretty printing is supporting. - * If it is useful to disable it also for the input phase is still to be - * understood ... *) - -val get_all_notations: unit -> (notation_id * string) list (* id, dsc *) -val get_active_notations: unit -> notation_id list -val set_active_notations: notation_id list -> unit - diff --git a/helm/ocaml/lexicon/disambiguatePp.ml b/helm/ocaml/lexicon/disambiguatePp.ml deleted file mode 100644 index 5f6512477..000000000 --- a/helm/ocaml/lexicon/disambiguatePp.ml +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open DisambiguateTypes - -let alias_of_domain_and_codomain_items domain_item (dsc,_) = - match domain_item with - Id id -> LexiconAst.Ident_alias (id, dsc) - | Symbol (symb, i) -> LexiconAst.Symbol_alias (symb, i, dsc) - | Num i -> LexiconAst.Number_alias (i, dsc) - -let aliases_of_environment env = - Environment.fold - (fun domain_item codomain_item acc -> - alias_of_domain_and_codomain_items domain_item codomain_item::acc - ) env [] - -let aliases_of_domain_and_codomain_items_list l = - List.fold_left - (fun acc (domain_item,codomain_item) -> - alias_of_domain_and_codomain_items domain_item codomain_item::acc - ) [] l - -let pp_environment env = - let aliases = aliases_of_environment env in - let strings = - List.map (fun alias -> LexiconAstPp.pp_alias alias ^ ".") aliases - in - String.concat "\n" (List.sort compare strings) diff --git a/helm/ocaml/lexicon/disambiguatePp.mli b/helm/ocaml/lexicon/disambiguatePp.mli deleted file mode 100644 index e8d9b94a4..000000000 --- a/helm/ocaml/lexicon/disambiguatePp.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val aliases_of_domain_and_codomain_items_list: - (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list -> - LexiconAst.alias_spec list - -val pp_environment: DisambiguateTypes.environment -> string diff --git a/helm/ocaml/lexicon/lexiconAst.ml b/helm/ocaml/lexicon/lexiconAst.ml deleted file mode 100644 index aed4b0b15..000000000 --- a/helm/ocaml/lexicon/lexiconAst.ml +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type direction = [ `LeftToRight | `RightToLeft ] - -type loc = Token.flocation - -type alias_spec = - | Ident_alias of string * string (* identifier, uri *) - | Symbol_alias of string * int * string (* name, instance no, description *) - | Number_alias of int * string (* instance no, description *) - -(** To be increased each time the command type below changes, used for "safe" - * marshalling *) -let magic = 5 - -type command = - | Include of loc * string - | Alias of loc * alias_spec - (** parameters, name, type, fields *) - | Notation of loc * direction option * CicNotationPt.term * Gramext.g_assoc * - int * CicNotationPt.term - (* direction, l1 pattern, associativity, precedence, l2 pattern *) - | Interpretation of loc * - string * (string * CicNotationPt.argument_pattern list) * - CicNotationPt.cic_appl_pattern - (* description (i.e. id), symbol, arg pattern, appl pattern *) - -(* composed magic: term + command magics. No need to change this value *) -let magic = magic + 10000 * CicNotationPt.magic - diff --git a/helm/ocaml/lexicon/lexiconAstPp.ml b/helm/ocaml/lexicon/lexiconAstPp.ml deleted file mode 100644 index e49a66f60..000000000 --- a/helm/ocaml/lexicon/lexiconAstPp.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open LexiconAst - -let pp_l1_pattern = CicNotationPp.pp_term -let pp_l2_pattern = CicNotationPp.pp_term - -let pp_alias = function - | Ident_alias (id, uri) -> sprintf "alias id \"%s\" = \"%s\"" id uri - | Symbol_alias (symb, instance, desc) -> - sprintf "alias symbol \"%s\" (instance %d) = \"%s\"" - symb instance desc - | Number_alias (instance,desc) -> - sprintf "alias num (instance %d) = \"%s\"" instance desc - -let pp_associativity = function - | Gramext.LeftA -> "left associative" - | Gramext.RightA -> "right associative" - | Gramext.NonA -> "non associative" - -let pp_precedence i = sprintf "with precedence %d" i - -let pp_argument_pattern = function - | CicNotationPt.IdentArg (eta_depth, name) -> - let eta_buf = Buffer.create 5 in - for i = 1 to eta_depth do - Buffer.add_string eta_buf "\\eta." - done; - sprintf "%s%s" (Buffer.contents eta_buf) name - -let pp_interpretation dsc symbol arg_patterns cic_appl_pattern = - sprintf "interpretation \"%s\" '%s %s = %s" - dsc symbol - (String.concat " " (List.map pp_argument_pattern arg_patterns)) - (CicNotationPp.pp_cic_appl_pattern cic_appl_pattern) - -let pp_dir_opt = function - | None -> "" - | Some `LeftToRight -> "> " - | Some `RightToLeft -> "< " - -let pp_notation dir_opt l1_pattern assoc prec l2_pattern = - sprintf "notation %s\"%s\" %s %s for %s" - (pp_dir_opt dir_opt) - (pp_l1_pattern l1_pattern) - (pp_associativity assoc) - (pp_precedence prec) - (pp_l2_pattern l2_pattern) - -let pp_command = function - | Include (_,path) -> "include " ^ path - | Alias (_,s) -> pp_alias s - | Interpretation (_, dsc, (symbol, arg_patterns), cic_appl_pattern) -> - pp_interpretation dsc symbol arg_patterns cic_appl_pattern - | Notation (_, dir_opt, l1_pattern, assoc, prec, l2_pattern) -> - pp_notation dir_opt l1_pattern assoc prec l2_pattern - diff --git a/helm/ocaml/lexicon/lexiconAstPp.mli b/helm/ocaml/lexicon/lexiconAstPp.mli deleted file mode 100644 index b7ad59f3c..000000000 --- a/helm/ocaml/lexicon/lexiconAstPp.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val pp_command: LexiconAst.command -> string - -val pp_alias: LexiconAst.alias_spec -> string - diff --git a/helm/ocaml/lexicon/lexiconEngine.ml b/helm/ocaml/lexicon/lexiconEngine.ml deleted file mode 100644 index aec759c96..000000000 --- a/helm/ocaml/lexicon/lexiconEngine.ml +++ /dev/null @@ -1,150 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception IncludedFileNotCompiled of string (* file name *) -exception MetadataNotFound of string (* file name *) - -type status = { - aliases: DisambiguateTypes.environment; (** disambiguation aliases *) - multi_aliases: DisambiguateTypes.multiple_environment; - lexicon_content_rev: LexiconMarshal.lexicon; - notation_ids: CicNotation.notation_id list; (** in-scope notation ids *) - metadata: LibraryNoDb.metadata list; -} - -let add_lexicon_content cmds status = - let content = status.lexicon_content_rev in - let content' = - List.fold_right - (fun cmd acc -> cmd :: (List.filter ((<>) cmd) acc)) - cmds content - in -(* prerr_endline ("new lexicon content: " ^ String.concat " " (List.map - LexiconAstPp.pp_command content')); *) - { status with lexicon_content_rev = content' } - -let add_metadata new_metadata status = - if Helm_registry.get_bool "db.nodb" then - let metadata = status.metadata in - let metadata' = - List.fold_left - (fun acc m -> - match m with - | LibraryNoDb.Dependency buri -> - if List.exists (LibraryNoDb.eq_metadata m) metadata - then acc - else m :: acc) - metadata new_metadata - in - { status with metadata = metadata' } - else - status - -let set_proof_aliases status new_aliases = - let commands_of_aliases = - List.map - (fun alias -> LexiconAst.Alias (HExtlib.dummy_floc, alias)) - in - let deps_of_aliases = - HExtlib.filter_map - (function - | LexiconAst.Ident_alias (_, suri) -> - let buri = UriManager.buri_of_uri (UriManager.uri_of_string suri) in - Some (LibraryNoDb.Dependency buri) - | _ -> None) - in - let aliases = - List.fold_left (fun acc (d,c) -> DisambiguateTypes.Environment.add d c acc) - status.aliases new_aliases in - let multi_aliases = - List.fold_left (fun acc (d,c) -> DisambiguateTypes.Environment.cons d c acc) - status.multi_aliases new_aliases in - let new_status = - { status with multi_aliases = multi_aliases ; aliases = aliases} - in - if new_aliases = [] then - new_status - else - let aliases = - DisambiguatePp.aliases_of_domain_and_codomain_items_list new_aliases - in - let status = add_lexicon_content (commands_of_aliases aliases) new_status in - let status = add_metadata (deps_of_aliases aliases) status in - status - -let rec eval_command status cmd = - let notation_ids' = CicNotation.process_notation cmd in - let status = - { status with notation_ids = notation_ids' @ status.notation_ids } in - let basedir = Helm_registry.get "matita.basedir" in - match cmd with - | LexiconAst.Include (loc, baseuri) -> - let lexiconpath = LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri in - if not (Sys.file_exists lexiconpath) then - raise (IncludedFileNotCompiled lexiconpath); - let lexicon = LexiconMarshal.load_lexicon lexiconpath in - let status = List.fold_left eval_command status lexicon in - if Helm_registry.get_bool "db.nodb" then - let metadatapath = LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri in - if not (Sys.file_exists metadatapath) then - raise (MetadataNotFound metadatapath) - else - add_metadata (LibraryNoDb.load_metadata ~fname:metadatapath) status - else - status - | LexiconAst.Alias (loc, spec) -> - let diff = - (*CSC: Warning: this code should be factorized with the corresponding - code in DisambiguatePp *) - match spec with - | LexiconAst.Ident_alias (id,uri) -> - [DisambiguateTypes.Id id, - (uri,(fun _ _ _-> CicUtil.term_of_uri(UriManager.uri_of_string uri)))] - | LexiconAst.Symbol_alias (symb, instance, desc) -> - [DisambiguateTypes.Symbol (symb,instance), - DisambiguateChoices.lookup_symbol_by_dsc symb desc] - | LexiconAst.Number_alias (instance,desc) -> - [DisambiguateTypes.Num instance, - DisambiguateChoices.lookup_num_by_dsc desc] - in - set_proof_aliases status diff - | LexiconAst.Interpretation (_, dsc, (symbol, _), cic_appl_pattern) as stm -> - let status = add_lexicon_content [stm] status in - let uris = - List.map - (fun uri -> LibraryNoDb.Dependency (UriManager.buri_of_uri uri)) - (CicNotationUtil.find_appl_pattern_uris cic_appl_pattern) - in - let diff = - [DisambiguateTypes.Symbol (symbol, 0), - DisambiguateChoices.lookup_symbol_by_dsc symbol dsc] - in - let status = set_proof_aliases status diff in - let status = add_metadata uris status in - status - | LexiconAst.Notation _ as stm -> add_lexicon_content [stm] status - diff --git a/helm/ocaml/lexicon/lexiconEngine.mli b/helm/ocaml/lexicon/lexiconEngine.mli deleted file mode 100644 index ba0938640..000000000 --- a/helm/ocaml/lexicon/lexiconEngine.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -exception IncludedFileNotCompiled of string - -type status = { - aliases: DisambiguateTypes.environment; (** disambiguation aliases *) - multi_aliases: DisambiguateTypes.multiple_environment; - lexicon_content_rev: LexiconMarshal.lexicon; - notation_ids: CicNotation.notation_id list; (** in-scope notation ids *) - metadata: LibraryNoDb.metadata list; -} - -val eval_command : status -> LexiconAst.command -> status - -val set_proof_aliases: - status -> - (DisambiguateTypes.Environment.key * DisambiguateTypes.codomain_item) list -> - status diff --git a/helm/ocaml/lexicon/lexiconMarshal.ml b/helm/ocaml/lexicon/lexiconMarshal.ml deleted file mode 100644 index 7b9422db5..000000000 --- a/helm/ocaml/lexicon/lexiconMarshal.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type lexicon = LexiconAst.command list - -let format_name = "lexicon" - -let save_lexicon_to_file ~fname lexicon = - HMarshal.save ~fmt:format_name ~version:LexiconAst.magic ~fname lexicon - -let load_lexicon_from_file ~fname = - let raw = HMarshal.load ~fmt:format_name ~version:LexiconAst.magic ~fname in - (raw: lexicon) - -let rehash_cmd_uris = - let rehash_uri uri = - UriManager.uri_of_string (UriManager.string_of_uri uri) in - function - | LexiconAst.Interpretation (loc, dsc, args, cic_appl_pattern) -> - let rec aux = - function - | CicNotationPt.UriPattern uri -> - CicNotationPt.UriPattern (rehash_uri uri) - | CicNotationPt.ApplPattern args -> - CicNotationPt.ApplPattern (List.map aux args) - | CicNotationPt.VarPattern _ - | CicNotationPt.ImplicitPattern as pat -> pat - in - let appl_pattern = aux cic_appl_pattern in - LexiconAst.Interpretation (loc, dsc, args, appl_pattern) - | LexiconAst.Notation _ - | LexiconAst.Alias _ as cmd -> cmd - | cmd -> - prerr_endline "Found a command not expected in a .lexicon:"; - prerr_endline (LexiconAstPp.pp_command cmd); - assert false - -let save_lexicon ~fname lexicon = save_lexicon_to_file ~fname (List.rev lexicon) - -let load_lexicon ~fname = - let lexicon = load_lexicon_from_file ~fname in - List.map rehash_cmd_uris lexicon - diff --git a/helm/ocaml/lexicon/lexiconMarshal.mli b/helm/ocaml/lexicon/lexiconMarshal.mli deleted file mode 100644 index 930d73f8d..000000000 --- a/helm/ocaml/lexicon/lexiconMarshal.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -type lexicon = LexiconAst.command list - -val save_lexicon: fname:string -> lexicon -> unit - - (** @raise HMarshal.* *) -val load_lexicon: fname:string -> lexicon - diff --git a/helm/ocaml/lexicon/lexiconSync.ml b/helm/ocaml/lexicon/lexiconSync.ml deleted file mode 100644 index d7fa27f90..000000000 --- a/helm/ocaml/lexicon/lexiconSync.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let alias_diff ~from status = - let module Map = DisambiguateTypes.Environment in - Map.fold - (fun domain_item (description1,_ as codomain_item) acc -> - try - let description2,_ = Map.find domain_item from.LexiconEngine.aliases in - if description1 <> description2 then - (domain_item,codomain_item)::acc - else - acc - with - Not_found -> - (domain_item,codomain_item)::acc) - status.LexiconEngine.aliases [] - -let alias_diff = - let profiler = HExtlib.profile "alias_diff (conteggiato anche in include)" in - fun ~from status -> profiler.HExtlib.profile (alias_diff ~from) status - -(** given a uri and a type list (the contructors types) builds a list of pairs - * (name,uri) that is used to generate automatic aliases **) -let extract_alias types uri = - fst(List.fold_left ( - fun (acc,i) (name, _, _, cl) -> - (name, UriManager.uri_of_uriref uri i None) :: - (fst(List.fold_left ( - fun (acc,j) (name,_) -> - (((name,UriManager.uri_of_uriref uri i - (Some j)) :: acc) , j+1) - ) (acc,1) cl)),i+1 - ) ([],0) types) - -let build_aliases = - List.map - (fun (name,uri) -> - DisambiguateTypes.Id name, - (UriManager.string_of_uri uri, fun _ _ _ -> CicUtil.term_of_uri uri)) - -let add_aliases_for_inductive_def status types uri = - let aliases = build_aliases (extract_alias types uri) in - LexiconEngine.set_proof_aliases status aliases - -let add_alias_for_constant status uri = - let name = UriManager.name_of_uri uri in - let new_env = build_aliases [(name,uri)] in - LexiconEngine.set_proof_aliases status new_env - -let add_aliases_for_object status uri = - function - Cic.InductiveDefinition (types,_,_,_) -> - add_aliases_for_inductive_def status types uri - | Cic.Constant _ -> add_alias_for_constant status uri - | Cic.Variable _ - | Cic.CurrentProof _ -> assert false - -let add_aliases_for_objs = - List.fold_left - (fun status uri -> - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - add_aliases_for_object status uri obj) - -module OrderedId = -struct - type t = CicNotation.notation_id - let compare = Pervasives.compare -end - -module IdSet = Set.Make (OrderedId) - - (** @return l2 \ l1 *) -let id_list_diff l2 l1 = - let module S = IdSet in - let s1 = List.fold_left (fun set uri -> S.add uri set) S.empty l1 in - let s2 = List.fold_left (fun set uri -> S.add uri set) S.empty l2 in - let diff = S.diff s2 s1 in - S.fold (fun uri uris -> uri :: uris) diff [] - -let time_travel ~present ~past = - let notation_to_remove = - id_list_diff present.LexiconEngine.notation_ids - past.LexiconEngine.notation_ids - in - List.iter CicNotation.remove_notation notation_to_remove - -let init = - { - LexiconEngine.aliases = DisambiguateTypes.Environment.empty; - multi_aliases = DisambiguateTypes.Environment.empty; - lexicon_content_rev = []; - notation_ids = []; - metadata = []; - } diff --git a/helm/ocaml/lexicon/lexiconSync.mli b/helm/ocaml/lexicon/lexiconSync.mli deleted file mode 100644 index 62d8b97f5..000000000 --- a/helm/ocaml/lexicon/lexiconSync.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val add_aliases_for_objs: - LexiconEngine.status -> UriManager.uri list -> LexiconEngine.status - -val time_travel: - present:LexiconEngine.status -> past:LexiconEngine.status -> unit - - (** perform a diff between the aliases contained in two statuses, assuming - * that the second one can only have more aliases than the first one - * @return the list of aliases that should be added to aliases of from in - * order to be equal to aliases of the second argument *) -val alias_diff: - from:LexiconEngine.status -> LexiconEngine.status -> - (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list - -val init: LexiconEngine.status diff --git a/helm/ocaml/library/.depend b/helm/ocaml/library/.depend deleted file mode 100644 index 5054959da..000000000 --- a/helm/ocaml/library/.depend +++ /dev/null @@ -1,25 +0,0 @@ -cicCoercion.cmi: coercDb.cmi -cicElim.cmo: cicElim.cmi -cicElim.cmx: cicElim.cmi -cicRecord.cmo: cicRecord.cmi -cicRecord.cmx: cicRecord.cmi -libraryMisc.cmo: libraryMisc.cmi -libraryMisc.cmx: libraryMisc.cmi -libraryDb.cmo: libraryDb.cmi -libraryDb.cmx: libraryDb.cmi -coercDb.cmo: coercDb.cmi -coercDb.cmx: coercDb.cmi -cicCoercion.cmo: coercDb.cmi cicCoercion.cmi -cicCoercion.cmx: coercDb.cmx cicCoercion.cmi -coercGraph.cmo: coercDb.cmi coercGraph.cmi -coercGraph.cmx: coercDb.cmx coercGraph.cmi -librarySync.cmo: libraryDb.cmi coercGraph.cmi coercDb.cmi cicRecord.cmi \ - cicElim.cmi cicCoercion.cmi librarySync.cmi -librarySync.cmx: libraryDb.cmx coercGraph.cmx coercDb.cmx cicRecord.cmx \ - cicElim.cmx cicCoercion.cmx librarySync.cmi -libraryNoDb.cmo: libraryNoDb.cmi -libraryNoDb.cmx: libraryNoDb.cmi -libraryClean.cmo: librarySync.cmi libraryNoDb.cmi libraryMisc.cmi \ - libraryDb.cmi libraryClean.cmi -libraryClean.cmx: librarySync.cmx libraryNoDb.cmx libraryMisc.cmx \ - libraryDb.cmx libraryClean.cmi diff --git a/helm/ocaml/library/Makefile b/helm/ocaml/library/Makefile deleted file mode 100644 index 4f0ca3eb8..000000000 --- a/helm/ocaml/library/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -PACKAGE = library -PREDICATES = - -INTERFACE_FILES = \ - cicElim.mli \ - cicRecord.mli \ - libraryMisc.mli \ - libraryDb.mli \ - coercDb.mli \ - cicCoercion.mli \ - coercGraph.mli \ - librarySync.mli \ - libraryNoDb.mli \ - libraryClean.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/library/cicCoercion.ml b/helm/ocaml/library/cicCoercion.ml deleted file mode 100644 index fe636ee35..000000000 --- a/helm/ocaml/library/cicCoercion.ml +++ /dev/null @@ -1,156 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) else () - -(* given the new coercion uri from src to tgt returns the list - * of new coercions to create. hte list elements are - * (source, list of coercions to follow, target) - *) -let get_closure_coercions src tgt uri coercions = - let eq_carr s t = - try - CoercDb.eq_carr s t - with - | CoercDb.EqCarrNotImplemented _ | CoercDb.EqCarrOnNonMetaClosed -> false - in - match src,tgt with - | CoercDb.Uri _, CoercDb.Uri _ -> - let c_from_tgt = - List.filter (fun (f,_,_) -> eq_carr f tgt) coercions - in - let c_to_src = - List.filter (fun (_,t,_) -> eq_carr t src) coercions - in - (List.map (fun (_,t,u) -> src,[uri; u],t) c_from_tgt) @ - (List.map (fun (s,_,u) -> s,[u; uri],tgt) c_to_src) @ - (List.fold_left ( - fun l (s,_,u1) -> - ((List.map (fun (_,t,u2) -> - (s,[u1;uri;u2],t) - )c_from_tgt)@l) ) - [] c_to_src) - | _ -> [] (* do not close in case source or target is not an indty ?? *) -;; - -let obj_attrs = [`Class `Coercion; `Generated] - -(* generate_composite_closure (c2 (c1 s)) in the universe graph univ *) -let generate_composite_closure c1 c2 univ = - let c1_ty,univ = CicTypeChecker.type_of_aux' [] [] c1 univ in - let rec mk_rels n = - match n with - | 0 -> [] - | _ -> (Cic.Rel n) :: (mk_rels (n-1)) - in - let rec compose k = - function - | Cic.Prod (name,src,tgt) -> - let name = - match name with - | Cic.Anonymous -> Cic.Name "x" - | _ -> name - in - Cic.Lambda (name,src,compose (k+1) tgt) - | Cic.Appl (he::tl) -> - Cic.Appl (c2 :: tl @ [Cic.Appl (c1 :: (mk_rels k)) ]) - | _ -> Cic.Appl (c2 :: [Cic.Appl (c1 :: (mk_rels k)) ]) - in - let c = compose 0 c1_ty in - let c_ty,univ = - try - CicTypeChecker.type_of_aux' [] [] c univ - with CicTypeChecker.TypeCheckerFailure s as exn -> - debug_print (lazy (Printf.sprintf "Generated composite coercion:\n%s\n%s" - (CicPp.ppterm c) (Lazy.force s))); - raise exn - in - let cleaned_ty = - FreshNamesGenerator.clean_dummy_dependent_types c_ty - in - let obj = Cic.Constant ("xxxx",Some c,cleaned_ty,[],obj_attrs) in - obj,univ -;; - -(* removes from l the coercions that are in !coercions *) -let filter_duplicates l coercions = - List.filter ( - fun (src,_,tgt) -> - not (List.exists (fun (s,t,u) -> - CoercDb.eq_carr s src && - CoercDb.eq_carr t tgt) - coercions)) - l - -(* given a new coercion uri from src to tgt returns - * a list of (new coercion uri, coercion obj, universe graph) - *) -let close_coercion_graph src tgt uri = - (* check if the coercion already exists *) - let coercions = CoercDb.to_list () in - let todo_list = get_closure_coercions src tgt uri coercions in - let todo_list = filter_duplicates todo_list coercions in - let new_coercions = - List.map ( - fun (src, l , tgt) -> - match l with - | [] -> assert false - | he :: tl -> - let first_step = - Cic.Constant ("", - Some (CoercDb.term_of_carr (CoercDb.Uri he)), - Cic.Sort Cic.Prop, [], obj_attrs) - in - let o,_ = - List.fold_left (fun (o,univ) coer -> - match o with - | Cic.Constant (_,Some c,_,[],_) -> - generate_composite_closure c (CoercDb.term_of_carr (CoercDb.Uri - coer)) univ - | _ -> assert false - ) (first_step, CicUniv.empty_ugraph) tl - in - let name_src = CoercDb.name_of_carr src in - let name_tgt = CoercDb.name_of_carr tgt in - let name = name_tgt ^ "_of_" ^ name_src in - let buri = UriManager.buri_of_uri uri in - let c_uri = - UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") - in - let named_obj = - match o with - | Cic.Constant (_,bo,ty,vl,attrs) -> - Cic.Constant (name,bo,ty,vl,attrs) - | _ -> assert false - in - ((src,tgt,c_uri,named_obj)) - ) todo_list - in - new_coercions -;; - diff --git a/helm/ocaml/library/cicCoercion.mli b/helm/ocaml/library/cicCoercion.mli deleted file mode 100644 index c9eaf0aac..000000000 --- a/helm/ocaml/library/cicCoercion.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* This module implements the Coercions transitive closure *) - -val close_coercion_graph: - CoercDb.coerc_carr -> CoercDb.coerc_carr -> UriManager.uri -> - (CoercDb.coerc_carr * CoercDb.coerc_carr * UriManager.uri * Cic.obj) list - diff --git a/helm/ocaml/library/cicElim.ml b/helm/ocaml/library/cicElim.ml deleted file mode 100644 index fb3c0655c..000000000 --- a/helm/ocaml/library/cicElim.ml +++ /dev/null @@ -1,421 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -exception Elim_failure of string Lazy.t -exception Can_t_eliminate - -let debug_print = fun _ -> () -(*let debug_print s = prerr_endline (Lazy.force s) *) - -let counter = ref ~-1 ;; - -let fresh_binder () = Cic.Name "matita_dummy" -(* - incr counter; - Cic.Name ("e" ^ string_of_int !counter) *) - - (** verifies if a given inductive type occurs in a term in target position *) -let rec recursive uri typeno = function - | Cic.Prod (_, _, target) -> recursive uri typeno target - | Cic.MutInd (uri', typeno', []) - | Cic.Appl (Cic.MutInd (uri', typeno', []) :: _) -> - UriManager.eq uri uri' && typeno = typeno' - | _ -> false - - (** given a list of constructor types, return true if at least one of them is - * recursive, false otherwise *) -let recursive_type uri typeno constructors = - let rec aux = function - | Cic.Prod (_, src, tgt) -> recursive uri typeno src || aux tgt - | _ -> false - in - List.exists (fun (_, ty) -> aux ty) constructors - -let unfold_appl = function - | Cic.Appl ((Cic.Appl args) :: tl) -> Cic.Appl (args @ tl) - | t -> t - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> assert false - - (** build elimination principle part related to a single constructor - * @param paramsno number of Prod to ignore in this constructor (i.e. number of - * inductive parameters) - * @param dependent true if we are in the dependent case (i.e. sort <> Prop) *) -let rec delta (uri, typeno) dependent paramsno consno t p args = - match t with - | Cic.MutInd (uri', typeno', []) when - UriManager.eq uri uri' && typeno = typeno' -> - if dependent then - (match args with - | [] -> assert false - | [arg] -> unfold_appl (Cic.Appl [p; arg]) - | _ -> unfold_appl (Cic.Appl [p; unfold_appl (Cic.Appl args)])) - else - p - | Cic.Appl (Cic.MutInd (uri', typeno', []) :: tl) when - UriManager.eq uri uri' && typeno = typeno' -> - let (lparams, rparams) = split tl paramsno in - if dependent then - (match args with - | [] -> assert false - | [arg] -> unfold_appl (Cic.Appl (p :: rparams @ [arg])) - | _ -> - unfold_appl (Cic.Appl (p :: - rparams @ [unfold_appl (Cic.Appl args)]))) - else (* non dependent *) - (match rparams with - | [] -> p - | _ -> Cic.Appl (p :: rparams)) - | Cic.Prod (binder, src, tgt) -> - if recursive uri typeno src then - let args = List.map (CicSubstitution.lift 2) args in - let phi = - let src = CicSubstitution.lift 1 src in - delta (uri, typeno) dependent paramsno consno src - (CicSubstitution.lift 1 p) [Cic.Rel 1] - in - let tgt = CicSubstitution.lift 1 tgt in - Cic.Prod (fresh_binder (), src, - Cic.Prod (Cic.Anonymous, phi, - delta (uri, typeno) dependent paramsno consno tgt - (CicSubstitution.lift 2 p) (args @ [Cic.Rel 2]))) - else (* non recursive *) - let args = List.map (CicSubstitution.lift 1) args in - Cic.Prod (fresh_binder (), src, - delta (uri, typeno) dependent paramsno consno tgt - (CicSubstitution.lift 1 p) (args @ [Cic.Rel 1])) - | _ -> assert false - -let rec strip_left_params consno leftno = function - | t when leftno = 0 -> t (* no need to lift, the term is (hopefully) closed *) - | Cic.Prod (_, _, tgt) (* when leftno > 0 *) -> - (* after stripping the parameters we lift of consno. consno is 1 based so, - * the first constructor will be lifted by 1 (for P), the second by 2 (1 - * for P and 1 for the 1st constructor), and so on *) - if leftno = 1 then - CicSubstitution.lift consno tgt - else - strip_left_params consno (leftno - 1) tgt - | _ -> assert false - -let delta (ury, typeno) dependent paramsno consno t p args = - let t = strip_left_params consno paramsno t in - delta (ury, typeno) dependent paramsno consno t p args - -let rec add_params binder indno ty eliminator = - if indno = 0 then - eliminator - else - match ty with - | Cic.Prod (name, src, tgt) -> - let name = - match name with - Cic.Name _ -> name - | Cic.Anonymous -> fresh_binder () - in - binder name src (add_params binder (indno - 1) tgt eliminator) - | _ -> assert false - -let rec mk_rels consno = function - | 0 -> [] - | n -> Cic.Rel (n+consno) :: mk_rels consno (n-1) - -let rec strip_pi = function - | Cic.Prod (_, _, tgt) -> strip_pi tgt - | t -> t - -let rec count_pi = function - | Cic.Prod (_, _, tgt) -> count_pi tgt + 1 - | t -> 0 - -let rec type_of_p sort dependent leftno indty = function - | Cic.Prod (n, src, tgt) when leftno = 0 -> - let n = - if dependent then - match n with - Cic.Name _ -> n - | Cic.Anonymous -> fresh_binder () - else - n - in - Cic.Prod (n, src, type_of_p sort dependent leftno indty tgt) - | Cic.Prod (_, _, tgt) -> type_of_p sort dependent (leftno - 1) indty tgt - | t -> - if dependent then - Cic.Prod (Cic.Anonymous, indty, Cic.Sort sort) - else - Cic.Sort sort - -let rec add_right_pi dependent strip liftno liftfrom rightno indty = function - | Cic.Prod (_, src, tgt) when strip = 0 -> - Cic.Prod (fresh_binder (), - CicSubstitution.lift_from liftfrom liftno src, - add_right_pi dependent strip liftno (liftfrom + 1) rightno indty tgt) - | Cic.Prod (_, _, tgt) -> - add_right_pi dependent (strip - 1) liftno liftfrom rightno indty tgt - | t -> - if dependent then - Cic.Prod (fresh_binder (), - CicSubstitution.lift_from (rightno + 1) liftno indty, - Cic.Appl (Cic.Rel (1 + liftno + rightno) :: mk_rels 0 (rightno + 1))) - else - Cic.Prod (Cic.Anonymous, - CicSubstitution.lift_from (rightno + 1) liftno indty, - if rightno = 0 then - Cic.Rel (1 + liftno + rightno) - else - Cic.Appl (Cic.Rel (1 + liftno + rightno) :: mk_rels 1 rightno)) - -let rec add_right_lambda dependent strip liftno liftfrom rightno indty case = -function - | Cic.Prod (_, src, tgt) when strip = 0 -> - Cic.Lambda (fresh_binder (), - CicSubstitution.lift_from liftfrom liftno src, - add_right_lambda dependent strip liftno (liftfrom + 1) rightno indty - case tgt) - | Cic.Prod (_, _, tgt) -> - add_right_lambda true (strip - 1) liftno liftfrom rightno indty - case tgt - | t -> - Cic.Lambda (fresh_binder (), - CicSubstitution.lift_from (rightno + 1) liftno indty, case) - -let rec branch (uri, typeno) insource paramsno t fix head args = - match t with - | Cic.MutInd (uri', typeno', []) when - UriManager.eq uri uri' && typeno = typeno' -> - if insource then - (match args with - | [arg] -> Cic.Appl (fix :: args) - | _ -> Cic.Appl (head :: [Cic.Appl args])) - else - (match args with - | [] -> head - | _ -> Cic.Appl (head :: args)) - | Cic.Appl (Cic.MutInd (uri', typeno', []) :: tl) when - UriManager.eq uri uri' && typeno = typeno' -> - if insource then - let (lparams, rparams) = split tl paramsno in - match args with - | [arg] -> Cic.Appl (fix :: rparams @ args) - | _ -> Cic.Appl (fix :: rparams @ [Cic.Appl args]) - else - (match args with - | [] -> head - | _ -> Cic.Appl (head :: args)) - | Cic.Prod (binder, src, tgt) -> - if recursive uri typeno src then - let args = List.map (CicSubstitution.lift 1) args in - let phi = - let fix = CicSubstitution.lift 1 fix in - let src = CicSubstitution.lift 1 src in - branch (uri, typeno) true paramsno src fix head [Cic.Rel 1] - in - Cic.Lambda (fresh_binder (), src, - branch (uri, typeno) insource paramsno tgt - (CicSubstitution.lift 1 fix) (CicSubstitution.lift 1 head) - (args @ [Cic.Rel 1; phi])) - else (* non recursive *) - let args = List.map (CicSubstitution.lift 1) args in - Cic.Lambda (fresh_binder (), src, - branch (uri, typeno) insource paramsno tgt - (CicSubstitution.lift 1 fix) (CicSubstitution.lift 1 head) - (args @ [Cic.Rel 1])) - | _ -> assert false - -let branch (uri, typeno) insource liftno paramsno t fix head args = - let t = strip_left_params liftno paramsno t in - branch (uri, typeno) insource paramsno t fix head args - -let elim_of ~sort uri typeno = - counter := ~-1; - let (obj, univ) = (CicEnvironment.get_obj CicUniv.empty_ugraph uri) in - match obj with - | Cic.InductiveDefinition (indTypes, params, leftno, _) -> - let (name, inductive, ty, constructors) = - try - List.nth indTypes typeno - with Failure _ -> assert false - in - let paramsno = count_pi ty in (* number of (left or right) parameters *) - let rightno = paramsno - leftno in - let dependent = (strip_pi ty <> Cic.Sort Cic.Prop) in - let head = - match strip_pi ty with - Cic.Sort s -> s - | _ -> assert false - in - let conslen = List.length constructors in - let consno = ref (conslen + 1) in - if - not - (CicTypeChecker.check_allowed_sort_elimination uri typeno head sort) - then - raise Can_t_eliminate; - let indty = - let indty = Cic.MutInd (uri, typeno, []) in - if paramsno = 0 then - indty - else - Cic.Appl (indty :: mk_rels 0 paramsno) - in - let mk_constructor consno = - let constructor = Cic.MutConstruct (uri, typeno, consno, []) in - if leftno = 0 then - constructor - else - Cic.Appl (constructor :: mk_rels consno leftno) - in - let p_ty = type_of_p sort dependent leftno indty ty in - let final_ty = - add_right_pi dependent leftno (conslen + 1) 1 rightno indty ty - in - let eliminator_type = - let cic = - Cic.Prod (Cic.Name "P", p_ty, - (List.fold_right - (fun (_, constructor) acc -> - decr consno; - let p = Cic.Rel !consno in - Cic.Prod (Cic.Anonymous, - (delta (uri, typeno) dependent leftno !consno - constructor p [mk_constructor !consno]), - acc)) - constructors final_ty)) - in - add_params (fun b s t -> Cic.Prod (b, s, t)) leftno ty cic - in - let consno = ref (conslen + 1) in - let eliminator_body = - let fix = Cic.Rel (rightno + 2) in - let is_recursive = recursive_type uri typeno constructors in - let recshift = if is_recursive then 1 else 0 in - let (_, branches) = - List.fold_right - (fun (_, ty) (shift, branches) -> - let head = Cic.Rel (rightno + shift + 1 + recshift) in - let b = - branch (uri, typeno) false - (rightno + conslen + 2 + recshift) leftno ty fix head [] - in - (shift + 1, b :: branches)) - constructors (1, []) - in - let shiftno = conslen + rightno + 2 + recshift in - let outtype = - if dependent then - Cic.Rel shiftno - else - let head = - if rightno = 0 then - CicSubstitution.lift 1 (Cic.Rel shiftno) - else - Cic.Appl - ((CicSubstitution.lift (rightno + 1) (Cic.Rel shiftno)) :: - mk_rels 1 rightno) - in - add_right_lambda true leftno shiftno 1 rightno indty head ty - in - let mutcase = - Cic.MutCase (uri, typeno, outtype, Cic.Rel 1, branches) - in - let body = - if is_recursive then - let fixfun = - add_right_lambda dependent leftno (conslen + 2) 1 rightno - indty mutcase ty - in - (* rightno is the decreasing argument, i.e. the argument of - * inductive type *) - Cic.Fix (0, ["f", rightno, final_ty, fixfun]) - else - add_right_lambda dependent leftno (conslen + 1) 1 rightno indty - mutcase ty - in - let cic = - Cic.Lambda (Cic.Name "P", p_ty, - (List.fold_right - (fun (_, constructor) acc -> - decr consno; - let p = Cic.Rel !consno in - Cic.Lambda (fresh_binder (), - (delta (uri, typeno) dependent leftno !consno - constructor p [mk_constructor !consno]), - acc)) - constructors body)) - in - add_params (fun b s t -> Cic.Lambda (b, s, t)) leftno ty cic - in -(* -debug_print (lazy (CicPp.ppterm eliminator_type)); -debug_print (lazy (CicPp.ppterm eliminator_body)); -*) - let eliminator_type = - FreshNamesGenerator.mk_fresh_names [] [] [] eliminator_type in - let eliminator_body = - FreshNamesGenerator.mk_fresh_names [] [] [] eliminator_body in -(* -debug_print (lazy (CicPp.ppterm eliminator_type)); -debug_print (lazy (CicPp.ppterm eliminator_body)); -*) - let (computed_type, ugraph) = - try - CicTypeChecker.type_of_aux' [] [] eliminator_body CicUniv.empty_ugraph - with CicTypeChecker.TypeCheckerFailure msg -> - raise (Elim_failure (lazy (sprintf - "type checker failure while type checking:\n%s\nerror:\n%s" - (CicPp.ppterm eliminator_body) (Lazy.force msg)))) - in - if not (fst (CicReduction.are_convertible [] - eliminator_type computed_type ugraph)) - then - raise (Failure (sprintf - "internal error: type mismatch on eliminator type\n%s\n%s" - (CicPp.ppterm eliminator_type) (CicPp.ppterm computed_type))); - let suffix = - match sort with - | Cic.Prop -> "_ind" - | Cic.Set -> "_rec" - | Cic.Type _ -> "_rect" - | _ -> assert false - in - let name = UriManager.name_of_uri uri ^ suffix in - let buri = UriManager.buri_of_uri uri in - let uri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in - let obj_attrs = [`Class (`Elim sort); `Generated] in - uri, - Cic.Constant (name, Some eliminator_body, eliminator_type, [], obj_attrs) - | _ -> - failwith (sprintf "not an inductive definition (%s)" - (UriManager.string_of_uri uri)) - diff --git a/helm/ocaml/library/cicElim.mli b/helm/ocaml/library/cicElim.mli deleted file mode 100644 index f1f84c92e..000000000 --- a/helm/ocaml/library/cicElim.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - - (** can't build the required elimination principle (e.g. elimination from Prop - * to Set *) -exception Can_t_eliminate - - (** internal error while generating elimination principle *) -exception Elim_failure of string Lazy.t - -(** @param sort target sort -* @param uri inductive type uri -* @param typeno inductive type number -* @raise Failure -* @raise Can_t_eliminate -* @return Cic constant corresponding to the required elimination principle -* and its uri -*) -val elim_of: sort:Cic.sort -> UriManager.uri -> int -> UriManager.uri * Cic.obj diff --git a/helm/ocaml/library/cicRecord.ml b/helm/ocaml/library/cicRecord.ml deleted file mode 100644 index 775292ccb..000000000 --- a/helm/ocaml/library/cicRecord.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let rec_ty uri leftno = - let rec_ty = Cic.MutInd (uri,0,[]) in - if leftno = 0 then rec_ty else - Cic.Appl (rec_ty :: (CicUtil.mk_rels leftno 0)) - -let generate_one_proj uri params paramsno fields t i = - let mk_lambdas l start = - List.fold_right (fun (name,ty) acc -> - Cic.Lambda (Cic.Name name,ty,acc)) l start in - let recty = rec_ty uri paramsno in - let outtype = Cic.Lambda (Cic.Name "w'", CicSubstitution.lift 1 recty, t) in - (mk_lambdas params - (Cic.Lambda (Cic.Name "w", recty, - Cic.MutCase (uri,0,outtype, Cic.Rel 1, - [mk_lambdas fields (Cic.Rel i)])))) - -let projections_of uri field_names = - let buri = UriManager.buri_of_uri uri in - let obj,ugraph = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri in - match obj with - Cic.InductiveDefinition ([_,_,sort,[_,ty]],params,paramsno,_) -> - assert (params = []); (* general case not implemented *) - let leftparams,ty = - let rec aux = - function - 0,ty -> [],ty - | n,Cic.Prod (Cic.Name name,s,t) -> - let leftparams,ty = aux (n - 1,t) in - (name,s)::leftparams,ty - | _,_ -> assert false - in - aux (paramsno,ty) - in - let fields = - let rec aux = - function - Cic.MutInd _, [] - | Cic.Appl _, [] -> [] - | Cic.Prod (_,s,t), name::tl -> (name,s)::aux (t,tl) - | _,_ -> assert false - in - aux ((CicSubstitution.lift 1 ty),field_names) - in - let rec aux i = - function - Cic.MutInd _, [] - | Cic.Appl _, [] -> [] - | Cic.Prod (_,s,t), name::tl -> - let p = generate_one_proj uri leftparams paramsno fields s i in - let puri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in - (puri,name,p) :: - aux (i - 1) - (CicSubstitution.subst - (Cic.Appl - (Cic.Const (puri,[]) :: - CicUtil.mk_rels paramsno 2 @ [Cic.Rel 1]) - ) t, tl) - | _,_ -> assert false - in - aux (List.length fields) (CicSubstitution.lift 2 ty,field_names) - | _ -> assert false diff --git a/helm/ocaml/library/cicRecord.mli b/helm/ocaml/library/cicRecord.mli deleted file mode 100644 index b966f317c..000000000 --- a/helm/ocaml/library/cicRecord.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** projections_of [uri] returns uri * name * term *) -val projections_of: - UriManager.uri -> string list -> (UriManager.uri * string * Cic.term) list diff --git a/helm/ocaml/library/coercDb.ml b/helm/ocaml/library/coercDb.ml deleted file mode 100644 index 8e2c62f31..000000000 --- a/helm/ocaml/library/coercDb.ml +++ /dev/null @@ -1,96 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type coerc_carr = Uri of UriManager.uri | Sort of Cic.sort | Term of Cic.term -exception EqCarrNotImplemented of string Lazy.t -exception EqCarrOnNonMetaClosed - -let db = ref [] - -let coerc_carr_of_term t = - try - Uri (CicUtil.uri_of_term t) - with Invalid_argument _ -> - match t with - | Cic.Sort s -> Sort s - | Cic.Appl ((Cic.Const (uri, _))::_) - | Cic.Appl ((Cic.MutInd (uri, _, _))::_) - | Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_) -> Uri uri - | t -> Term t -;; - -let name_of_carr = function - | Uri u -> UriManager.name_of_uri u - | Sort s -> CicPp.ppsort s - | Term (Cic.Appl ((Cic.Const (uri, _))::_)) - | Term (Cic.Appl ((Cic.MutInd (uri, _, _))::_)) - | Term (Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_)) -> - UriManager.name_of_uri uri - | Term t -> (* CicPp.ppterm t *) assert false - -let eq_carr src tgt = - match src, tgt with - | Uri src, Uri tgt -> UriManager.eq src tgt - | Sort (Cic.Type _), Sort (Cic.Type _) -> true - | Sort src, Sort tgt when src = tgt -> true - | Term t1, Term t2 -> - if CicUtil.is_meta_closed t1 && CicUtil.is_meta_closed t2 then - raise - (EqCarrNotImplemented - (lazy ("Unsupported carr for coercions: " ^ - CicPp.ppterm t1 ^ " or " ^ CicPp.ppterm t2))) - else raise EqCarrOnNonMetaClosed - | _, _ -> false - -let to_list () = - !db - -let add_coercion c = - db := c :: !db - -let remove_coercion p = - db := List.filter (fun u -> not(p u)) !db - -let find_coercion f = - List.map (fun (_,_,x) -> x) (List.filter (fun (s,t,_) -> f (s,t)) !db) - -let is_a_coercion u = - List.exists (fun (_,_,x) -> UriManager.eq x u) !db - -let get_carr uri = - try - let src, tgt, _ = List.find (fun (_,_,x) -> UriManager.eq x uri) !db in - src, tgt - with Not_found -> assert false (* uri must be a coercion *) - -let term_of_carr = function - | Uri u -> CicUtil.term_of_uri u - | Sort s -> Cic.Sort s - | Term _ -> assert false - - - diff --git a/helm/ocaml/library/coercDb.mli b/helm/ocaml/library/coercDb.mli deleted file mode 100644 index 9e8bf5e9c..000000000 --- a/helm/ocaml/library/coercDb.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* 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/. - *) - - - (** THIS MODULE SHOULD BE USED ONLY BY CoercGraph/CicCoercion/librarySync - * - * and may be merged with CicCoercion... - * - * **) - - - (** XXX WARNING: non-reentrant *) -type coerc_carr = Uri of UriManager.uri | Sort of Cic.sort | Term of Cic.term -exception EqCarrNotImplemented of string Lazy.t -exception EqCarrOnNonMetaClosed -val eq_carr: coerc_carr -> coerc_carr -> bool -val coerc_carr_of_term: Cic.term -> coerc_carr -val name_of_carr: coerc_carr -> string - -val to_list: - unit -> - (coerc_carr * coerc_carr * UriManager.uri) list - -val add_coercion: - coerc_carr * coerc_carr * UriManager.uri -> unit - -val remove_coercion: - (coerc_carr * coerc_carr * UriManager.uri -> bool) -> unit - -val find_coercion: - (coerc_carr * coerc_carr -> bool) -> UriManager.uri list - -val is_a_coercion: UriManager.uri -> bool -val get_carr: UriManager.uri -> coerc_carr * coerc_carr - -val term_of_carr: coerc_carr -> Cic.term diff --git a/helm/ocaml/library/coercGraph.ml b/helm/ocaml/library/coercGraph.ml deleted file mode 100644 index cd958a8f6..000000000 --- a/helm/ocaml/library/coercGraph.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open Printf;; - -type coercion_search_result = - | SomeCoercion of Cic.term - | NoCoercion - | NotMetaClosed - | NotHandled of string Lazy.t - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) else () - -(* searches a coercion fron src to tgt in the !coercions list *) -let look_for_coercion src tgt = - try - let l = - CoercDb.find_coercion - (fun (s,t) -> CoercDb.eq_carr s src && CoercDb.eq_carr t tgt) - in - match l with - | [] -> - debug_print - (lazy - (sprintf ":-( coercion non trovata da %s a %s" - (CoercDb.name_of_carr src) - (CoercDb.name_of_carr tgt))); - NoCoercion - | [u] -> - debug_print (lazy ( - sprintf ":-) TROVATA 1 coercion da %s a %s: %s" - (CoercDb.name_of_carr src) - (CoercDb.name_of_carr tgt) - (UriManager.name_of_uri u))); - SomeCoercion (CicUtil.term_of_uri u) - | u::_ -> - debug_print (lazy ( - sprintf ":-/ TROVATE %d coercion(s) da %s a %s, prendo la prima: %s" - (List.length l) - (CoercDb.name_of_carr src) - (CoercDb.name_of_carr tgt) - (UriManager.name_of_uri u))); - SomeCoercion (CicUtil.term_of_uri u) - with - | CoercDb.EqCarrNotImplemented s -> NotHandled s - | CoercDb.EqCarrOnNonMetaClosed -> NotMetaClosed -;; - -let look_for_coercion src tgt = - let src_uri = CoercDb.coerc_carr_of_term src in - let tgt_uri = CoercDb.coerc_carr_of_term tgt in - look_for_coercion src_uri tgt_uri - -let is_a_coercion t = - try - let uri = CicUtil.uri_of_term t in - CoercDb.is_a_coercion uri - with Invalid_argument _ -> false - -let source_of t = - try - let uri = CicUtil.uri_of_term t in - CoercDb.term_of_carr (fst (CoercDb.get_carr uri)) - with Invalid_argument _ -> assert false (* t must be a coercion *) - -let target_of t = - try - let uri = CicUtil.uri_of_term t in - CoercDb.term_of_carr (snd (CoercDb.get_carr uri)) - with Invalid_argument _ -> assert false (* t must be a coercion *) - -(* EOF *) diff --git a/helm/ocaml/library/coercGraph.mli b/helm/ocaml/library/coercGraph.mli deleted file mode 100644 index 1923a964a..000000000 --- a/helm/ocaml/library/coercGraph.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* 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/. - *) - -(* This module implements the Query interface to the Coercion Graph *) - -type coercion_search_result = - | SomeCoercion of Cic.term - | NoCoercion - | NotMetaClosed - | NotHandled of string Lazy.t - -val look_for_coercion : - Cic.term -> Cic.term -> coercion_search_result - -val is_a_coercion: Cic.term -> bool -val source_of: Cic.term -> Cic.term -val target_of: Cic.term -> Cic.term - diff --git a/helm/ocaml/library/libraryClean.ml b/helm/ocaml/library/libraryClean.ml deleted file mode 100644 index 6f72ff495..000000000 --- a/helm/ocaml/library/libraryClean.ml +++ /dev/null @@ -1,238 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let debug = false -let debug_prerr = if debug then prerr_endline else ignore - -module HGT = Http_getter_types;; -module HG = Http_getter;; -module UM = UriManager;; - -let cache_of_processed_baseuri = Hashtbl.create 1024 - -let one_step_depend suri = - let buri = - try - UM.buri_of_uri (UM.uri_of_string suri) - with UM.IllFormedUri _ -> suri - in - if Hashtbl.mem cache_of_processed_baseuri buri then - [] - else - begin - Hashtbl.add cache_of_processed_baseuri buri true; - let query = - let buri = buri ^ "/" in - let buri = HMysql.escape buri in - let obj_tbl = MetadataTypes.obj_tbl () in - sprintf - ("SELECT source, h_occurrence FROM %s WHERE " ^^ - "h_occurrence REGEXP '^%s[^/]*$'") - obj_tbl buri - in - try - let rc = HMysql.exec (LibraryDb.instance ()) query in - let l = ref [] in - HMysql.iter rc ( - fun row -> - match row.(0), row.(1) with - | Some uri, Some occ when Filename.dirname occ = buri -> - l := uri :: !l - | _ -> ()); - let l = List.sort Pervasives.compare !l in - HExtlib.list_uniq l - with - exn -> raise exn (* no errors should be accepted *) - end - -let safe_buri_of_suri suri = - try - UM.buri_of_uri (UM.uri_of_string suri) - with - UM.IllFormedUri _ -> suri - -let close_uri_list uri_to_remove = - (* to remove an uri you have to remove the whole script *) - let buri_to_remove = - HExtlib.list_uniq - (List.fast_sort Pervasives.compare - (List.map safe_buri_of_suri uri_to_remove)) - in - (* cleand the already visided baseuris *) - let buri_to_remove = - List.filter - (fun buri -> - if Hashtbl.mem cache_of_processed_baseuri buri then false - else true) - buri_to_remove - in - (* now calculate the list of objects that belong to these baseuris *) - let uri_to_remove = - try - List.fold_left - (fun acc buri -> - let inhabitants = HG.ls (buri ^ "/") in - let inhabitants = List.filter - (function HGT.Ls_object _ -> true | _ -> false) - inhabitants - in - let inhabitants = List.map - (function - | HGT.Ls_object e -> buri ^ "/" ^ e.HGT.uri - | _ -> assert false) - inhabitants - in - inhabitants @ acc) - [] buri_to_remove - with HGT.Invalid_URI u -> - HLog.error ("We were listing an invalid buri: " ^ u); - exit 1 - in - (* now we want the list of all uri that depend on them *) - let depend = - List.fold_left - (fun acc u -> one_step_depend u @ acc) [] uri_to_remove - in - let depend = - HExtlib.list_uniq (List.fast_sort Pervasives.compare depend) - in - uri_to_remove, depend - -let rec close_db uris next = - match next with - | [] -> uris - | l -> let uris, next = close_uri_list l in close_db uris next @ uris - -let cleaned_no = ref 0;; - - (** TODO repellent code ... *) -let moo_root_dir = lazy ( - let url = - List.assoc "cic:/matita/" - (List.map - (fun pair -> - match - Str.split (Str.regexp "[ \t\r\n]+") (HExtlib.trim_blanks pair) - with - | a::b::_ -> a, b - | _ -> assert false) - (Helm_registry.get_list Helm_registry.string "getter.prefix")) - in - String.sub url 7 (String.length url - 7) (* remove heading "file:///" *) -) - -let close_nodb ~basedir buris = - let rev_deps = Hashtbl.create 97 in - let all_metadata = - HExtlib.find ~test:(fun name -> Filename.check_suffix name ".metadata") - (Lazy.force moo_root_dir) - in - List.iter - (fun path -> - let metadata = LibraryNoDb.load_metadata ~fname:path in - let baseuri_of_current_metadata = - let dirname = Filename.dirname path in - let basedirlen = String.length basedir in - assert (String.sub dirname 0 basedirlen = basedir); - "cic:" ^ - String.sub dirname basedirlen (String.length dirname - basedirlen) ^ - Filename.basename path - in - let deps = - HExtlib.filter_map - (function LibraryNoDb.Dependency buri -> Some buri) - metadata - in - List.iter - (fun buri -> Hashtbl.add rev_deps buri baseuri_of_current_metadata) deps) - all_metadata; - let buris_to_remove = - HExtlib.list_uniq - (List.fast_sort Pervasives.compare - (List.flatten (List.map (Hashtbl.find_all rev_deps) buris))) - in - let objects_to_remove = - let objs_of_buri buri = - HExtlib.filter_map - (function - | Http_getter_types.Ls_object o -> - Some (buri ^ "/" ^ o.Http_getter_types.uri) - | _ -> None) - (Http_getter.ls buri) - in - List.flatten (List.map objs_of_buri (buris @ buris_to_remove)) - in - objects_to_remove - -let clean_baseuris ?(verbose=true) ~basedir buris = - Hashtbl.clear cache_of_processed_baseuri; - let buris = List.map Http_getter_misc.strip_trailing_slash buris in - debug_prerr "clean_baseuris called on:"; - if debug then - List.iter debug_prerr buris; - let l = - if Helm_registry.get_bool "db.nodb" then - close_nodb ~basedir buris - else - close_db [] buris - in - let l = HExtlib.list_uniq (List.fast_sort Pervasives.compare l) in - let l = List.map UriManager.uri_of_string l in - debug_prerr "clean_baseuri will remove:"; - if debug then - List.iter (fun u -> debug_prerr (UriManager.string_of_uri u)) l; - List.iter - (fun buri -> - HExtlib.safe_remove (LibraryMisc.obj_file_of_baseuri basedir buri); - HExtlib.safe_remove (LibraryMisc.metadata_file_of_baseuri basedir buri); - HExtlib.safe_remove (LibraryMisc.lexicon_file_of_baseuri basedir buri)) - (HExtlib.list_uniq (List.fast_sort Pervasives.compare - (List.map (UriManager.buri_of_uri) l))); - List.iter - (let last_baseuri = ref "" in - fun uri -> - let buri = UriManager.buri_of_uri uri in - if buri <> !last_baseuri then - begin - HLog.message ("Removing: " ^ buri ^ "/*"); - last_baseuri := buri - end; - LibrarySync.remove_obj uri - ) l; - cleaned_no := !cleaned_no + List.length l; - if !cleaned_no > 30 then - begin - cleaned_no := 0; - List.iter - (function table -> - ignore (HMysql.exec (LibraryDb.instance ()) ("OPTIMIZE TABLE " ^ table))) - [MetadataTypes.name_tbl (); MetadataTypes.rel_tbl (); - MetadataTypes.sort_tbl (); MetadataTypes.obj_tbl(); - MetadataTypes.count_tbl()] - end diff --git a/helm/ocaml/library/libraryClean.mli b/helm/ocaml/library/libraryClean.mli deleted file mode 100644 index deca8f4a7..000000000 --- a/helm/ocaml/library/libraryClean.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val clean_baseuris : ?verbose:bool -> basedir:string -> string list -> unit diff --git a/helm/ocaml/library/libraryDb.ml b/helm/ocaml/library/libraryDb.ml deleted file mode 100644 index 8c11f591f..000000000 --- a/helm/ocaml/library/libraryDb.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf ;; - -let instance = - let dbd = lazy ( - HMysql.quick_connect - ~host:(Helm_registry.get "db.host") - ~user:(Helm_registry.get "db.user") - ~database:(Helm_registry.get "db.database") - ()) - in - fun () -> Lazy.force dbd - - -let xpointer_RE = Pcre.regexp "#.*$" -let file_scheme_RE = Pcre.regexp "^file://" - -let clean_owner_environment () = - let dbd = instance () in - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - let count_tbl = MetadataTypes.count_tbl () in - let tbls = [ - (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; - (name_tbl,`ObjectName) ; (count_tbl,`Count) ] - in - let statements = - (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls) - in - let owned_uris = - try - MetadataDb.clean ~dbd - with Mysql.Error _ as exn -> - match HMysql.errno dbd with - | Mysql.No_such_table -> [] - | _ -> raise exn - in - List.iter - (fun uri -> - let uri = Pcre.replace ~rex:xpointer_RE ~templ:"" uri in - List.iter - (fun suffix -> - try - HExtlib.safe_remove (Http_getter.resolve (uri ^ suffix)) - with Http_getter_types.Key_not_found _ -> ()) - [""; ".body"; ".types"]) - owned_uris; - List.iter (fun statement -> - try - ignore (HMysql.exec dbd statement) - with Mysql.Error _ as exn -> - match HMysql.errno dbd with - | Mysql.Bad_table_error - | Mysql.No_such_index | Mysql.No_such_table -> () - | _ -> raise exn - ) statements; -;; - -let create_owner_environment () = - let dbd = instance () in - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - let count_tbl = MetadataTypes.count_tbl () in - let tbls = [ - (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; - (name_tbl,`ObjectName) ; (count_tbl,`Count) ] - in - let statements = - (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls) - in - List.iter (fun statement -> - try - ignore (HMysql.exec dbd statement) - with - exn -> - let status = HMysql.status dbd in - match status with - | Mysql.StatusError Mysql.Table_exists_error -> () - | Mysql.StatusError Mysql.Dup_keyname -> () - | Mysql.StatusError _ -> raise exn - | _ -> () - ) statements -;; - -(* removes uri from the ownerized tables, and returns the list of other objects - * (theyr uris) that ref the one removed. - * AFAIK there is no need to return it, since the MatitaTypes.staus should - * contain all defined objects. but to double check we do not garbage the - * metadata... - *) -let remove_uri uri = - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - (*let conclno_tbl = MetadataTypes.conclno_tbl () in - let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in*) - let count_tbl = MetadataTypes.count_tbl () in - - let dbd = instance () in - let suri = UriManager.string_of_uri uri in - let query table suri = sprintf - "DELETE FROM %s WHERE source LIKE '%s%%'" table (HMysql.escape suri) - in - List.iter (fun t -> - try - ignore (HMysql.exec dbd (query t suri)) - with - exn -> raise exn (* no errors should be accepted *) - ) - [obj_tbl;sort_tbl;rel_tbl;name_tbl;(*conclno_tbl;conclno_hyp_tbl*)count_tbl]; - (* and now the debug job *) - let dbg_q = - sprintf "SELECT source FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl - (HMysql.escape suri) - in - try - let rc = HMysql.exec dbd dbg_q in - let l = ref [] in - HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); - let l = List.sort Pervasives.compare !l in - HExtlib.list_uniq l - with - exn -> raise exn (* no errors should be accepted *) - -let xpointers_of_ind uri = - let dbd = instance () in - let name_tbl = MetadataTypes.name_tbl () in - let query = sprintf - "SELECT source FROM %s WHERE source LIKE '%s#xpointer%%'" name_tbl - (HMysql.escape (UriManager.string_of_uri uri)) - in - let rc = HMysql.exec dbd query in - let l = ref [] in - HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); - List.map UriManager.uri_of_string !l - diff --git a/helm/ocaml/library/libraryDb.mli b/helm/ocaml/library/libraryDb.mli deleted file mode 100644 index 39aa7c079..000000000 --- a/helm/ocaml/library/libraryDb.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val instance: unit -> HMysql.dbd - -val create_owner_environment: unit -> unit -val clean_owner_environment: unit -> unit - -(* returns a list of uri thet must be removed sice they reference uri, - * but this is used only for debugging purposes *) -val remove_uri: UriManager.uri -> string list -val xpointers_of_ind: UriManager.uri -> UriManager.uri list diff --git a/helm/ocaml/library/libraryMisc.ml b/helm/ocaml/library/libraryMisc.ml deleted file mode 100644 index 3f1931e42..000000000 --- a/helm/ocaml/library/libraryMisc.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let obj_file_of_baseuri ~basedir ~baseuri = - let path = basedir ^ "/xml" ^ Pcre.replace ~pat:"^cic:" ~templ:"" baseuri in - path ^ ".moo" - -let lexicon_file_of_baseuri ~basedir ~baseuri = - let path = basedir ^ "/xml" ^ Pcre.replace ~pat:"^cic:" ~templ:"" baseuri in - path ^ ".lexicon" - -let metadata_file_of_baseuri ~basedir ~baseuri = - let path = basedir ^ "/xml" ^ Pcre.replace ~pat:"^cic:" ~templ:"" baseuri in - path ^ ".metadata" diff --git a/helm/ocaml/library/libraryMisc.mli b/helm/ocaml/library/libraryMisc.mli deleted file mode 100644 index e4d07faf7..000000000 --- a/helm/ocaml/library/libraryMisc.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -val obj_file_of_baseuri: basedir:string -> baseuri:string -> string -val lexicon_file_of_baseuri: basedir:string -> baseuri:string -> string -val metadata_file_of_baseuri: basedir:string -> baseuri:string -> string diff --git a/helm/ocaml/library/libraryNoDb.ml b/helm/ocaml/library/libraryNoDb.ml deleted file mode 100644 index 9ac42a5ea..000000000 --- a/helm/ocaml/library/libraryNoDb.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -exception Checksum_failure of string -exception Corrupt_metadata of string -exception Version_mismatch of string - -let magic = 1 -let format_name = "metadata" - -type metadata = - | Dependency of string (* baseuri without trailing slash *) - -let eq_metadata (m1:metadata) (m2:metadata) = m1 = m2 - -let save_metadata_to_file ~fname metadata = - HMarshal.save ~fmt:format_name ~version:magic ~fname metadata - -let load_metadata_from_file ~fname = - let raw = HMarshal.load ~fmt:format_name ~version:magic ~fname in - (raw: metadata list) - -let save_metadata ~fname metadata = save_metadata_to_file ~fname metadata -let load_metadata ~fname = load_metadata_from_file ~fname - diff --git a/helm/ocaml/library/libraryNoDb.mli b/helm/ocaml/library/libraryNoDb.mli deleted file mode 100644 index 1521f456f..000000000 --- a/helm/ocaml/library/libraryNoDb.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* TODO the strings below should be UriManager.uri, but UriManager ATM does not - * support their format *) -type metadata = - | Dependency of string (* baseuri without trailing slash *) - -val eq_metadata: metadata -> metadata -> bool - -val save_metadata: fname:string -> metadata list -> unit -val load_metadata: fname:string -> metadata list - diff --git a/helm/ocaml/library/librarySync.ml b/helm/ocaml/library/librarySync.ml deleted file mode 100644 index 7363697d5..000000000 --- a/helm/ocaml/library/librarySync.ml +++ /dev/null @@ -1,427 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception AlreadyDefined of UriManager.uri - -let auxiliary_lemmas_hashtbl = UriManager.UriHashtbl.create 29 - -(* uri |--> (derived_coercions_in_the_coercion_DB, derived_coercions_in_lib) - * - * in case of remove_coercion uri, the first component is removed from the - * coercion DB, while the second is passed to remove_obj (and is not [] only if - * add_coercion is called with add_composites - * *) -let coercion_hashtbl = UriManager.UriHashtbl.create 3 - -let rec merge_coercions = - let module C = Cic in - let aux = (fun (u,t) -> u,merge_coercions t) in - function - C.Rel _ | C.Sort _ | C.Implicit _ as t -> t - | C.Meta (n,subst) -> - let subst' = - List.map - (function None -> None | Some t -> Some (merge_coercions t)) subst - in - C.Meta (n,subst') - | C.Cast (te,ty) -> C.Cast (merge_coercions te, merge_coercions ty) - | C.Prod (name,so,dest) -> - C.Prod (name, merge_coercions so, merge_coercions dest) - | C.Lambda (name,so,dest) -> - C.Lambda (name, merge_coercions so, merge_coercions dest) - | C.LetIn (name,so,dest) -> - C.LetIn (name, merge_coercions so, merge_coercions dest) - | Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ] when - CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 -> - let source_carr = CoercGraph.source_of c2 in - let tgt_carr = CoercGraph.target_of c1 in - (match CoercGraph.look_for_coercion source_carr tgt_carr - with - | CoercGraph.SomeCoercion c -> Cic.Appl [ c ; head ] - | _ -> assert false) (* the composite coercion must exist *) - | C.Appl l -> C.Appl (List.map merge_coercions l) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst = List.map aux exp_named_subst in - C.Var (uri, exp_named_subst) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst = List.map aux exp_named_subst in - C.Const (uri, exp_named_subst) - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst = List.map aux 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 aux exp_named_subst in - C.MutConstruct (uri,tyno,consno,exp_named_subst) - | C.MutCase (uri,tyno,out,te,pl) -> - let pl = List.map merge_coercions pl in - C.MutCase (uri,tyno,merge_coercions out,merge_coercions te,pl) - | C.Fix (fno, fl) -> - let fl = List.map (fun (name,idx,ty,bo)->(name,idx,merge_coercions ty,merge_coercions bo)) fl in - C.Fix (fno, fl) - | C.CoFix (fno, fl) -> - let fl = List.map (fun (name,ty,bo) -> (name, merge_coercions ty, merge_coercions bo)) fl in - C.CoFix (fno, fl) - -let merge_coercions_in_obj obj = - let module C = Cic in - match obj with - | C.Constant (id, body, ty, params, attrs) -> - let body = - match body with - | None -> None - | Some body -> Some (merge_coercions body) - in - let ty = merge_coercions ty in - C.Constant (id, body, ty, params, attrs) - | C.Variable (name, body, ty, params, attrs) -> - let body = - match body with - | None -> None - | Some body -> Some (merge_coercions body) - in - let ty = merge_coercions ty in - C.Variable (name, body, ty, params, attrs) - | C.CurrentProof (_name, _conjectures, _body, _ty, _params, _attrs) -> - assert false - | C.InductiveDefinition (indtys, params, leftno, attrs) -> - let indtys = - List.map - (fun (name, ind, arity, cl) -> - let arity = merge_coercions arity in - let cl = List.map (fun (name, ty) -> (name,merge_coercions ty)) cl in - (name, ind, arity, cl)) - indtys - in - C.InductiveDefinition (indtys, params, leftno, attrs) - -let uris_of_obj uri = - let innertypesuri = UriManager.innertypesuri_of_uri uri in - let bodyuri = UriManager.bodyuri_of_uri uri in - let univgraphuri = UriManager.univgraphuri_of_uri uri in - innertypesuri,bodyuri,univgraphuri - -let paths_and_uris_of_obj uri ~basedir = - let basedir = basedir ^ "/xml" in - let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in - let innertypesfilename = Str.replace_first (Str.regexp "^cic:") "" - (UriManager.string_of_uri innertypesuri) ^ ".xml.gz" in - let innertypespath = basedir ^ "/" ^ innertypesfilename in - let xmlfilename = Str.replace_first (Str.regexp "^cic:/") "" - (UriManager.string_of_uri uri) ^ ".xml.gz" in - let xmlpath = basedir ^ "/" ^ xmlfilename in - let xmlbodyfilename = Str.replace_first (Str.regexp "^cic:/") "" - (UriManager.string_of_uri uri) ^ ".body.xml.gz" in - let xmlbodypath = basedir ^ "/" ^ xmlbodyfilename in - let xmlunivgraphfilename = Str.replace_first (Str.regexp "^cic:/") "" - (UriManager.string_of_uri univgraphuri) ^ ".xml.gz" in - let xmlunivgraphpath = basedir ^ "/" ^ xmlunivgraphfilename in - xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri, - xmlunivgraphpath, univgraphuri - -let save_object_to_disk ~basedir uri obj ugraph univlist = - let ensure_path_exists path = - let dir = Filename.dirname path in - HExtlib.mkdir dir - in - (* generate annobj, ids_to_inner_sorts and ids_to_inner_types *) - let annobj = Cic2acic.plain_acic_object_of_cic_object obj in - (* prepare XML *) - let xml, bodyxml = - Cic2Xml.print_object - uri ?ids_to_inner_sorts:None ~ask_dtd_to_the_getter:false annobj - in - let xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri, - xmlunivgraphpath, univgraphuri = - paths_and_uris_of_obj uri basedir - in - List.iter HExtlib.mkdir (List.map Filename.dirname [xmlpath]); - (* now write to disk *) - ensure_path_exists xmlpath; - Xml.pp ~gzip:true xml (Some xmlpath); - CicUniv.write_xml_of_ugraph xmlunivgraphpath ugraph univlist; - (* we return a list of uri,path we registered/created *) - (uri,xmlpath) :: - (univgraphuri,xmlunivgraphpath) :: - (* now the optional body, both write and register *) - (match bodyxml,bodyuri with - None,None -> [] - | Some bodyxml,Some bodyuri-> - ensure_path_exists xmlbodypath; - Xml.pp ~gzip:true bodyxml (Some xmlbodypath); - [bodyuri, xmlbodypath] - | _-> assert false) - - -let typecheck_obj = - let profiler = HExtlib.profile "add_obj.typecheck_obj" in - fun uri obj -> profiler.HExtlib.profile (CicTypeChecker.typecheck_obj uri) obj - -let index_obj = - let profiler = HExtlib.profile "add_obj.index_obj" in - fun ~dbd ~uri -> - profiler.HExtlib.profile (fun uri -> MetadataDb.index_obj ~dbd ~uri) uri - -let add_single_obj uri obj ~basedir = - let obj = - if (*List.mem `Generated (CicUtil.attributes_of_obj obj) &&*) - not (CoercGraph.is_a_coercion (Cic.Const (uri, []))) - then - merge_coercions_in_obj obj - else - obj - in - let dbd = LibraryDb.instance () in - if CicEnvironment.in_library uri then - raise (AlreadyDefined uri) - else begin - (*CicUniv.reset_spent_time (); - let before = Unix.gettimeofday () in*) - typecheck_obj uri obj; (* 1 *) - (*let after = Unix.gettimeofday () in - let univ_time = CicUniv.get_spent_time () in - let total_time = after -. before in - prerr_endline - (Printf.sprintf "QED: %%univ = %2.5f, total = %2.5f, univ = %2.5f, %s\n" - (univ_time *. 100. /. total_time) (total_time) (univ_time) - (UriManager.name_of_uri uri));*) - let _, ugraph, univlist = - CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph uri in - try - index_obj ~dbd ~uri; (* 2 must be in the env *) - try - (*3*) - let new_stuff = save_object_to_disk ~basedir uri obj ugraph univlist in - try - HLog.message - (Printf.sprintf "%s defined" (UriManager.string_of_uri uri)) - with exc -> - List.iter HExtlib.safe_remove (List.map snd new_stuff); (* -3 *) - raise exc - with exc -> - ignore(LibraryDb.remove_uri uri); (* -2 *) - raise exc - with exc -> - CicEnvironment.remove_obj uri; (* -1 *) - raise exc - end - -let remove_single_obj uri = - let derived_uris_of_uri uri = - let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in - innertypesuri::univgraphuri::(match bodyuri with None -> [] | Some u -> [u]) - in - let to_remove = - uri :: - (if UriManager.uri_is_ind uri then LibraryDb.xpointers_of_ind uri else []) @ - derived_uris_of_uri uri - in - List.iter - (fun uri -> - (try - let file = Http_getter.resolve' uri in - HExtlib.safe_remove file; - HExtlib.rmdir_descend (Filename.dirname file) - with Http_getter_types.Key_not_found _ -> ()); - ignore (LibraryDb.remove_uri uri); - (*CoercGraph.remove_coercion uri;*) - CicEnvironment.remove_obj uri) - to_remove - -(*** GENERATION OF AUXILIARY LEMMAS ***) - -let generate_elimination_principles ~basedir uri = - let uris = ref [] in - let elim sort = - try - let uri,obj = CicElim.elim_of ~sort uri 0 in - add_single_obj uri obj ~basedir; - uris := uri :: !uris - with CicElim.Can_t_eliminate -> () - in - try - List.iter elim [ Cic.Prop; Cic.Set; (Cic.Type (CicUniv.fresh ())) ]; - !uris - with exn -> - List.iter remove_single_obj !uris; - raise exn - -(* COERCIONS ***********************************************************) - -let remove_all_coercions () = - UriManager.UriHashtbl.clear coercion_hashtbl; - CoercDb.remove_coercion (fun (_,_,u1) -> true) - -let add_coercion ~basedir ~add_composites uri = - let coer_ty,_ = - let coer = CicUtil.term_of_uri uri in - CicTypeChecker.type_of_aux' [] [] coer CicUniv.empty_ugraph - in - (* we have to get the source and the tgt type uri - * in Coq syntax we have already their names, but - * since we don't support Funclass and similar I think - * all the coercion should be of the form - * (A:?)(B:?)T1->T2 - * So we should be able to extract them from the coercion type - * - * Currently only (_:T1)T2 is supported. - * should we saturate it with metas in case we insert it? - * - *) - let extract_last_two_p ty = - let rec aux = function - | Cic.Prod( _, src, Cic.Prod (n,t1,t2)) -> - assert false - (* not implemented: aux (Cic.Prod(n,t1,t2)) *) - | Cic.Prod( _, src, tgt) -> src, tgt - | _ -> assert false - in - aux ty - in - let ty_src, ty_tgt = extract_last_two_p coer_ty in - let src_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_src) in - let tgt_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_tgt) in - let new_coercions = CicCoercion.close_coercion_graph src_uri tgt_uri uri in - let composite_uris = List.map (fun (_,_,uri,_) -> uri) new_coercions in - (* update the DB *) - List.iter - (fun (src,tgt,uri,_) -> CoercDb.add_coercion (src,tgt,uri)) - new_coercions; - CoercDb.add_coercion (src_uri, tgt_uri, uri); - (* add the composites obj and they eventual lemmas *) - let lemmas = - if add_composites then - List.fold_left - (fun acc (_,_,uri,obj) -> - add_single_obj ~basedir uri obj; - uri::acc) - composite_uris new_coercions - else - [] - in - (* store that composite_uris are related to uri. the first component is the - * stuff in the DB while the second is stuff for remove_obj *) - prerr_endline ("aggiungo: " ^ string_of_bool add_composites ^ UriManager.string_of_uri uri); - List.iter (fun u -> prerr_endline (UriManager.string_of_uri u)) - composite_uris; - UriManager.UriHashtbl.add coercion_hashtbl uri - (composite_uris,if add_composites then composite_uris else []); - lemmas - -let remove_coercion uri = - try - let (composites_in_db, composites_in_lib) = - UriManager.UriHashtbl.find coercion_hashtbl uri - in - prerr_endline ("removing: " ^UriManager.string_of_uri uri); - List.iter (fun u -> prerr_endline (UriManager.string_of_uri u)) - composites_in_db; - UriManager.UriHashtbl.remove coercion_hashtbl uri; - CoercDb.remove_coercion (fun (_,_,u) -> UriManager.eq uri u); - (* remove from the DB *) - List.iter - (fun u -> CoercDb.remove_coercion (fun (_,_,u1) -> UriManager.eq u u1)) - composites_in_db; - (* remove composites from the lib *) - List.iter remove_single_obj composites_in_lib - with - Not_found -> () (* mhh..... *) - - -let generate_projections ~basedir uri fields = - let uris = ref [] in - let projections = CicRecord.projections_of uri (List.map fst fields) in - try - List.iter2 - (fun (uri, name, bo) (_name, coercion) -> - try - let ty, ugraph = - CicTypeChecker.type_of_aux' [] [] bo CicUniv.empty_ugraph in - let attrs = [`Class `Projection; `Generated] in - let obj = Cic.Constant (name,Some bo,ty,[],attrs) in - add_single_obj ~basedir uri obj; - let composites = - if coercion then - add_coercion ~basedir ~add_composites:true uri - else - [] - in - uris := uri :: composites @ !uris - with - CicTypeChecker.TypeCheckerFailure s -> - HLog.message - ("Unable to create projection " ^ name ^ " cause: " ^ Lazy.force s); - | CicEnvironment.Object_not_found uri -> - let depend = UriManager.name_of_uri uri in - HLog.message - ("Unable to create projection " ^ name ^ " because it requires " ^ - depend) - ) projections fields; - !uris - with exn -> - List.iter remove_single_obj !uris; - raise exn - - -let add_obj uri obj ~basedir = - add_single_obj uri obj ~basedir; - let uris = ref [] in - try - begin - match obj with - | Cic.Constant _ -> () - | Cic.InductiveDefinition (_,_,_,attrs) -> - uris := !uris @ generate_elimination_principles ~basedir uri; - let rec get_record_attrs = - function - | [] -> None - | (`Class (`Record fields))::_ -> Some fields - | _::tl -> get_record_attrs tl - in - (match get_record_attrs attrs with - | None -> () (* not a record *) - | Some fields -> - uris := !uris @ (generate_projections ~basedir uri fields)) - | Cic.CurrentProof _ - | Cic.Variable _ -> assert false - end; - UriManager.UriHashtbl.add auxiliary_lemmas_hashtbl uri !uris; - !uris - with exn -> - List.iter remove_single_obj !uris; - raise exn - -let remove_obj uri = - let uris = - try - let res = UriManager.UriHashtbl.find auxiliary_lemmas_hashtbl uri in - UriManager.UriHashtbl.remove auxiliary_lemmas_hashtbl uri; - res - with - Not_found -> [] (*assert false*) - in - List.iter remove_single_obj (uri::uris) - diff --git a/helm/ocaml/library/librarySync.mli b/helm/ocaml/library/librarySync.mli deleted file mode 100644 index d063b3282..000000000 --- a/helm/ocaml/library/librarySync.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -exception AlreadyDefined of UriManager.uri - -val merge_coercions: Cic.term -> Cic.term - -(* adds an object to the library together with all auxiliary lemmas on it *) -(* (e.g. elimination principles, projections, etc.) *) -(* it returns the list of the uris of the auxiliary lemmas generated *) -val add_obj: UriManager.uri -> Cic.obj -> basedir:string -> UriManager.uri list - -(* inverse of add_obj; *) -(* Warning: it does not remove the dependencies on the object and on its *) -(* auxiliary lemmas! *) -val remove_obj: UriManager.uri -> unit - -(* Informs the library that [uri] is a coercion. *) -(* This can generate some composite coercions that, if [add_composites] *) -(* is true are added to the library. *) -(* The list of added objects is returned. *) -val add_coercion: - basedir:string -> add_composites:bool -> UriManager.uri -> - UriManager.uri list - -(* inverse of add_coercion, removes both the eventually created composite *) -(* coercions and the information that [uri] and the composites are coercion *) -val remove_coercion: UriManager.uri -> unit - -(* mh... *) -val remove_all_coercions: unit -> unit - diff --git a/helm/ocaml/license b/helm/ocaml/license deleted file mode 100644 index c67e1fc29..000000000 --- a/helm/ocaml/license +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2006, 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://helm.cs.unibo.it/ - *) - diff --git a/helm/ocaml/logger/.depend b/helm/ocaml/logger/.depend deleted file mode 100644 index 28268d29e..000000000 --- a/helm/ocaml/logger/.depend +++ /dev/null @@ -1,2 +0,0 @@ -helmLogger.cmo: helmLogger.cmi -helmLogger.cmx: helmLogger.cmi diff --git a/helm/ocaml/logger/Makefile b/helm/ocaml/logger/Makefile deleted file mode 100644 index 39d690084..000000000 --- a/helm/ocaml/logger/Makefile +++ /dev/null @@ -1,10 +0,0 @@ - -PACKAGE = logger -INTERFACE_FILES = \ - helmLogger.mli -IMPLEMENTATION_FILES = \ - $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common - diff --git a/helm/ocaml/logger/helmLogger.ml b/helm/ocaml/logger/helmLogger.ml deleted file mode 100644 index c41674754..000000000 --- a/helm/ocaml/logger/helmLogger.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* $Id$ *) - -open Printf - -(* HTML simulator (first in its kind) *) - -type html_tag = - [ `T of string - | `L of html_tag list - | `BR - | `DIV of int * string option * html_tag - ] - -type html_msg = [ `Error of html_tag | `Msg of html_tag ] - -type logger_fun = ?append_NL:bool -> html_msg -> unit - -let rec string_of_html_tag = - let rec aux indent = - let indent_str = String.make indent ' ' in - function - | `T s -> s - | `L msgs -> - String.concat ("\n" ^ indent_str) (List.map (aux indent) msgs) - | `BR -> "\n" ^ indent_str - | `DIV (local_indent, _, tag) -> - "\n" ^ indent_str ^ aux (indent + local_indent) tag - in - aux 0 - -let string_of_html_msg = function - | `Error tag -> "Error: " ^ string_of_html_tag tag - | `Msg tag -> string_of_html_tag tag - -let rec html_of_html_tag = function - | `T s -> s - | `L msgs -> - sprintf "
    \n%s\n
" - (String.concat "\n" - (List.map - (fun msg -> sprintf "
  • %s
    • " (html_of_html_tag msg)) - msgs)) - | `BR -> "
    \n" - | `DIV (indent, color, tag) -> - sprintf "
    \n%s\n
    " - (match color with None -> "" | Some color -> "color: " ^ color ^ "; ") - (float_of_int indent *. 0.5) - (html_of_html_tag tag) - -let html_of_html_msg = - function - | `Error tag -> "Error: " ^ html_of_html_tag tag ^ "" - | `Msg tag -> html_of_html_tag tag - -let log_callbacks = ref [] - -let register_log_callback logger_fun = - log_callbacks := !log_callbacks @ [ logger_fun ] - -let log ?append_NL html_msg = - List.iter (fun logger_fun -> logger_fun ?append_NL html_msg) !log_callbacks - diff --git a/helm/ocaml/logger/helmLogger.mli b/helm/ocaml/logger/helmLogger.mli deleted file mode 100644 index 633b5c3ec..000000000 --- a/helm/ocaml/logger/helmLogger.mli +++ /dev/null @@ -1,27 +0,0 @@ - -type html_tag = - [ `BR - | `L of html_tag list - | `T of string - | `DIV of int * string option * html_tag (* indentation, color, tag *) - ] -type html_msg = [ `Error of html_tag | `Msg of html_tag ] - - (** html_msg to plain text converter *) -val string_of_html_msg: html_msg -> string - - (** html_tag to plain text converter *) -val string_of_html_tag: html_tag -> string - - (** html_msg to html text converter *) -val html_of_html_msg: html_msg -> string - - (** html_tag to html text converter *) -val html_of_html_tag: html_tag -> string - -type logger_fun = ?append_NL:bool -> html_msg -> unit - -val register_log_callback: logger_fun -> unit - -val log: logger_fun - diff --git a/helm/ocaml/metadata/.depend b/helm/ocaml/metadata/.depend deleted file mode 100644 index 04197957b..000000000 --- a/helm/ocaml/metadata/.depend +++ /dev/null @@ -1,20 +0,0 @@ -metadataExtractor.cmi: metadataTypes.cmi -metadataPp.cmi: metadataTypes.cmi -metadataConstraints.cmi: metadataTypes.cmi -metadataDb.cmi: metadataTypes.cmi -sqlStatements.cmo: sqlStatements.cmi -sqlStatements.cmx: sqlStatements.cmi -metadataTypes.cmo: metadataTypes.cmi -metadataTypes.cmx: metadataTypes.cmi -metadataExtractor.cmo: metadataTypes.cmi metadataExtractor.cmi -metadataExtractor.cmx: metadataTypes.cmx metadataExtractor.cmi -metadataPp.cmo: metadataTypes.cmi metadataPp.cmi -metadataPp.cmx: metadataTypes.cmx metadataPp.cmi -metadataConstraints.cmo: metadataTypes.cmi metadataPp.cmi \ - metadataConstraints.cmi -metadataConstraints.cmx: metadataTypes.cmx metadataPp.cmx \ - metadataConstraints.cmi -metadataDb.cmo: metadataTypes.cmi metadataPp.cmi metadataExtractor.cmi \ - metadataConstraints.cmi metadataDb.cmi -metadataDb.cmx: metadataTypes.cmx metadataPp.cmx metadataExtractor.cmx \ - metadataConstraints.cmx metadataDb.cmi diff --git a/helm/ocaml/metadata/Makefile b/helm/ocaml/metadata/Makefile deleted file mode 100644 index d02d021a5..000000000 --- a/helm/ocaml/metadata/Makefile +++ /dev/null @@ -1,40 +0,0 @@ -PACKAGE = metadata -PREDICATES = - -INTERFACE_FILES = \ - sqlStatements.mli \ - metadataTypes.mli \ - metadataExtractor.mli \ - metadataPp.mli \ - metadataConstraints.mli \ - metadataDb.mli -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common - -all: all_table_creator all_extractor -opt: opt_table_creator opt_extractor - -all_table_creator: - @make -C table_creator/ all -opt_table_creator: - @make -C table_creator/ opt - -all_extractor: - @make -C extractor/ all -opt_extractor: - @make -C extractor/ opt - -clean: clean_table_creator clean_extractor - -clean_table_creator: - @echo " cleaning: table_creator" - @make -C table_creator/ clean - -clean_extractor: - @echo " cleaning: extractor" - @make -C extractor/ clean - diff --git a/helm/ocaml/metadata/dump_db/dump.sh b/helm/ocaml/metadata/dump_db/dump.sh deleted file mode 100755 index e7b43666e..000000000 --- a/helm/ocaml/metadata/dump_db/dump.sh +++ /dev/null @@ -1,20 +0,0 @@ -ALL_TABLES=`../table_creator/table_creator list all` - -if [ -z "$1" ]; then - echo "Dumps to stdout some tables of a given db on mowgli." - echo "If no tables are given the dump will contain:" - echo " $ALL_TABLES" - echo "" - echo "usage: dump.sh dbname [tables...]" - echo "" - exit 1 -fi -DB=$1 -shift -if [ -z "$1" ]; then - TABLES=$ALL_TABLES -else - TABLES=$@ -fi - -mysqldump -e --add-drop-table -u helm -h mowgli.cs.unibo.it $DB $TABLES diff --git a/helm/ocaml/metadata/extractor/.depend b/helm/ocaml/metadata/extractor/.depend deleted file mode 100644 index e69de29bb..000000000 diff --git a/helm/ocaml/metadata/extractor/Makefile b/helm/ocaml/metadata/extractor/Makefile deleted file mode 100644 index 579a5655f..000000000 --- a/helm/ocaml/metadata/extractor/Makefile +++ /dev/null @@ -1,36 +0,0 @@ - -all: extractor extractor_manager - @echo -n -opt: extractor.opt extractor_manager.opt - @echo -n - -clean: - rm -f *.cm[ixo] *.[ao] extractor extractor.opt *.err *.out extractor_manager extractor_manager.opt - -extractor: extractor.ml - @echo " OCAMLC $<" - @$(OCAMLFIND) ocamlc \ - -thread -package mysql,helm-metadata -linkpkg -o $@ $< - -extractor.opt: extractor.ml - @echo " OCAMLOPT $<" - @$(OCAMLFIND) ocamlopt \ - -thread -package mysql,helm-metadata -linkpkg -o $@ $< - -extractor_manager: extractor_manager.ml - @echo " OCAMLC $<" - @$(OCAMLFIND) ocamlc \ - -thread -package mysql,helm-metadata -linkpkg -o $@ $< - -extractor_manager.opt: extractor_manager.ml - @echo " OCAMLOPT $<" - @$(OCAMLFIND) ocamlopt \ - -thread -package mysql,helm-metadata -linkpkg -o $@ $< - -export: extractor.opt extractor_manager.opt - nice -n 20 \ - time \ - ./extractor_manager.opt 1>export.out 2>export.err - -include .depend -include ../../../Makefile.defs diff --git a/helm/ocaml/metadata/extractor/extractor.conf.xml b/helm/ocaml/metadata/extractor/extractor.conf.xml deleted file mode 100644 index 8dbc9a935..000000000 --- a/helm/ocaml/metadata/extractor/extractor.conf.xml +++ /dev/null @@ -1,19 +0,0 @@ - - -
    - .tmp/ -
    -
    - localhost - helm - mowgli -
    -
    - - file:///projects/helm/library/coq_contribs - - $(tmp.dir)/cache - $(tmp.dir)/maps - /projects/helm/xml/dtd -
    -     diff --git a/helm/ocaml/metadata/extractor/extractor.ml b/helm/ocaml/metadata/extractor/extractor.ml deleted file mode 100644 index 418d5ff7c..000000000 --- a/helm/ocaml/metadata/extractor/extractor.ml +++ /dev/null @@ -1,78 +0,0 @@ -let _ = Helm_registry.load_from "extractor.conf.xml" - -let usage () = - prerr_endline " - -!! This binary should not be called by hand, use the extractor_manager. !! - -usage: ./extractor[.opt] path owner - -path: the path for the getter maps -owner: the owner of the tables to update - -" - -let _ = - try - let _ = Sys.argv.(2), Sys.argv.(1) in - if Sys.argv.(1) = "-h"||Sys.argv.(1) = "-help"||Sys.argv.(1) = "--help" then - begin - usage (); - exit 1 - end - with - Invalid_argument _ -> usage (); exit 1 - -let owner = Sys.argv.(2) -let path = Sys.argv.(1) - -let main () = - print_endline (Printf.sprintf "%d alive on path:%s owner:%s" - (Unix.getpid()) path owner); - Helm_registry.set "tmp.dir" path; - Http_getter.init (); - let dbd = - HMysql.quick_connect - ~host:(Helm_registry.get "db.host") - ~user:(Helm_registry.get "db.user") - ~database:(Helm_registry.get "db.database") () - in - MetadataTypes.ownerize_tables owner; - let uris = - let ic = open_in (path ^ "/todo") in - let acc = ref [] in - (try - while true do - let l = input_line ic in - acc := l :: !acc - done - with - End_of_file -> ()); - close_in ic; - !acc - in - let len = float_of_int (List.length uris) in - let i = ref 0 in - let magic = 45 in - List.iter (fun u -> - incr i; - let perc = ((float_of_int !i) /. len *. 100.0) in - let l = String.length u in - let short = - if l < magic then - u ^ String.make (magic + 3 - l) ' ' - else - "..." ^ String.sub u (l - magic) magic - in - Printf.printf "%d (%d of %.0f = %3.1f%%): %s\n" - (Unix.getpid ()) !i len perc short; - flush stdout; - let uri = UriManager.uri_of_string u in - MetadataDb.index_obj ~dbd ~uri; - CicEnvironment.empty ()) - uris; - print_string "END "; Unix.system "date" -;; - -main () - diff --git a/helm/ocaml/metadata/extractor/extractor_manager.ml b/helm/ocaml/metadata/extractor/extractor_manager.ml deleted file mode 100644 index 05393b63e..000000000 --- a/helm/ocaml/metadata/extractor/extractor_manager.ml +++ /dev/null @@ -1,306 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* HELPERS *) - -let create_all dbd = - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - let count_tbl = MetadataTypes.count_tbl () in - let tbls = [ - (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; - (name_tbl,`ObjectName) ; (count_tbl,`Count) ] - in - let statements = - (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls) - in - List.iter (fun statement -> - try - ignore (Mysql.exec dbd statement) - with - exn -> - let status = Mysql.status dbd in - match status with - | Mysql.StatusError Mysql.Table_exists_error -> () - | Mysql.StatusError _ -> raise exn - | _ -> () - ) statements - -let drop_all dbd = - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - let count_tbl = MetadataTypes.count_tbl () in - let tbls = [ - (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; - (name_tbl,`ObjectName) ; (count_tbl,`Count) ] - in - let statements = - (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls) - in - List.iter (fun statement -> - try - ignore (Mysql.exec dbd statement) - with Mysql.Error _ as exn -> - match Mysql.errno dbd with - | Mysql.Bad_table_error - | Mysql.No_such_index | Mysql.No_such_table -> () - | _ -> raise exn - ) statements - -let slash_RE = Str.regexp "/" - -let partition l = - let l = List.fast_sort Pervasives.compare l in - let matches s1 s2 = - let l1,l2 = Str.split slash_RE s1, Str.split slash_RE s2 in - match l1,l2 with - | _::x::_,_::y::_ -> x = y - | _ -> false - in - let rec chunk l = - match l with - | [] -> [],[] - | h::(h1::tl as rest) when matches h h1 -> - let ch,todo = chunk rest in - (h::ch),todo - | h::(h1::tl as rest)-> [h],rest - | h::_ -> [h],[] - in - let rec split l = - let ch, todo = chunk l in - match todo with - | [] -> [ch] - | _ -> ch :: split todo - in - split l - - -(* ARGV PARSING *) - -let _ = - try - if Sys.argv.(1) = "-h"||Sys.argv.(1) = "-help"||Sys.argv.(1) = "--help" then - begin - prerr_endline " -usage: ./extractor_manager[.opt] [processes] [owner] - -defaults: - processes = 2 - owner = NEW - -"; - exit 1 - end - with Invalid_argument _ -> () - -let processes = - try - int_of_string (Sys.argv.(1)) - with - Invalid_argument _ -> 2 - -let owner = - try - Sys.argv.(2) - with Invalid_argument _ -> "NEW" - -let create_peons i = - let rec aux = function - | 0 -> [] - | n -> (n,0) :: aux (n-1) - in - ref (aux i) - -let is_a_peon_idle peons = - List.exists (fun (_,x) -> x = 0) !peons - -let get_ide_peon peons = - let p = fst(List.find (fun (_,x) -> x = 0) !peons) in - peons := List.filter (fun (x,_) -> x <> p) !peons; - p - -let assign_peon peon pid peons = - peons := (peon,pid) :: !peons - -let wait_a_peon peons = - let pid,status = Unix.wait () in - (match status with - | Unix.WEXITED 0 -> () - | Unix.WEXITED s -> - prerr_endline (Printf.sprintf "PEON %d EXIT STATUS %d" pid s) - | Unix.WSIGNALED s -> - prerr_endline - (Printf.sprintf "PEON %d HAD A PROBLEM, KILLED BY SIGNAL %d" pid s) - | Unix.WSTOPPED s -> - prerr_endline - (Printf.sprintf "PEON %d HAD A PROBLEM, STOPPED BY %d" pid s)); - let p = fst(List.find (fun (_,x) -> x = pid) !peons) in - peons := List.filter (fun (x,_) -> x <> p) !peons; - peons := (p,0) :: !peons - -let is_a_peon_busy peons = - List.exists (fun (_,x) -> x <> 0) !peons - -(* MAIN *) -let main () = - Helm_registry.load_from "extractor.conf.xml"; - Http_getter.init (); - print_endline "Updating the getter...."; - let base = (Helm_registry.get "tmp.dir") ^ "/maps" in - let formats i = - (Helm_registry.get "tmp.dir") ^ "/"^(string_of_int i)^"/maps" - in - for i = 1 to processes do - let fmt = formats i in - ignore(Unix.system ("rm -rf " ^ fmt)); - ignore(Unix.system ("mkdir -p " ^ fmt)); - ignore(Unix.system ("cp -r " ^ base ^ " " ^ fmt ^ "/../")); - done; - let dbd = - Mysql.quick_connect - ~host:(Helm_registry.get "db.host") - ~user:(Helm_registry.get "db.user") - ~database:(Helm_registry.get "db.database") () - in - MetadataTypes.ownerize_tables owner; - let uri_RE = Str.regexp ".*\\(ind\\|var\\|con\\)$" in - drop_all dbd; - create_all dbd; - let uris = Http_getter.getalluris () in - let uris = List.filter (fun u -> Str.string_match uri_RE u 0) uris in - let todo = partition uris in - let cur = ref 0 in - let tot = List.length todo in - let peons = create_peons processes in - print_string "START "; flush stdout; - ignore(Unix.system "date"); - while !cur < tot do - if is_a_peon_idle peons then - let peon = get_ide_peon peons in - let fmt = formats peon in - let oc = open_out (fmt ^ "/../todo") in - List.iter (fun s -> output_string oc (s^"\n")) (List.nth todo !cur); - close_out oc; - let pid = Unix.fork () in - if pid = 0 then - Unix.execv - "./extractor.opt" [| "./extractor.opt" ; fmt ^ "/../" ; owner|] - else - begin - assign_peon peon pid peons; - incr cur - end - else - wait_a_peon peons - done; - while is_a_peon_busy peons do wait_a_peon peons done; - print_string "END "; flush stdout; - ignore(Unix.system "date"); - (* and now the rename table stuff *) - let obj_tbl = MetadataTypes.library_obj_tbl in - let sort_tbl = MetadataTypes.library_sort_tbl in - let rel_tbl = MetadataTypes.library_rel_tbl in - let name_tbl = MetadataTypes.library_name_tbl in - let count_tbl = MetadataTypes.library_count_tbl in - let hits_tbl = MetadataTypes.library_hits_tbl in - let obj_tbl_b = obj_tbl ^ "_BACKUP" in - let sort_tbl_b = sort_tbl ^ "_BACKUP" in - let rel_tbl_b = rel_tbl ^ "_BACKUP" in - let name_tbl_b = name_tbl ^ "_BACKUP" in - let count_tbl_b = count_tbl ^ "_BACKUP" in - let obj_tbl_c = MetadataTypes.obj_tbl () in - let sort_tbl_c = MetadataTypes.sort_tbl () in - let rel_tbl_c = MetadataTypes.rel_tbl () in - let name_tbl_c = MetadataTypes.name_tbl () in - let count_tbl_c = MetadataTypes.count_tbl () in - let stats = - SqlStatements.drop_tables [ - (obj_tbl_b,`RefObj); - (sort_tbl_b,`RefSort); - (rel_tbl_b,`RefRel); - (name_tbl_b,`ObjectName); - (count_tbl_b,`Count); - (hits_tbl,`Hits) ] @ - SqlStatements.drop_indexes [ - (obj_tbl,`RefObj); - (sort_tbl,`RefSort); - (rel_tbl,`RefRel); - (name_tbl,`ObjectName); - (count_tbl,`Count); - (obj_tbl_c,`RefObj); - (sort_tbl_c,`RefSort); - (rel_tbl_c,`RefRel); - (name_tbl_c,`ObjectName); - (count_tbl_c,`Count); - (hits_tbl,`Hits) ] @ - SqlStatements.rename_tables [ - (obj_tbl,obj_tbl_b); - (sort_tbl,sort_tbl_b); - (rel_tbl,rel_tbl_b); - (name_tbl,name_tbl_b); - (count_tbl,count_tbl_b) ] @ - SqlStatements.rename_tables [ - (obj_tbl_c,obj_tbl); - (sort_tbl_c,sort_tbl); - (rel_tbl_c,rel_tbl); - (name_tbl_c,name_tbl); - (count_tbl_c,count_tbl) ] @ - SqlStatements.create_tables [ - (hits_tbl,`Hits) ] @ - SqlStatements.fill_hits obj_tbl hits_tbl @ - SqlStatements.create_indexes [ - (obj_tbl,`RefObj); - (sort_tbl,`RefSort); - (rel_tbl,`RefRel); - (name_tbl,`ObjectName); - (count_tbl,`Count); - (hits_tbl,`Hits) ] - in - List.iter (fun statement -> - try -(* prerr_endline statement;*) - ignore (Mysql.exec dbd statement) - with exn -> - let status = Mysql.status dbd in - match status with - | Mysql.StatusError Mysql.Table_exists_error - | Mysql.StatusError Mysql.Bad_table_error - | Mysql.StatusError Mysql.Cant_drop_field_or_key - | Mysql.StatusError Mysql.Unknown_table -> () - | Mysql.StatusError status -> -(* prerr_endline (string_of_int (Obj.magic status));*) - prerr_endline (Printexc.to_string exn); - raise exn - | _ -> - prerr_endline (Printexc.to_string exn); - ()) - stats -;; - -main () diff --git a/helm/ocaml/metadata/metadataConstraints.ml b/helm/ocaml/metadata/metadataConstraints.ml deleted file mode 100644 index 07fcc738b..000000000 --- a/helm/ocaml/metadata/metadataConstraints.ml +++ /dev/null @@ -1,649 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf -open MetadataTypes - -let critical_value = 7 -let just_factor = 3 - -module UriManagerSet = UriManager.UriSet -module SetSet = Set.Make (UriManagerSet) - -type term_signature = (UriManager.uri * UriManager.uri list) option * UriManagerSet.t - -type cardinality_condition = - | Eq of int - | Gt of int - | Lt of int - -type rating_criterion = - [ `Hits (** order by number of hits, most used objects first *) - ] - -let default_tables = - (library_obj_tbl,library_rel_tbl,library_sort_tbl,library_count_tbl) - -let current_tables () = - (obj_tbl (),rel_tbl (),sort_tbl (), count_tbl ()) - -let tbln n = "table" ^ string_of_int n - -(* -let add_depth_constr depth_opt cur_tbl where = - match depth_opt with - | None -> where - | Some depth -> (sprintf "%s.h_depth = %d" cur_tbl depth) :: where -*) - -let mk_positions positions cur_tbl = - "(" ^ - String.concat " or " - (List.map - (fun pos -> - let pos_str = MetadataPp.pp_position_tag pos in - match pos with - | `InBody - | `InConclusion - | `InHypothesis - | `MainConclusion None - | `MainHypothesis None -> - sprintf "%s.h_position = \"%s\"" cur_tbl pos_str - | `MainConclusion (Some r) - | `MainHypothesis (Some r) -> - let depth = MetadataPp.pp_relation r in - sprintf "(%s.h_position = \"%s\" and %s.h_depth %s)" - cur_tbl pos_str cur_tbl depth) - (positions :> MetadataTypes.position list)) ^ - ")" - -let explode_card_constr = function - | Eq card -> "=", card - | Gt card -> ">", card - | Lt card -> "<", card - -let add_card_constr tbl col where = function - | None -> where - | Some constr -> - let op, card = explode_card_constr constr in - (* count(_utente).hypothesis = 3 *) - (sprintf "%s.%s %s %d" tbl col op card :: where) - -let add_diff_constr tbl where = function - | None -> where - | Some constr -> - let op, card = explode_card_constr constr in - (sprintf "%s.hypothesis - %s.conclusion %s %d" tbl tbl op card :: where) - -let add_all_constr ?(tbl=library_count_tbl) (n,from,where) concl full diff = - match (concl, full, diff) with - | None, None, None -> (n,from,where) - | _ -> - let cur_tbl = tbln n in - let from = (sprintf "%s as %s" tbl cur_tbl) :: from in - let where = add_card_constr cur_tbl "conclusion" where concl in - let where = add_card_constr cur_tbl "statement" where full in - let where = add_diff_constr cur_tbl where diff in - (n+2,from, - (if n > 0 then - sprintf "table0.source = %s.source" cur_tbl :: where - else - where)) - - -let add_constraint ?(start=0) ?(tables=default_tables) (n,from,where) metadata = - let obj_tbl,rel_tbl,sort_tbl,count_tbl = tables - in - let cur_tbl = tbln n in - let start_table = tbln start in - match metadata with - | `Obj (uri, positions) -> - let from = (sprintf "%s as %s" obj_tbl cur_tbl) :: from in - let where = - (sprintf "(%s.h_occurrence = \"%s\")" cur_tbl (UriManager.string_of_uri uri)) :: - mk_positions positions cur_tbl :: - (if n=start then [] - else [sprintf "%s.source = %s.source" start_table cur_tbl]) @ - where - in - ((n+2), from, where) - | `Rel positions -> - let from = (sprintf "%s as %s" rel_tbl cur_tbl) :: from in - let where = - mk_positions positions cur_tbl :: - (if n=start then [] - else [sprintf "%s.source = %s.source" start_table cur_tbl]) @ - where - in - ((n+2), from, where) - | `Sort (sort, positions) -> - let sort_str = CicPp.ppsort sort in - let from = (sprintf "%s as %s" sort_tbl cur_tbl) :: from in - let where = - (sprintf "%s.h_sort = \"%s\"" cur_tbl sort_str ) :: - mk_positions positions cur_tbl :: - (if n=start then - [] - else - [sprintf "%s.source = %s.source" start_table cur_tbl ]) @ where - in - ((n+2), from, where) - -let exec ~(dbd:HMysql.dbd) ?rating (n,from,where) = - let from = String.concat ", " from in - let where = String.concat " and " where in - let query = - match rating with - | None -> sprintf "select distinct table0.source from %s where %s" from where - | Some `Hits -> - sprintf - ("select distinct table0.source from %s, hits where %s - and table0.source = hits.source order by hits.no desc") - from where - in - (* prerr_endline query; *) - let result = HMysql.exec dbd query in - HMysql.map result - (fun row -> match row.(0) with Some s -> UriManager.uri_of_string s | _ -> assert false) - - -let at_least ~(dbd:HMysql.dbd) ?concl_card ?full_card ?diff ?rating tables - (metadata: MetadataTypes.constr list) -= - let obj_tbl,rel_tbl,sort_tbl, count_tbl = tables - in - if (metadata = []) && concl_card = None && full_card = None then - failwith "MetadataQuery.at_least: no constraints given"; - let (n,from,where) = - List.fold_left (add_constraint ~tables) (0,[],[]) metadata - in - let (n,from,where) = - add_all_constr ~tbl:count_tbl (n,from,where) concl_card full_card diff - in - exec ~dbd ?rating (n,from,where) - -let at_least - ~(dbd:HMysql.dbd) ?concl_card ?full_card ?diff ?rating - (metadata: MetadataTypes.constr list) -= - if are_tables_ownerized () then - (at_least - ~dbd ?concl_card ?full_card ?diff ?rating default_tables metadata) @ - (at_least - ~dbd ?concl_card ?full_card ?diff ?rating (current_tables ()) metadata) - else - at_least - ~dbd ?concl_card ?full_card ?diff ?rating default_tables metadata - - - (** Prefix handling *) - -let filter_by_card n = - SetSet.filter (fun t -> (UriManagerSet.cardinal t) <= n) - -let merge n a b = - let init = SetSet.union a b in - let merge_single_set s1 b = - SetSet.fold - (fun s2 res -> SetSet.add (UriManagerSet.union s1 s2) res) - b SetSet.empty in - let res = - SetSet.fold (fun s1 res -> SetSet.union (merge_single_set s1 b) res) a init - in - filter_by_card n res - -let rec inspect_children n childs = - List.fold_left - (fun res term -> merge n (inspect_conclusion n term) res) - SetSet.empty childs - -and add_root n root childs = - let childunion = inspect_children n childs in - let addroot = UriManagerSet.add root in - SetSet.fold - (fun child newsets -> SetSet.add (addroot child) newsets) - childunion - (SetSet.singleton (UriManagerSet.singleton root)) - -and inspect_conclusion n t = - if n = 0 then SetSet.empty - else match t with - Cic.Rel _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ -> SetSet.empty - | Cic.Var (u,exp_named_subst) -> SetSet.empty - | Cic.Const (u,exp_named_subst) -> - SetSet.singleton (UriManagerSet.singleton u) - | Cic.MutInd (u, t, exp_named_subst) -> - SetSet.singleton (UriManagerSet.singleton - (UriManager.uri_of_uriref u t None)) - | Cic.MutConstruct (u, t, c, exp_named_subst) -> - SetSet.singleton (UriManagerSet.singleton - (UriManager.uri_of_uriref u t (Some c))) - | Cic.Cast (t, _) -> inspect_conclusion n t - | Cic.Prod (_, s, t) -> - merge n (inspect_conclusion n s) (inspect_conclusion n t) - | Cic.Lambda (_, s, t) -> - merge n (inspect_conclusion n s) (inspect_conclusion n t) - | Cic.LetIn (_, s, t) -> - merge n (inspect_conclusion n s) (inspect_conclusion n t) - | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> - add_root (n-1) u l - | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> - let uri = UriManager.uri_of_uriref u t None in - add_root (n-1) uri l - | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t (Some c) in - add_root (n-1) suri l - | Cic.Appl l -> - SetSet.empty - | Cic.MutCase (u, t, tt, uu, m) -> - SetSet.empty - | Cic.Fix (_, m) -> - SetSet.empty - | Cic.CoFix (_, m) -> - SetSet.empty - -let rec inspect_term n t = - if n = 0 then - assert false - else - match t with - Cic.Rel _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ -> None, SetSet.empty - | Cic.Var (u,exp_named_subst) -> None, SetSet.empty - | Cic.Const (u,exp_named_subst) -> - Some u, SetSet.empty - | Cic.MutInd (u, t, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t None in - Some uri, SetSet.empty - | Cic.MutConstruct (u, t, c, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t (Some c) in - Some uri, SetSet.empty - | Cic.Cast (t, _) -> inspect_term n t - | Cic.Prod (_, _, t) -> inspect_term n t - | Cic.LetIn (_, _, t) -> inspect_term n t - | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> - let childunion = inspect_children (n-1) l in - Some u, childunion - | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t None in - if u = HelmLibraryObjects.Logic.eq_URI && n>1 then - (* equality is handled in a special way: in particular, - the type, if defined, is always added to the prefix, - and n is not decremented - it should have been n-2 *) - match l with - Cic.Const (u1,exp_named_subst1)::l1 -> - let inconcl = add_root (n-1) u1 l1 in - Some suri, inconcl - | Cic.MutInd (u1, t1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 None in - let inconcl = add_root (n-1) suri1 l1 in - Some suri, inconcl - | Cic.MutConstruct (u1, t1, c1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 (Some c1) in - let inconcl = add_root (n-1) suri1 l1 in - Some suri, inconcl - | _ :: _ -> Some suri, SetSet.empty - | _ -> assert false (* args number must be > 0 *) - else - let childunion = inspect_children (n-1) l in - Some suri, childunion - | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t(Some c) in - let childunion = inspect_children (n-1) l in - Some suri, childunion - | _ -> None, SetSet.empty - -let add_cardinality s = - let l = SetSet.elements s in - let res = - List.map - (fun set -> - let el = UriManagerSet.elements set in - (List.length el, el)) l in - (* ordered by descending cardinality *) - List.sort (fun (n,_) (m,_) -> m - n) ((0,[])::res) - -let prefixes n t = - match inspect_term n t with - Some a, set -> Some a, add_cardinality set - | None, set when (SetSet.is_empty set) -> None, [] - | _, _ -> assert false - - -let rec add children = - List.fold_left - (fun acc t -> UriManagerSet.union (signature_concl t) acc) - (UriManagerSet.empty) children - -(* this function creates the set of all different constants appearing in - the conclusion of the term *) -and signature_concl = - function - Cic.Rel _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ -> UriManagerSet.empty - | Cic.Var (u,exp_named_subst) -> - (*CSC: TODO if the var has a body it must be processed *) - UriManagerSet.empty - | Cic.Const (u,exp_named_subst) -> - UriManagerSet.singleton u - | Cic.MutInd (u, t, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t None in - UriManagerSet.singleton uri - | Cic.MutConstruct (u, t, c, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t (Some c) in - UriManagerSet.singleton uri - | Cic.Cast (t, _) -> signature_concl t - | Cic.Prod (_, s, t) -> - UriManagerSet.union (signature_concl s) (signature_concl t) - | Cic.Lambda (_, s, t) -> - UriManagerSet.union (signature_concl s) (signature_concl t) - | Cic.LetIn (_, s, t) -> - UriManagerSet.union (signature_concl s) (signature_concl t) - | Cic.Appl l -> add l - | Cic.MutCase _ - | Cic.Fix _ - | Cic.CoFix _ -> - UriManagerSet.empty - -let rec signature_of = function - | Cic.Cast (t, _) -> signature_of t - | Cic.Prod (_, _, t) -> signature_of t - | Cic.LetIn (_, _, t) -> signature_of t - | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> - Some (u, []), add l - | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t None in - if u = HelmLibraryObjects.Logic.eq_URI then - (* equality is handled in a special way: in particular, - the type, if defined, is always added to the prefix, - and n is not decremented - it should have been n-2 *) - match l with - Cic.Const (u1,exp_named_subst1)::l1 -> - let inconcl = UriManagerSet.remove u1 (add l1) in - Some (suri, [u1]), inconcl - | Cic.MutInd (u1, t1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 None in - let inconcl = UriManagerSet.remove suri1 (add l1) in - Some (suri, [suri1]), inconcl - | Cic.MutConstruct (u1, t1, c1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 (Some c1) in - let inconcl = UriManagerSet.remove suri1 (add l1) in - Some (suri, [suri1]), inconcl - | _ :: _ -> Some (suri, []), UriManagerSet.empty - | _ -> assert false (* args number must be > 0 *) - else - Some (suri, []), add l - | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t (Some c) in - Some (suri, []), add l - | t -> None, signature_concl t - -(* takes a list of lists and returns the list of all elements - without repetitions *) -let union l = - let rec drop_repetitions = function - [] -> [] - | [a] -> [a] - | u1::u2::l when u1 = u2 -> drop_repetitions (u2::l) - | u::l -> u::(drop_repetitions l) in - drop_repetitions (List.sort Pervasives.compare (List.concat l)) - -let must_of_prefix ?(where = `Conclusion) m s = - let positions = - match where with - | `Conclusion -> [`InConclusion] - | `Statement -> [`InConclusion; `InHypothesis; `MainHypothesis None] - in - let positions = - if m = None then `MainConclusion None :: positions else positions in - let s' = List.map (fun (u:UriManager.uri) -> `Obj (u, positions)) s in - match m with - None -> s' - | Some m -> `Obj (m, [`MainConclusion None]) :: s' - -let escape = Str.global_replace (Str.regexp_string "\'") "\\'" - -let get_constants (dbd:HMysql.dbd) ~where uri = - let uri = escape (UriManager.string_of_uri uri) in - let positions = - match where with - | `Conclusion -> [ MetadataTypes.mainconcl_pos; MetadataTypes.inconcl_pos ] - | `Statement -> - [ MetadataTypes.mainconcl_pos; MetadataTypes.inconcl_pos; - MetadataTypes.inhyp_pos; MetadataTypes.mainhyp_pos ] - in - let query = - let pos_predicate = - String.concat " OR " - (List.map (fun pos -> sprintf "(h_position = \"%s\")" pos) positions) - in - sprintf ("SELECT h_occurrence FROM %s WHERE source=\"%s\" AND (%s) UNION "^^ - "SELECT h_occurrence FROM %s WHERE source=\"%s\" AND (%s)") - (MetadataTypes.obj_tbl ()) uri pos_predicate - MetadataTypes.library_obj_tbl uri pos_predicate - - in - let result = HMysql.exec dbd query in - let set = ref UriManagerSet.empty in - HMysql.iter result - (fun col -> - match col.(0) with - | Some uri -> set := UriManagerSet.add (UriManager.uri_of_string uri) !set - | _ -> assert false); - !set - -let at_most ~(dbd:HMysql.dbd) ?(where = `Conclusion) only u = - let inconcl = get_constants dbd ~where u in - UriManagerSet.subset inconcl only - - (* Special handling of equality. The problem is filtering out theorems just - * containing variables (e.g. all the theorems in cic:/Coq/Ring/). Really - * ad-hoc, no better solution found at the moment *) -let myspeciallist_of_facts = - [0,UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"] -let myspeciallist = - [0,UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; - (* 0,"cic:/Coq/Init/Logic/sym_eq.con"; *) - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"; - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"; - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal2.con"; - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal3.con"] - - -let compute_exactly ~(dbd:HMysql.dbd) ?(facts=false) ~where main prefixes = - List.concat - (List.map - (fun (m,s) -> - let is_eq,card = - match main with - None -> false,m - | Some main -> - (m = 0 && - UriManager.eq main - (UriManager.uri_of_string (HelmLibraryObjects.Logic.eq_XURI))), - m+1 - in - if m = 0 && is_eq then - (if facts then myspeciallist_of_facts - else myspeciallist) - else - let res = - (* this gets rid of the ~750 objects of type Set/Prop/Type *) - if card = 0 then [] - else - let must = must_of_prefix ~where main s in - match where with - | `Conclusion -> at_least ~dbd ~concl_card:(Eq card) must - | `Statement -> at_least ~dbd ~full_card:(Eq card) must - in - List.map (fun uri -> (card, uri)) res) - prefixes) - - (* critical value reached, fallback to "only" constraints *) - -let compute_with_only ~(dbd:HMysql.dbd) ?(facts=false) ?(where = `Conclusion) - main prefixes constants -= - let max_prefix_length = - match prefixes with - | [] -> assert false - | (max,_)::_ -> max in - let maximal_prefixes = - let rec filter res = function - [] -> res - | (n,s)::l when n = max_prefix_length -> filter ((n,s)::res) l - | _::_-> res in - filter [] prefixes in - let greater_than = - let all = - union - (List.map - (fun (m,s) -> - let card = if main = None then m else m + 1 in - let must = must_of_prefix ~where main s in - (let res = - match where with - | `Conclusion -> at_least ~dbd ~concl_card:(Gt card) must - | `Statement -> at_least ~dbd ~full_card:(Gt card) must - in - (* we tag the uri with m+1, for sorting purposes *) - List.map (fun uri -> (card, uri)) res)) - maximal_prefixes) - in - Printf.fprintf stderr "all: %d\n" (List.length all);flush_all (); - List.filter (function (_,uri) -> at_most ~dbd ~where constants uri) all in - let equal_to = compute_exactly ~dbd ~facts ~where main prefixes in - greater_than @ equal_to - - (* real match query implementation *) - -let cmatch ~(dbd:HMysql.dbd) ?(facts=false) t = - let (main, constants) = signature_of t in - match main with - | None -> [] - | Some (main, types) -> - (* the type of eq is not counted in constants_no *) - let types_no = List.length types in - let constants_no = UriManagerSet.cardinal constants in - if (constants_no > critical_value) then - let prefixes = prefixes just_factor t in - (match prefixes with - | Some main, all_concl -> - let all_constants = - List.fold_right UriManagerSet.add types (UriManagerSet.add main constants) - in - compute_with_only ~dbd ~facts (Some main) all_concl all_constants - | _, _ -> []) - else - (* in this case we compute all prefixes, and we do not need - to apply the only constraints *) - let prefixes = - if constants_no = 0 then - (if types_no = 0 then - Some main, [0, []] - else - Some main, [0, []; types_no, types]) - else - prefixes (constants_no+types_no+1) t - in - (match prefixes with - Some main, all_concl -> - compute_exactly ~dbd ~facts ~where:`Conclusion (Some main) all_concl - | _, _ -> []) - -let power_upto upto consts = - let l = UriManagerSet.elements consts in - List.sort (fun (n,_) (m,_) -> m - n) - (List.fold_left - (fun res a -> - let res' = - List.filter (function (n,l) -> n <= upto) - (List.map (function (n,l) -> (n+1,a::l)) res) in - res@res') - [(0,[])] l) - -let power consts = - let l = UriManagerSet.elements consts in - List.sort (fun (n,_) (m,_) -> m - n) - (List.fold_left - (fun res a -> res@(List.map (function (n,l) -> (n+1,a::l)) res)) - [(0,[])] l) - -type where = [ `Conclusion | `Statement ] - -let sigmatch ~(dbd:HMysql.dbd) ?(facts=false) ?(where = `Conclusion) - (main, constants) -= - let main,types = - match main with - None -> None,[] - | Some (main, types) -> Some main,types - in - let constants_no = UriManagerSet.cardinal constants in - (* prerr_endline (("constants_no: ")^(string_of_int constants_no)); *) - if (constants_no > critical_value) then - let subsets = - let subsets = power_upto just_factor constants in - (* let _ = prerr_endline (("subsets: ")^ - (string_of_int (List.length subsets))) in *) - let types_no = List.length types in - List.map (function (n,l) -> (n+types_no,types@l)) subsets - in - let all_constants = - let all = match main with None -> types | Some m -> m::types in - List.fold_right UriManagerSet.add all constants - in - compute_with_only ~dbd ~where main subsets all_constants - else - let subsets = - let subsets = power constants in - let types_no = List.length types in - if types_no > 0 then - (0,[]) :: List.map (function (n,l) -> (n+types_no,types@l)) subsets - else subsets - in - compute_exactly ~dbd ~facts ~where main subsets - - (* match query wrappers *) - -let cmatch'= cmatch - -let cmatch ~dbd ?(facts=false) term = - List.map snd - (List.sort - (fun x y -> Pervasives.compare (fst y) (fst x)) - (cmatch' ~dbd ~facts term)) - -let constants_of = signature_concl - diff --git a/helm/ocaml/metadata/metadataConstraints.mli b/helm/ocaml/metadata/metadataConstraints.mli deleted file mode 100644 index 63757ae47..000000000 --- a/helm/ocaml/metadata/metadataConstraints.mli +++ /dev/null @@ -1,111 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -module UriManagerSet : Set.S with type elt = UriManager.uri - - - (** @return - * main: constant in main position and, for polymorphic constants, type - * instantitation - * constants: constants appearing in term *) -type term_signature = (UriManager.uri * UriManager.uri list) option * UriManagerSet.t - -(** {2 Candidates filtering} *) - - (** @return sorted list of theorem URIs, first URIs in the least have higher - * relevance *) -val cmatch: dbd:HMysql.dbd -> ?facts:bool -> Cic.term -> UriManager.uri list - - (** as cmatch, but returned list is not sorted but rather tagged with - * relevance information: higher the tag, higher the relevance *) -val cmatch': dbd:HMysql.dbd -> ?facts:bool -> Cic.term -> (int * UriManager.uri) list - -type where = [ `Conclusion | `Statement ] (** signature matching extent *) - - (** @param where defaults to `Conclusion *) -val sigmatch: - dbd:HMysql.dbd -> - ?facts:bool -> - ?where:where -> - term_signature -> - (int * UriManager.uri) list - -(** {2 Constraint engine} *) - - (** constraing on the number of distinct constants *) -type cardinality_condition = - | Eq of int - | Gt of int - | Lt of int - -type rating_criterion = - [ `Hits (** order by number of hits, most used objects first *) - ] - -val add_constraint: - ?start:int -> - ?tables:string * string * string * string -> - int * string list * string list -> - MetadataTypes.constr -> - int * string list * string list - - (** @param concl_card cardinality condition on conclusion only - * @param full_card cardinality condition on the whole statement - * @param diff required difference between the number of different constants in - * hypothesis and the number of different constants in body - * @return list of URI satisfying given constraints *) - -val at_least: - dbd:HMysql.dbd -> - ?concl_card:cardinality_condition -> - ?full_card:cardinality_condition -> - ?diff:cardinality_condition -> - ?rating:rating_criterion -> - MetadataTypes.constr list -> - UriManager.uri list - - (** @param where defaults to `Conclusion *) -val at_most: - dbd:HMysql.dbd -> - ?where:where -> UriManagerSet.t -> - (UriManager.uri -> bool) - -val add_all_constr: - ?tbl:string -> - int * string list * string list -> - cardinality_condition option -> - cardinality_condition option -> - cardinality_condition option -> - int * string list * string list - -val exec: - dbd:HMysql.dbd -> - ?rating:[ `Hits ] -> - int * string list * string list -> - UriManager.uri list - -val signature_of: Cic.term -> term_signature -val constants_of: Cic.term -> UriManagerSet.t - diff --git a/helm/ocaml/metadata/metadataDb.ml b/helm/ocaml/metadata/metadataDb.ml deleted file mode 100644 index 457545dee..000000000 --- a/helm/ocaml/metadata/metadataDb.ml +++ /dev/null @@ -1,193 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open MetadataTypes - -open Printf - -let execute_insert dbd uri (sort_cols, rel_cols, obj_cols) = - let sort_tuples = - List.fold_left (fun s l -> match l with - | [`String a; `String b; `Int c; `String d] -> - sprintf "(\"%s\", \"%s\", %d, \"%s\")" a b c d :: s - | _ -> assert false ) - [] sort_cols - in - let rel_tuples = - List.fold_left (fun s l -> match l with - | [`String a; `String b; `Int c] -> - sprintf "(\"%s\", \"%s\", %d)" a b c :: s - | _ -> assert false) - [] rel_cols - in - let obj_tuples = List.fold_left (fun s l -> match l with - | [`String a; `String b; `String c; `Int d] -> - sprintf "(\"%s\", \"%s\", \"%s\", %d)" a b c d :: s - | [`String a; `String b; `String c; `Null] -> - sprintf "(\"%s\", \"%s\", \"%s\", %s)" a b c "NULL" :: s - | _ -> assert false) - [] obj_cols - in - if sort_tuples <> [] then - begin - let query_sort = - sprintf "INSERT %s VALUES %s;" (sort_tbl ()) (String.concat "," sort_tuples) - in - ignore (HMysql.exec dbd query_sort) - end; - if rel_tuples <> [] then - begin - let query_rel = - sprintf "INSERT %s VALUES %s;" (rel_tbl ()) (String.concat "," rel_tuples) - in - ignore (HMysql.exec dbd query_rel) - end; - if obj_tuples <> [] then - begin - let query_obj = - sprintf "INSERT %s VALUES %s;" (obj_tbl ()) (String.concat "," obj_tuples) - in - ignore (HMysql.exec dbd query_obj) - end - - -let count_distinct position l = - MetadataConstraints.UriManagerSet.cardinal - (List.fold_left (fun acc d -> - match position with - | `Conclusion -> - (match d with - | `Obj (name,`InConclusion) - | `Obj (name,`MainConclusion _ ) -> - MetadataConstraints.UriManagerSet.add name acc - | _ -> acc) - | `Hypothesis -> - (match d with - | `Obj (name,`InHypothesis) - | `Obj (name,`MainHypothesis _) -> - MetadataConstraints.UriManagerSet.add name acc - | _ -> acc) - | `Statement -> - (match d with - | `Obj (name,`InBody) -> acc - | `Obj (name,_) -> MetadataConstraints.UriManagerSet.add name acc - | _ -> acc) - ) MetadataConstraints.UriManagerSet.empty l) - -let insert_const_no ~dbd l = - let data = - List.fold_left - (fun acc (uri,_,metadata) -> - let no_concl = count_distinct `Conclusion metadata in - let no_hyp = count_distinct `Hypothesis metadata in - let no_full = count_distinct `Statement metadata in - (sprintf "(\"%s\", %d, %d, %d)" - (UriManager.string_of_uri uri) no_concl no_hyp no_full) :: acc - ) [] l in - let insert = - sprintf "INSERT INTO %s VALUES %s" (count_tbl ()) (String.concat "," data) - in - ignore (HMysql.exec dbd insert) - -let insert_name ~dbd l = - let data = - List.fold_left - (fun acc (uri,name,_) -> - (sprintf "(\"%s\", \"%s\")" (UriManager.string_of_uri uri) name) :: acc - ) [] l in - let insert = - sprintf "INSERT INTO %s VALUES %s" (name_tbl ()) (String.concat "," data) - in - ignore (HMysql.exec dbd insert) - -type columns = - MetadataPp.t list list * MetadataPp.t list list * MetadataPp.t list list - - (* TODO ZACK: verify if an object has already been indexed *) -let already_indexed _ = false - -(***** TENTATIVE HACK FOR THE DB SLOWDOWN - BEGIN *******) -let analyze_index = ref 0 -let eventually_analyze dbd = - incr analyze_index; - if !analyze_index > 30 then - begin - let analyze t = "OPTIMIZE TABLE " ^ t ^ ";" in - List.iter - (fun table -> ignore (HMysql.exec dbd (analyze table))) - [name_tbl (); rel_tbl (); sort_tbl (); obj_tbl(); count_tbl()] - end - -(***** TENTATIVE HACK FOR THE DB SLOWDOWN - END *******) - -let index_obj ~dbd ~uri = - if not (already_indexed uri) then begin - eventually_analyze dbd; - let metadata = MetadataExtractor.compute_obj uri in - let uri = UriManager.string_of_uri uri in - let columns = MetadataPp.columns_of_metadata metadata in - execute_insert dbd uri (columns :> columns); - insert_const_no ~dbd metadata; - insert_name ~dbd metadata - end - - -let tables_to_clean = - [sort_tbl; rel_tbl; obj_tbl; name_tbl; count_tbl] - -let clean ~(dbd:HMysql.dbd) = - let owned_uris = (* list of uris in list-of-columns format *) - let query = sprintf "SELECT source FROM %s" (name_tbl ()) in - let result = HMysql.exec dbd query in - let uris = HMysql.map result (fun cols -> - match cols.(0) with - | Some src -> src - | None -> assert false) in - (* and now some stuff to remove #xpointers and duplicates *) - uris - in - let del_from tbl = - let query s = - sprintf "DELETE FROM %s WHERE source LIKE \"%s%%\"" (tbl ()) s - in - List.iter - (fun source_col -> ignore (HMysql.exec dbd (query source_col))) - owned_uris - in - List.iter del_from tables_to_clean; - owned_uris - -let unindex ~dbd ~uri = - let uri = UriManager.string_of_uri uri in - let del_from tbl = - let query tbl = - sprintf "DELETE FROM %s WHERE source LIKE \"%s%%\"" (tbl ()) uri - in - ignore (HMysql.exec dbd (query tbl)) - in - List.iter del_from tables_to_clean - diff --git a/helm/ocaml/metadata/metadataDb.mli b/helm/ocaml/metadata/metadataDb.mli deleted file mode 100644 index 86820aafb..000000000 --- a/helm/ocaml/metadata/metadataDb.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - - - -val index_obj: dbd:HMysql.dbd -> uri:UriManager.uri -> unit - -(* TODO Zack indexing of variables and (perhaps?) incomplete proofs *) - - (** remove from the db all metadata pertaining to a given owner - * @return list of uris removed from the db *) -val clean: dbd:HMysql.dbd -> string list - -val unindex: dbd:HMysql.dbd -> uri:UriManager.uri -> unit - -val count_distinct: - [`Conclusion | `Hypothesis | `Statement ] -> - MetadataTypes.metadata list -> - int diff --git a/helm/ocaml/metadata/metadataExtractor.ml b/helm/ocaml/metadata/metadataExtractor.ml deleted file mode 100644 index 4fbae1ba7..000000000 --- a/helm/ocaml/metadata/metadataExtractor.ml +++ /dev/null @@ -1,350 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open MetadataTypes - -let is_main_pos = function - | `MainConclusion _ - | `MainHypothesis _ -> true - | _ -> false - -let main_pos (pos: position): main_position = - match pos with - | `MainConclusion depth -> `MainConclusion depth - | `MainHypothesis depth -> `MainHypothesis depth - | _ -> assert false - -let next_pos = function - | `MainConclusion _ -> `InConclusion - | `MainHypothesis _ -> `InHypothesis - | pos -> pos - -let string_of_uri = UriManager.string_of_uri - -module OrderedMetadata = - struct - type t = MetadataTypes.metadata - let compare m1 m2 = (* ignore universes in Cic.Type sort *) - match (m1, m2) with - | `Sort (Cic.Type _, pos1), `Sort (Cic.Type _, pos2) -> - Pervasives.compare pos1 pos2 - | _ -> Pervasives.compare m1 m2 - end - -module MetadataSet = Set.Make (OrderedMetadata) -module UriManagerSet = UriManager.UriSet - -module S = MetadataSet - -let unopt = function Some x -> x | None -> assert false - -let incr_depth = function - | `MainConclusion (Some (Eq depth)) -> `MainConclusion (Some (Eq (depth + 1))) - | `MainHypothesis (Some (Eq depth)) -> `MainHypothesis (Some (Eq (depth + 1))) - | _ -> assert false - -let var_has_body uri = - match CicEnvironment.get_obj CicUniv.empty_ugraph uri with - | Cic.Variable (_, Some body, _, _, _), _ -> true - | _ -> false - -let compute_term pos term = - let rec aux (pos: position) set = function - | Cic.Var (uri, subst) when var_has_body uri -> - (* handles variables with body as constants *) - aux pos set (Cic.Const (uri, subst)) - | Cic.Rel _ - | Cic.Var _ -> - if is_main_pos pos then - S.add (`Rel (main_pos pos)) set - else - set - | Cic.Meta (_, local_context) -> - List.fold_left - (fun set context -> - match context with - | None -> set - | Some term -> aux (next_pos pos) set term) - set - local_context - | Cic.Sort sort -> - if is_main_pos pos then - S.add (`Sort (sort, main_pos pos)) set - else - set - | Cic.Implicit _ -> assert false - | Cic.Cast (term, ty) -> - (* TODO consider also ty? *) - aux pos set term - | Cic.Prod (_, source, target) -> - (match pos with - | `MainConclusion _ -> - let set = aux (`MainHypothesis (Some (Eq 0))) set source in - aux (incr_depth pos) set target - | `MainHypothesis _ -> - let set = aux `InHypothesis set source in - aux (incr_depth pos) set target - | `InConclusion - | `InHypothesis - | `InBody -> - let set = aux pos set source in - aux pos set target) - | Cic.Lambda (_, source, target) -> - (*assert (not (is_main_pos pos));*) - let set = aux (next_pos pos) set source in - aux (next_pos pos) set target - | Cic.LetIn (_, term, target) -> - if is_main_pos pos then - aux pos set (CicSubstitution.subst term target) - else - let set = aux pos set term in - aux pos set target - | Cic.Appl [] -> assert false - | Cic.Appl (hd :: tl) -> - let set = aux pos set hd in - List.fold_left - (fun set term -> aux (next_pos pos) set term) - set tl - | Cic.Const (uri, subst) -> - let set = S.add (`Obj (uri, pos)) set in - List.fold_left - (fun set (_, term) -> aux (next_pos pos) set term) - set subst - | Cic.MutInd (uri, typeno, subst) -> - let uri = UriManager.uri_of_uriref uri typeno None in - let set = S.add (`Obj (uri, pos)) set in - List.fold_left (fun set (_, term) -> aux (next_pos pos) set term) - set subst - | Cic.MutConstruct (uri, typeno, consno, subst) -> - let uri = UriManager.uri_of_uriref uri typeno (Some consno) in - let set = S.add (`Obj (uri, pos)) set in - List.fold_left (fun set (_, term) -> aux (next_pos pos) set term) - set subst - | Cic.MutCase (uri, _, outtype, term, pats) -> - let pos = next_pos pos in - let set = aux pos set term in - let set = aux pos set outtype in - List.fold_left (fun set term -> aux pos set term) set pats - | Cic.Fix (_, funs) -> - let pos = next_pos pos in - List.fold_left - (fun set (_, _, ty, body) -> - let set = aux pos set ty in - aux pos set body) - set funs - | Cic.CoFix (_, funs) -> - let pos = next_pos pos in - List.fold_left - (fun set (_, ty, body) -> - let set = aux pos set ty in - aux pos set body) - set funs - in - aux pos S.empty term - -module OrderedInt = -struct - type t = int - let compare = Pervasives.compare -end - -module IntSet = Set.Make (OrderedInt) - -let compute_metas term = - let rec aux in_hyp ((concl_metas, hyp_metas) as acc) cic = - match cic with - | Cic.Rel _ - | Cic.Sort _ - | Cic.Var _ -> acc - | Cic.Meta (no, local_context) -> - let acc = - if in_hyp then - (concl_metas, IntSet.add no hyp_metas) - else - (IntSet.add no concl_metas, hyp_metas) - in - List.fold_left - (fun set context -> - match context with - | None -> set - | Some term -> aux in_hyp set term) - acc - local_context - | Cic.Implicit _ -> assert false - | Cic.Cast (term, ty) -> - (* TODO consider also ty? *) - aux in_hyp acc term - | Cic.Prod (_, source, target) -> - if in_hyp then - let acc = aux in_hyp acc source in - aux in_hyp acc target - else - let acc = aux true acc source in - aux in_hyp acc target - | Cic.Lambda (_, source, target) -> - let acc = aux in_hyp acc source in - aux in_hyp acc target - | Cic.LetIn (_, term, target) -> - aux in_hyp acc (CicSubstitution.subst term target) - | Cic.Appl [] -> assert false - | Cic.Appl (hd :: tl) -> - let acc = aux in_hyp acc hd in - List.fold_left (fun acc term -> aux in_hyp acc term) acc tl - | Cic.Const (_, subst) - | Cic.MutInd (_, _, subst) - | Cic.MutConstruct (_, _, _, subst) -> - List.fold_left (fun acc (_, term) -> aux in_hyp acc term) acc subst - | Cic.MutCase (uri, _, outtype, term, pats) -> - let acc = aux in_hyp acc term in - let acc = aux in_hyp acc outtype in - List.fold_left (fun acc term -> aux in_hyp acc term) acc pats - | Cic.Fix (_, funs) -> - List.fold_left - (fun acc (_, _, ty, body) -> - let acc = aux in_hyp acc ty in - aux in_hyp acc body) - acc funs - | Cic.CoFix (_, funs) -> - List.fold_left - (fun acc (_, ty, body) -> - let acc = aux in_hyp acc ty in - aux in_hyp acc body) - acc funs - in - aux false (IntSet.empty, IntSet.empty) term - - (** type of inductiveType *) -let compute_type pos uri typeno (name, _, ty, constructors) = - let consno = ref 0 in - let type_metadata = - (UriManager.uri_of_uriref uri typeno None, name, (compute_term pos ty)) - in - let constructors_metadata = - List.map - (fun (name, term) -> - incr consno; - let uri = UriManager.uri_of_uriref uri typeno (Some !consno) in - (uri, name, (compute_term pos term))) - constructors - in - type_metadata :: constructors_metadata - -let compute_ind pos ~uri ~types = - let idx = ref ~-1 in - List.map (fun ty -> incr idx; compute_type pos uri !idx ty) types - -let compute (pos:position) ~body ~ty = - let type_metadata = compute_term pos ty in - let body_metadata = - match body with - | None -> S.empty - | Some body -> compute_term `InBody body - in - let uris = - S.fold - (fun metadata uris -> - match metadata with - | `Obj (uri, _) -> UriManagerSet.add uri uris - | _ -> uris) - type_metadata UriManagerSet.empty - in - S.union - (S.filter - (function - | `Obj (uri, _) when UriManagerSet.mem uri uris -> false - | _ -> true) - body_metadata) - type_metadata - -let depth_offset params = - let non p x = not (p x) in - List.length (List.filter (non var_has_body) params) - -let rec compute_var pos uri = - let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - | Cic.Variable (_, Some _, _, _, _) -> S.empty - | Cic.Variable (_, None, ty, params, _) -> - let var_metadata = - List.fold_left - (fun metadata uri -> - S.union metadata (compute_var (next_pos pos) uri)) - S.empty - params - in - (match pos with - | `MainHypothesis (Some (Eq 0)) -> - let pos = `MainHypothesis (Some (Eq (depth_offset params))) in - let ty_metadata = compute_term pos ty in - S.union ty_metadata var_metadata - | `InHypothesis -> - let ty_metadata = compute_term pos ty in - S.union ty_metadata var_metadata - | _ -> assert false) - | _ -> assert false - -let compute_obj uri = - let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - | Cic.Variable (_, body, ty, params, _) - | Cic.Constant (_, body, ty, params, _) -> - let pos = `MainConclusion (Some (Eq (depth_offset params))) in - let metadata = compute pos ~body ~ty in - let var_metadata = - List.fold_left - (fun metadata uri -> - S.union metadata (compute_var (`MainHypothesis (Some (Eq 0))) uri)) - S.empty - params - in - [ uri, - UriManager.name_of_uri uri, - S.union metadata var_metadata ] - | Cic.InductiveDefinition (types, params, _, _) -> - let pos = `MainConclusion(Some (Eq (depth_offset params))) in - let metadata = compute_ind pos ~uri ~types in - let var_metadata = - List.fold_left - (fun metadata uri -> - S.union metadata (compute_var (`MainHypothesis (Some (Eq 0))) uri)) - S.empty params - in - List.fold_left - (fun acc m -> - (List.map (fun (uri,name,md) -> (uri,name,S.union md var_metadata)) m) - @ acc) - [] metadata - | Cic.CurrentProof _ -> assert false - -let compute_obj uri = - List.map (fun (u, n, md) -> (u, n, S.elements md)) (compute_obj uri) - -let compute ~body ~ty = - S.elements (compute (`MainConclusion (Some (Eq 0))) ~body ~ty) - diff --git a/helm/ocaml/metadata/metadataExtractor.mli b/helm/ocaml/metadata/metadataExtractor.mli deleted file mode 100644 index 68af269a9..000000000 --- a/helm/ocaml/metadata/metadataExtractor.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -val compute: - body:Cic.term option -> - ty:Cic.term -> - MetadataTypes.metadata list - - (** @return tuples *) -val compute_obj: - UriManager.uri -> - (UriManager.uri * string * MetadataTypes.metadata list) list - -module IntSet: Set.S with type elt = int - - (** given a term, returns a pair of sets corresponding respectively to the set - * of meta numbers occurring in term's conclusion and the set of meta numbers - * occurring in term's hypotheses *) -val compute_metas: Cic.term -> IntSet.t * IntSet.t - diff --git a/helm/ocaml/metadata/metadataPp.ml b/helm/ocaml/metadata/metadataPp.ml deleted file mode 100644 index 373ec540f..000000000 --- a/helm/ocaml/metadata/metadataPp.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -open MetadataTypes - -let pp_relation r = - match r with - | Eq i -> sprintf "= %d" i - | Ge i -> sprintf ">= %d" i - | Gt i -> sprintf "> %d" i - | Le i -> sprintf "<= %d" i - | Lt i -> sprintf "< %d" i - -let pp_position = function - | `MainConclusion (Some d) -> sprintf "MainConclusion(%s)" (pp_relation d) - | `MainConclusion None -> sprintf "MainConclusion" - | `MainHypothesis (Some d) -> sprintf "MainHypothesis(%s)" (pp_relation d) - | `MainHypothesis None -> "MainHypothesis" - | `InConclusion -> "InConclusion" - | `InHypothesis -> "InHypothesis" - | `InBody -> "InBody" - -let pp_position_tag = function - | `MainConclusion _ -> mainconcl_pos - | `MainHypothesis _ -> mainhyp_pos - | `InConclusion -> inconcl_pos - | `InHypothesis -> inhyp_pos - | `InBody -> inbody_pos - -let columns_of_position pos = - match pos with - | `MainConclusion (Some (Eq d)) -> `String mainconcl_pos, `Int d - | `MainConclusion None -> `String mainconcl_pos, `Null - | `MainHypothesis (Some (Eq d)) -> `String mainhyp_pos, `Int d - | `MainHypothesis None -> `String mainhyp_pos, `Null - | `InConclusion -> `String inconcl_pos, `Null - | `InHypothesis -> `String inhyp_pos, `Null - | `InBody -> `String inbody_pos, `Null - | _ -> assert false - -(* -let metadata_ns = "http://www.cs.unibo.it/helm/schemas/schema-helm" -let uri_of_pos pos = String.concat "#" [metadata_ns; pp_position pos] -*) - -type t = [ `Int of int | `String of string | `Null ] - -let columns_of_metadata_aux ~about metadata = - let sort s = `String (CicPp.ppsort s) in - let source = `String (UriManager.string_of_uri about) in - let occurrence u = `String (UriManager.string_of_uri u) in - List.fold_left - (fun (sort_cols, rel_cols, obj_cols) metadata -> - match metadata with - | `Sort (s, p) -> - let (p, d) = columns_of_position (p :> position) in - [source; p; d; sort s] :: sort_cols, rel_cols, obj_cols - | `Rel p -> - let (p, d) = columns_of_position (p :> position) in - sort_cols, [source; p; d] :: rel_cols, obj_cols - | `Obj (o, p) -> - let (p, d) = columns_of_position p in - sort_cols, rel_cols, - [source; occurrence o; p; d] :: obj_cols) - ([], [], []) metadata - -let columns_of_metadata metadata = - List.fold_left - (fun (sort_cols, rel_cols, obj_cols) (uri, _, metadata) -> - let (s, r, o) = columns_of_metadata_aux ~about:uri metadata in - (List.append sort_cols s, List.append rel_cols r, List.append obj_cols o)) - ([], [], []) metadata - -let pp_constr = - function - | `Sort (sort, p) -> - sprintf "Sort %s; [%s]" - (CicPp.ppsort sort) (String.concat ";" (List.map pp_position p)) - | `Rel p -> sprintf "Rel [%s]" (String.concat ";" (List.map pp_position p)) - | `Obj (uri, p) -> sprintf "Obj %s; [%s]" - (UriManager.string_of_uri uri) (String.concat ";" (List.map pp_position p)) - -(* -let pp_columns ?(sep = "\n") (sort_cols, rel_cols, obj_cols) = - String.concat sep - ([ "Sort" ] @ List.map Dbi.sdebug (sort_cols :> Dbi.sql_t list list) @ - [ "Rel" ] @ List.map Dbi.sdebug (rel_cols :> Dbi.sql_t list list) @ - [ "Obj" ] @ List.map Dbi.sdebug (obj_cols :> Dbi.sql_t list list)) -*) - - diff --git a/helm/ocaml/metadata/metadataPp.mli b/helm/ocaml/metadata/metadataPp.mli deleted file mode 100644 index cffb24c48..000000000 --- a/helm/ocaml/metadata/metadataPp.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(** metadata -> string *) - -val pp_position: MetadataTypes.position -> string -val pp_position_tag: MetadataTypes.position -> string -val pp_constr: MetadataTypes.constr -> string - -(** Pretty printer and OCamlDBI friendly interface *) - -type t = - [ `Int of int - | `String of string - | `Null ] - - (** @return columns for Sort, Rel, and Obj respectively *) -val columns_of_metadata: - (UriManager.uri * string * MetadataTypes.metadata list) list -> - t list list * t list list * t list list - -(* -val pp_columns: ?sep:string -> t list list * t list list * t list list -> string -*) - -val pp_relation: MetadataTypes.relation -> string - diff --git a/helm/ocaml/metadata/metadataTypes.ml b/helm/ocaml/metadata/metadataTypes.ml deleted file mode 100644 index e186b377a..000000000 --- a/helm/ocaml/metadata/metadataTypes.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let position_prefix = "http://www.cs.unibo.it/helm/schemas/schema-helm#" -(* let position_prefix = "" *) - -let inconcl_pos = position_prefix ^ "InConclusion" -let mainconcl_pos = position_prefix ^ "MainConclusion" -let mainhyp_pos = position_prefix ^ "MainHypothesis" -let inhyp_pos = position_prefix ^ "InHypothesis" -let inbody_pos = position_prefix ^ "InBody" - -type relation = - | Eq of int - | Le of int - | Lt of int - | Ge of int - | Gt of int - -type main_position = - [ `MainConclusion of relation option (* Pi depth *) - | `MainHypothesis of relation option (* Pi depth *) - ] - -type position = - [ main_position - | `InConclusion - | `InHypothesis - | `InBody - ] - -type pi_depth = int - -type metadata = - [ `Sort of Cic.sort * main_position - | `Rel of main_position - | `Obj of UriManager.uri * position - ] - -type constr = - [ `Sort of Cic.sort * main_position list - | `Rel of main_position list - | `Obj of UriManager.uri * position list - ] - -let constr_of_metadata: metadata -> constr = function - | `Sort (sort, pos) -> `Sort (sort, [pos]) - | `Rel pos -> `Rel [pos] - | `Obj (uri, pos) -> `Obj (uri, [pos]) - - (** the name of the tables in the DB *) -let sort_tbl_original = "refSort" -let rel_tbl_original = "refRel" -let obj_tbl_original = "refObj" -let name_tbl_original = "objectName" -let count_tbl_original = "count" -let hits_tbl_original = "hits" - - (** the names currently used *) -let sort_tbl_real = ref sort_tbl_original -let rel_tbl_real = ref rel_tbl_original -let obj_tbl_real = ref obj_tbl_original -let name_tbl_real = ref name_tbl_original -let count_tbl_real = ref count_tbl_original - - (** the exported symbols *) -let sort_tbl () = ! sort_tbl_real ;; -let rel_tbl () = ! rel_tbl_real ;; -let obj_tbl () = ! obj_tbl_real ;; -let name_tbl () = ! name_tbl_real ;; -let count_tbl () = ! count_tbl_real ;; - - (** to use the owned tables *) -let ownerize_tables owner = - sort_tbl_real := ( sort_tbl_original ^ "_" ^ owner) ; - rel_tbl_real := ( rel_tbl_original ^ "_" ^ owner) ; - obj_tbl_real := ( obj_tbl_original ^ "_" ^ owner) ; - name_tbl_real := ( name_tbl_original ^ "_" ^ owner); - count_tbl_real := ( count_tbl_original ^ "_" ^ owner) -;; - -let library_sort_tbl = sort_tbl_original -let library_rel_tbl = rel_tbl_original -let library_obj_tbl = obj_tbl_original -let library_name_tbl = name_tbl_original -let library_count_tbl = count_tbl_original -let library_hits_tbl = hits_tbl_original - -let are_tables_ownerized () = - sort_tbl () <> library_sort_tbl - diff --git a/helm/ocaml/metadata/metadataTypes.mli b/helm/ocaml/metadata/metadataTypes.mli deleted file mode 100644 index f86ff84f5..000000000 --- a/helm/ocaml/metadata/metadataTypes.mli +++ /dev/null @@ -1,84 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -val inconcl_pos : string -val mainconcl_pos : string -val mainhyp_pos : string -val inhyp_pos : string -val inbody_pos : string - -type relation = - | Eq of int - | Le of int - | Lt of int - | Ge of int - | Gt of int - -type main_position = - [ `MainConclusion of relation option (* Pi depth *) - | `MainHypothesis of relation option (* Pi depth *) - ] - -type position = - [ main_position - | `InConclusion - | `InHypothesis - | `InBody - ] - -type pi_depth = int - -type metadata = - [ `Sort of Cic.sort * main_position - | `Rel of main_position - | `Obj of UriManager.uri * position - ] - -type constr = - [ `Sort of Cic.sort * main_position list - | `Rel of main_position list - | `Obj of UriManager.uri * position list - ] - -val constr_of_metadata: metadata -> constr - - (** invoke this function to set the current owner. Afterwards the functions - * below will return the name of the table of the set owner *) -val ownerize_tables : string -> unit -val are_tables_ownerized : unit -> bool - -val sort_tbl: unit -> string -val rel_tbl: unit -> string -val obj_tbl: unit -> string -val name_tbl: unit -> string -val count_tbl: unit -> string - -val library_sort_tbl: string -val library_rel_tbl: string -val library_obj_tbl: string -val library_name_tbl: string -val library_count_tbl: string -val library_hits_tbl: string - diff --git a/helm/ocaml/metadata/sqlStatements.ml b/helm/ocaml/metadata/sqlStatements.ml deleted file mode 100644 index a08073965..000000000 --- a/helm/ocaml/metadata/sqlStatements.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf;; -type tbl = [ `RefObj| `RefSort| `RefRel| `ObjectName| `Hits| `Count] - -(* TABLES *) - -let sprintf_refObj_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) binary not null, - h_occurrence varchar(255) binary not null, - h_position varchar(62) binary not null, - h_depth integer -);" name] - -let sprintf_refSort_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) binary not null, - h_position varchar(62) binary not null, - h_depth integer not null, - h_sort varchar(5) binary not null -);" name] - -let sprintf_refRel_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) binary not null, - h_position varchar(62) binary not null, - h_depth integer not null -);" name] - -let sprintf_objectName_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) binary not null, - value varchar(255) binary not null -);" name] - -let sprintf_hits_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) binary not null, - no integer not null -);" name] - -let sprintf_count_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) binary unique not null, - conclusion smallint(6) not null, - hypothesis smallint(6) not null, - statement smallint(6) not null -);" name] - -let sprintf_refObj_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_refSort_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_refRel_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_objectName_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_hits_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_count_drop name = [sprintf "DROP TABLE %s;" name] - -(* INDEXES *) - -let sprintf_refObj_index name = [ -sprintf "CREATE INDEX %s_index ON %s (source(219),h_occurrence(219),h_position);" name name; -sprintf "CREATE INDEX %s_occurrence ON %s (h_occurrence);" name name ] - -let sprintf_refSort_index name = [ -sprintf "CREATE INDEX %s_index ON %s (source,h_sort,h_position,h_depth);" name name] - -let sprintf_objectName_index name = [ -sprintf "CREATE INDEX %s_value ON %s (value);" name name] - -let sprintf_hits_index name = [ -sprintf "CREATE INDEX %s_source ON %s (source);" name name ; -sprintf "CREATE INDEX %s_no ON %s (no);" name name] - -let sprintf_count_index name = [ -sprintf "CREATE INDEX %s_conclusion ON %s (conclusion);" name name; -sprintf "CREATE INDEX %s_hypothesis ON %s (hypothesis);" name name; -sprintf "CREATE INDEX %s_statement ON %s (statement);" name name] - -let sprintf_refRel_index name = [ -sprintf "CREATE INDEX %s_index ON %s (source,h_position,h_depth);" name name] - -let sprintf_refObj_index_drop name = [ -sprintf "DROP INDEX %s_index ON %s;" name name ] - -let sprintf_refSort_index_drop name = [ -sprintf "DROP INDEX %s_index ON %s;" name name ] - -let sprintf_objectName_index_drop name = [ -sprintf "DROP INDEX %s_value ON %s;" name name] - -let sprintf_hits_index_drop name = [ -sprintf "DROP INDEX %s_source ON %s;" name name ; -sprintf "DROP INDEX %s_no ON %s;" name name] - -let sprintf_count_index_drop name = [ -sprintf "DROP INDEX %s_source ON %s;" name name; -sprintf "DROP INDEX %s_conclusion ON %s;" name name; -sprintf "DROP INDEX %s_hypothesis ON %s;" name name; -sprintf "DROP INDEX %s_statement ON %s;" name name] - -let sprintf_refRel_index_drop name = [ -sprintf "DROP INDEX %s_index ON %s;" name name] - -let sprintf_rename_table oldname newname = [ -sprintf "RENAME TABLE %s TO %s;" oldname newname -] - - -(* FUNCTIONS *) - -let get_table_format t named = - match t with - | `RefObj -> sprintf_refObj_format named - | `RefSort -> sprintf_refSort_format named - | `RefRel -> sprintf_refRel_format named - | `ObjectName -> sprintf_objectName_format named - | `Hits -> sprintf_hits_format named - | `Count -> sprintf_count_format named - -let get_index_format t named = - match t with - | `RefObj -> sprintf_refObj_index named - | `RefSort -> sprintf_refSort_index named - | `RefRel -> sprintf_refRel_index named - | `ObjectName -> sprintf_objectName_index named - | `Hits -> sprintf_hits_index named - | `Count -> sprintf_count_index named - -let get_table_drop t named = - match t with - | `RefObj -> sprintf_refObj_drop named - | `RefSort -> sprintf_refSort_drop named - | `RefRel -> sprintf_refRel_drop named - | `ObjectName -> sprintf_objectName_drop named - | `Hits -> sprintf_hits_drop named - | `Count -> sprintf_count_drop named - -let get_index_drop t named = - match t with - | `RefObj -> sprintf_refObj_index_drop named - | `RefSort -> sprintf_refSort_index_drop named - | `RefRel -> sprintf_refRel_index_drop named - | `ObjectName -> sprintf_objectName_index_drop named - | `Hits -> sprintf_hits_index_drop named - | `Count -> sprintf_count_index_drop named - -let create_tables l = - List.fold_left (fun s (name,table) -> s @ get_table_format table name) [] l - -let create_indexes l = - List.fold_left (fun s (name,table) -> s @ get_index_format table name) [] l - -let drop_tables l = - List.fold_left (fun s (name,table) -> s @ get_table_drop table name) [] l - -let drop_indexes l = - List.fold_left (fun s (name,table) -> s @ get_index_drop table name) [] l - -let rename_tables l = - List.fold_left (fun s (o,n) -> s @ sprintf_rename_table o n) [] l - -let fill_hits refObj hits = - [ sprintf - "INSERT INTO %s - SELECT h_occurrence, COUNT(source) - FROM %s - GROUP BY h_occurrence;" - hits refObj ] - - diff --git a/helm/ocaml/metadata/sqlStatements.mli b/helm/ocaml/metadata/sqlStatements.mli deleted file mode 100644 index 9f9af55ef..000000000 --- a/helm/ocaml/metadata/sqlStatements.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** table shape kinds *) -type tbl = [ `RefObj| `RefSort| `RefRel| `ObjectName| `Hits| `Count] - -(** all functions below return either an SQL statement or a list of SQL - * statements. - * For functions taking as argument (string * tbl) list, the meaning is a list - * of pairs ; where the type specify the desired kind of - * table and name the desired name (e.g. create a `RefObj like table name - * refObj_NEW) *) - -val create_tables: (string * tbl) list -> string list -val create_indexes: (string * tbl) list -> string list -val drop_tables: (string * tbl) list -> string list -val drop_indexes: (string * tbl) list -> string list -val rename_tables: (string * string) list -> string list - -(** @param refObj name of the refObj table - * @param hits name of the hits table *) -val fill_hits: string -> string -> string list - diff --git a/helm/ocaml/metadata/table_creator/.depend b/helm/ocaml/metadata/table_creator/.depend deleted file mode 100644 index 1cf113d91..000000000 --- a/helm/ocaml/metadata/table_creator/.depend +++ /dev/null @@ -1,4 +0,0 @@ -sql.cmo: sql.cmi -sql.cmx: sql.cmi -table_creator.cmo: sql.cmi -table_creator.cmx: sql.cmx diff --git a/helm/ocaml/metadata/table_creator/Makefile b/helm/ocaml/metadata/table_creator/Makefile deleted file mode 100644 index c54e52d4a..000000000 --- a/helm/ocaml/metadata/table_creator/Makefile +++ /dev/null @@ -1,35 +0,0 @@ -REQUIRES = mysql helm-metadata - -INTERFACE_FILES = -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = \ - table_creator table_creator.opt table_destructor table_destructor.opt - -all: table_creator table_destructor - @echo -n -opt: table_creator.opt table_destructor.opt - @echo -n - -table_creator: table_creator.ml ../metadata.cma - @echo " OCAMLC $<" - @$(OCAMLFIND) ocamlc \ - -thread -package mysql,helm-metadata -linkpkg -o $@ $< - -table_destructor: table_creator - @ln -f $< $@ - -table_creator.opt: table_creator.ml ../metadata.cmxa - @echo " OCAMLOPT $<" - @$(OCAMLFIND) ocamlopt \ - -thread -package mysql,helm-metadata -linkpkg -o $@ $< - -table_destructor.opt: table_creator.opt - @ln -f $< $@ - -clean: - rm -f *.cm[iox] *.a *.o - rm -f table_creator table_creator.opt table_destructor table_destructor.opt - -include .depend -include ../../../Makefile.defs diff --git a/helm/ocaml/metadata/table_creator/sync_db.sh b/helm/ocaml/metadata/table_creator/sync_db.sh deleted file mode 100755 index 7b201382a..000000000 --- a/helm/ocaml/metadata/table_creator/sync_db.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/sh - -# sync metadata from a source database (usually "mowgli") to a target one -# (usually "matita") -# Created: Fri, 13 May 2005 13:50:16 +0200 zacchiro -# Last-Modified: Fri, 13 May 2005 13:50:16 +0200 zacchiro - -SOURCE_DB="mowgli" -TARGET_DB="matita" -MYSQL_FLAGS="-u helm -h localhost" - -MYSQL="mysql $MYSQL_FLAGS -f" -MYSQLDUMP="mysqldump $MYSQL_FLAGS" -MYSQLRESTORE="mysqlrestore $MYSQL_FLAGS" -TABLES=`./table_creator list all` -DUMP="${SOURCE_DB}_dump.gz" - -echo "Dumping source db $SOURCE_DB ..." -$MYSQLDUMP $SOURCE_DB $TABLES | gzip -c > $DUMP -echo "Destroying old tables in target db $TARGET_DB ..." -./table_destructor table all | $MYSQL $TARGET_DB -echo "Creating table structure in target db $TARGET_DB ..." -echo "Filling target db $TARGET_DB ..." -zcat $DUMP | $MYSQL $TARGET_DB -./table_creator index all | $MYSQL $TARGET_DB -rm $DUMP -echo "Done." - diff --git a/helm/ocaml/metadata/table_creator/table_creator.ml b/helm/ocaml/metadata/table_creator/table_creator.ml deleted file mode 100644 index 423edfb27..000000000 --- a/helm/ocaml/metadata/table_creator/table_creator.ml +++ /dev/null @@ -1,83 +0,0 @@ - -open Printf - -let map = - (MetadataTypes.library_obj_tbl,`RefObj) :: - (MetadataTypes.library_sort_tbl,`RefSort) :: - (MetadataTypes.library_rel_tbl,`RefRel) :: - (MetadataTypes.library_name_tbl,`ObjectName) :: - (MetadataTypes.library_hits_tbl,`Hits) :: - (MetadataTypes.library_count_tbl,`Count) :: [] - -let usage argv_o = - prerr_string "\nusage:"; - prerr_string ("\t" ^ argv_o ^ " what tablename[=rename]\n"); - prerr_string ("\t" ^ argv_o ^ " what all\n\n"); - prerr_endline "what:"; - prerr_endline "\tlist\tlist table names"; - prerr_endline "\ttable\toutput SQL regarding tables"; - prerr_endline "\tindex\toutput SQL regarding indexes"; - prerr_endline "\tfill\toutput SQL filling tables (only \"hits\" supported)\n"; - prerr_string "known tables:\n\t"; - List.iter (fun (n,_) -> prerr_string (" " ^ n)) map; - prerr_endline "\n" - -let eq_RE = Str.regexp "=" - -let parse_args l = - List.map (fun s -> - let parts = Str.split eq_RE s in - let len = List.length parts in - assert (len = 1 || len = 2); - if len = 1 then (s,s) else (List.nth parts 0, List.nth parts 1)) - l - -let destructor_RE = Str.regexp "table_destructor\\(\\|\\.opt\\)$" - -let am_i_destructor () = - try - let _ = Str.search_forward destructor_RE Sys.argv.(0) 0 in true - with Not_found -> false - -let main () = - let len = Array.length Sys.argv in - if len < 3 then - begin - usage Sys.argv.(0); - exit 1 - end - else - begin - let tab,idx,fill = - if am_i_destructor () then - (SqlStatements.drop_tables,SqlStatements.drop_indexes, - fun _ t -> [sprintf "DELETE * FROM %s;" t]) - else - (SqlStatements.create_tables,SqlStatements.create_indexes, - SqlStatements.fill_hits) - in - let from = 2 in - let what = - match Sys.argv.(1) with - | "list" -> `List - | "index" -> `Index - | "table" -> `Table - | "fill" -> `Fill - | _ -> failwith "what must be one of \"index\", \"table\", \"fill\"" - in - let todo = Array.to_list (Array.sub Sys.argv from (len - from)) in - let todo = match todo with ["all"] -> List.map fst map | todo -> todo in - let todo = parse_args todo in - let todo = List.map (fun (x,name) -> name, (List.assoc x map)) todo in - match what with - | `Index -> print_endline (String.concat "\n" (idx todo)) - | `Table -> print_endline (String.concat "\n" (tab todo)) - | `Fill -> - print_endline (String.concat "\n" - (fill MetadataTypes.library_obj_tbl MetadataTypes.library_hits_tbl)) - | `List -> print_endline (String.concat " " (List.map fst map)) - end - -let _ = main () - - diff --git a/helm/ocaml/registry/.depend b/helm/ocaml/registry/.depend deleted file mode 100644 index cf4f36b68..000000000 --- a/helm/ocaml/registry/.depend +++ /dev/null @@ -1,2 +0,0 @@ -helm_registry.cmo: helm_registry.cmi -helm_registry.cmx: helm_registry.cmi diff --git a/helm/ocaml/registry/.ocamlinit b/helm/ocaml/registry/.ocamlinit deleted file mode 100644 index b08e0ebfc..000000000 --- a/helm/ocaml/registry/.ocamlinit +++ /dev/null @@ -1,4 +0,0 @@ -#use "topfind";; -#require "helm-registry";; -open Helm_registry;; -load_from "tests/sample.xml";; diff --git a/helm/ocaml/registry/Makefile b/helm/ocaml/registry/Makefile deleted file mode 100644 index bb9715ab4..000000000 --- a/helm/ocaml/registry/Makefile +++ /dev/null @@ -1,8 +0,0 @@ - -PACKAGE = registry -INTERFACE_FILES = helm_registry.mli -IMPLEMENTATION_FILES = helm_registry.ml - -include ../../Makefile.defs -include ../Makefile.common - diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml deleted file mode 100644 index b7b3de11d..000000000 --- a/helm/ocaml/registry/helm_registry.ml +++ /dev/null @@ -1,425 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let debug = false -let debug_print s = - if debug then prerr_endline ("Helm_registry debugging: " ^ (Lazy.force s)) - - (** *) - -let list_uniq l = - let rec aux last_element = function - | [] -> [] - | hd :: tl -> - (match last_element with - | Some elt when elt = hd -> aux last_element tl - | _ -> hd :: aux (Some hd) tl) - in - aux None l - -let starts_with prefix = -(* - let rex = Str.regexp (Str.quote prefix) in - fun s -> Str.string_match rex s 0 -*) - let prefix_len = String.length prefix in - fun s -> - try - String.sub s 0 prefix_len = prefix - with Invalid_argument _ -> false - -let hashtbl_keys tbl = Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] -let hashtbl_pairs tbl = Hashtbl.fold (fun k v acc -> (k,v) :: acc) tbl [] - - (** *) - -exception Malformed_key of string -exception Key_not_found of string -exception Cyclic_definition of string -exception Type_error of string (* expected type, value, msg *) -exception Parse_error of string * int * int * string (* file, line, col, msg *) - - (* root XML tag: used by save_to, ignored by load_from *) -let root_tag = "helm_registry" - -let magic_size = 127 - -let backup_registry registry = Hashtbl.copy registry -let restore_registry backup registry = - Hashtbl.clear registry; - Hashtbl.iter (fun key value -> Hashtbl.add registry key value) backup - - (* as \\w but: - * - no sequences of '_' longer than 1 are permitted - *) -let valid_step_rex_raw = "[a-zA-Z0-9]+\\(_[a-z0A-Z-9]+\\)*" -let valid_key_rex_raw = - sprintf "%s\\(\\.%s\\)*" valid_step_rex_raw valid_step_rex_raw -let valid_key_rex = Str.regexp ("^" ^ valid_key_rex_raw ^ "$") -let interpolated_key_rex = Str.regexp ("\\$(" ^ valid_key_rex_raw ^ ")") -let dot_rex = Str.regexp "\\." -let spaces_rex = Str.regexp "[ \t\n\r]+" -let heading_spaces_rex = Str.regexp "^[ \t\n\r]+" -let margin_blanks_rex = - Str.regexp "^\\([ \t\n\r]*\\)\\([^ \t\n\r]*\\)\\([ \t\n\r]*\\)$" - -let strip_blanks s = Str.global_replace margin_blanks_rex "\\2" s - -let split s = - (* trailing blanks are removed per default by split *) - Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s) -let merge l = String.concat " " l - -let handle_type_error f x = - try f x with exn -> raise (Type_error (Printexc.to_string exn)) - - (** marshallers/unmarshallers *) -let string x = x -let int = handle_type_error int_of_string -let float = handle_type_error float_of_string -let bool = handle_type_error bool_of_string -let of_string x = x -let of_int = handle_type_error string_of_int -let of_float = handle_type_error string_of_float -let of_bool = handle_type_error string_of_bool - - (* escapes for xml configuration file *) -let (escape, unescape) = - let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in - (Netencoding.Html.encode ~in_enc ~out_enc (), - Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ()) - -let key_is_valid key = - if not (Str.string_match valid_key_rex key 0) then - raise (Malformed_key key) - -let set' ?(replace=false) registry ~key ~value = - debug_print (lazy(sprintf "Setting (replace: %b) %s = %s" replace key value)); - key_is_valid key; - let add_fun = if replace then Hashtbl.replace else Hashtbl.add in - add_fun registry key value - -let unset registry = Hashtbl.remove registry - -let env_var_of_key = Str.global_replace dot_rex "__" - -let singleton = function - | [] -> - raise (Type_error ("empty list value found where singleton was expected")) - | hd :: _ -> hd - -let get registry key = - let rec aux stack key = - key_is_valid key; - if List.mem key stack then begin - let msg = (String.concat " -> " (List.rev stack)) ^ " -> " ^ key in - raise (Cyclic_definition msg) - end; - (* internal value *) - let registry_values = List.rev (Hashtbl.find_all registry key) in - let env_value = (* environment value *) - try - Some (Sys.getenv (env_var_of_key key)) - with Not_found -> None - in - let values = (* resulting value *) - match registry_values, env_value with - | _, Some env -> [env] - | [], None -> - (try - [ Sys.getenv key ] - with Not_found -> raise (Key_not_found key)) - | values, None -> values - in - List.map (interpolate (key :: stack)) values - and interpolate stack value = - Str.global_substitute interpolated_key_rex - (fun s -> - let matched = Str.matched_string s in - (* "$(var)" -> "var" *) - let key = String.sub matched 2 (String.length matched - 3) in - singleton (aux stack key)) - value - in - List.map strip_blanks (aux [] key) - -let has registry key = Hashtbl.mem registry key - -let get_typed registry unmarshaller key = - let value = singleton (get registry key) in - unmarshaller value - -let set_typed registry marshaller ~key ~value = - set' ~replace:true registry ~key ~value:(marshaller value) - -let get_opt registry unmarshaller key = - try - Some (unmarshaller (singleton (get registry key))) - with Key_not_found _ -> None - -let get_opt_default registry unmarshaller ~default key = - match get_opt registry unmarshaller key with - | None -> default - | Some v -> v - -let set_opt registry marshaller ~key ~value = - match value with - | None -> unset registry key - | Some value -> set' ~replace:true registry ~key ~value:(marshaller value) - -let get_list registry unmarshaller key = - try - List.map unmarshaller (get registry key) - with Key_not_found _ -> [] - -let get_pair registry fst_unmarshaller snd_unmarshaller key = - let v = singleton (get registry key) in - match Str.split spaces_rex v with - | [fst; snd] -> fst_unmarshaller fst, snd_unmarshaller snd - | _ -> raise (Type_error "not a pair") - -let set_list registry marshaller ~key ~value = - Hashtbl.remove registry key; - List.iter - (fun v -> set' ~replace:false registry ~key ~value:(marshaller v)) - value - -type xml_tree = - | Cdata of string - | Element of string * (string * string) list * xml_tree list - -let dot_RE = Str.regexp "\\." - -let xml_tree_of_registry registry = - let has_child name elements = - List.exists - (function - | Element (_, ["name", name'], _) when name = name' -> true - | _ -> false) - elements - in - let rec get_child name = function - | [] -> assert false - | (Element (_, ["name", name'], _) as child) :: tl when name = name' -> - child, tl - | hd :: tl -> - let child, rest = get_child name tl in - child, hd :: rest - in - let rec add_key path value tree = - match path, tree with - | [key], Element (name, attrs, children) -> - Element (name, attrs, - Element ("key", ["name", key], - [Cdata (strip_blanks value)]) :: children) - | dir :: path, Element (name, attrs, children) -> - if has_child dir children then - let child, rest = get_child dir children in - Element (name, attrs, add_key path value child :: rest) - else - Element (name, attrs, - ((add_key path value (Element ("section", ["name", dir], []))) - :: children)) - | _ -> assert false - in - Hashtbl.fold - (fun k v tree -> add_key ((Str.split dot_RE k)) v tree) - registry - (Element (root_tag, [], [])) - -let rec stream_of_xml_tree = function - | Cdata s -> Xml.xml_cdata s - | Element (name, attrs, children) -> - Xml.xml_nempty name - (List.map (fun (n, v) -> (None, n, v)) attrs) - (stream_of_xml_trees children) -and stream_of_xml_trees = function - | [] -> [< >] - | hd :: tl -> [< stream_of_xml_tree hd; stream_of_xml_trees tl >] - -let save_to registry fname = - let token_stream = stream_of_xml_tree (xml_tree_of_registry registry) in - let oc = open_out fname in - Xml.pp_to_outchan token_stream oc; - close_out oc - -let rec load_from_absolute ?path registry fname = - let _path = ref (match path with None -> [] | Some p -> p)in - (*
    elements entered so far *) - let in_key = ref false in (* have we entered a element? *) - let cdata = ref "" in (* collected cdata (inside *) - let push_path name = _path := name :: !_path in - let pop_path () = _path := List.tl !_path in - let start_element tag attrs = - match tag, attrs with - | "section", ["name", name] -> push_path name - | "key", ["name", name] -> in_key := true; push_path name - | "helm_registry", _ -> () - | "include", ["href", fname] -> - debug_print (lazy ("including file " ^ fname)); - load_from_absolute ~path:!_path registry fname - | tag, _ -> - raise (Parse_error (fname, ~-1, ~-1, - (sprintf "unexpected element <%s> or wrong attribute set" tag))) - in - let end_element tag = - match tag with - | "section" -> pop_path () - | "key" -> - let key = String.concat "." (List.rev !_path) in - set' registry ~key ~value:!cdata; - cdata := ""; - in_key := false; - pop_path () - | "include" | "helm_registry" -> () - | _ -> assert false - in - let character_data text = - if !in_key then cdata := !cdata ^ text - in - let callbacks = { - XmlPushParser.default_callbacks with - XmlPushParser.start_element = Some start_element; - XmlPushParser.end_element = Some end_element; - XmlPushParser.character_data = Some character_data; - } in - let xml_parser = XmlPushParser.create_parser callbacks in - let backup = backup_registry registry in -(* if path = None then Hashtbl.clear registry; *) - try - XmlPushParser.parse xml_parser (`File fname) - with exn -> - restore_registry backup registry; - raise exn - -let load_from registry ?path fname = - if Filename.is_relative fname then begin - let no_file_found = ref true in - let path = - match path with - | Some path -> path (* path given as argument *) - | None -> [ Sys.getcwd () ] (* no path given, try with cwd *) - in - List.iter - (fun dir -> - let conffile = dir ^ "/" ^ fname in - if Sys.file_exists conffile then begin - no_file_found := false; - load_from_absolute registry conffile - end) - path; - if !no_file_found then - failwith (sprintf - "Helm_registry.init: no configuration file named %s in [ %s ]" - fname (String.concat "; " path)) - end else - load_from_absolute registry fname - -let fold registry ?prefix ?(interpolate = true) f init = - let value_of k v = - if interpolate then singleton (get registry k) else strip_blanks v - in - match prefix with - | None -> Hashtbl.fold (fun k v acc -> f acc k (value_of k v)) registry init - | Some s -> - let key_matches = starts_with (s ^ ".") in - let rec fold_filter acc = function - | [] -> acc - | (k,v) :: tl when key_matches k -> - fold_filter (f acc k (value_of k v)) tl - | _ :: tl -> fold_filter acc tl - in - fold_filter init (hashtbl_pairs registry) - -let iter registry ?prefix ?interpolate f = - fold registry ?prefix ?interpolate (fun _ k v -> f k v) () -let to_list registry ?prefix ?interpolate () = - fold registry ?prefix ?interpolate (fun acc k v -> (k, v) :: acc) [] - -let ls registry prefix = - let prefix = prefix ^ "." in - let prefix_len = String.length prefix in - let key_matches = starts_with prefix in - let matching_keys = (* collect matching keys' _postfixes_ *) - fold registry - (fun acc key _ -> - if key_matches key then - String.sub key prefix_len (String.length key - prefix_len) :: acc - else - acc) - [] - in - let (sections, keys) = - List.fold_left - (fun (sections, keys) postfix -> - match Str.split dot_rex postfix with - | [key] -> (sections, key :: keys) - | hd_key :: _ -> (* length > 1 => nested section found *) - (hd_key :: sections, keys) - | _ -> assert false) - ([], []) matching_keys - in - (list_uniq (List.sort Pervasives.compare sections), keys) - -(** {2 API implementation} - * functional methods above are wrapped so that they work on a default - * (imperative) registry*) - -let default_registry = Hashtbl.create magic_size - -let get key = singleton (get default_registry key) -let set = set' ~replace:true default_registry -let has = has default_registry -let fold ?prefix ?interpolate f init = - fold default_registry ?prefix ?interpolate f init -let iter = iter default_registry -let to_list = to_list default_registry -let ls = ls default_registry -let get_typed unmarshaller = get_typed default_registry unmarshaller -let get_opt unmarshaller = get_opt default_registry unmarshaller -let get_opt_default unmarshaller = get_opt_default default_registry unmarshaller -let get_list unmarshaller = get_list default_registry unmarshaller -let get_pair unmarshaller = get_pair default_registry unmarshaller -let set_typed marshaller = set_typed default_registry marshaller -let set_opt unmarshaller = set_opt default_registry unmarshaller -let set_list marshaller = set_list default_registry marshaller -let unset = unset default_registry -let save_to = save_to default_registry -let load_from = load_from default_registry -let clear () = Hashtbl.clear default_registry - -let get_string = get_typed string -let get_int = get_typed int -let get_float = get_typed float -let get_bool = get_typed bool -let set_string = set_typed of_string -let set_int = set_typed of_int -let set_float = set_typed of_float -let set_bool = set_typed of_bool - diff --git a/helm/ocaml/registry/helm_registry.mli b/helm/ocaml/registry/helm_registry.mli deleted file mode 100644 index 1ef1aa3b7..000000000 --- a/helm/ocaml/registry/helm_registry.mli +++ /dev/null @@ -1,199 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** Configuration repository for HELM applications. - * - * ++ Keys format ++ - * - * key ::= path - * path ::= component ( '.' component )* - * component ::= ( alpha | num | '_' )+ - * # with the only exception that sequences of '_' longer than 1 aren't valid - * # components - * - * Suggested usage .: - * e.g. gTopLevel.prooffile, http_getter.port, ... - * - * ++ Configuration file example ++ - * - * gTopLevel.prooffile = "/home/zack/prooffile" - * http_getter.port = "58080" - * - * ++ Environment variable override ++ - * - * each key has an associated environment variable name. At runtime (i.e. when - * "get" requests are performed) a variable with this name will be looked for, - * if it's defined it will override the value present (or absent) in the - * registry. - * Environment variables are _not_ considered when saving the configuration to - * a configuration file (via "save_to" function below) . - * - * Mapping between keys and environment variables is as follows: - * - each "." is converted to "__" - * E.g.: my.Foo_iSH.Application -> my__Foo_iSH__Application - * - * ++ Variable interpolation ++ - * - * Interpolation is supported with the following syntax: - * - * foo.bar = "quux" - * foo.baz = $(foo.bar)/baz - *) - - (** raised when a looked up key can't be found - * @param key looked up key *) -exception Key_not_found of string - - (** raised when a cyclic definitions is found, e.g. after - * Helm_registry.set "a" "$b" - * Helm_registry.set "b" "$a" - * @param msg brief description of the definition cycle *) -exception Cyclic_definition of string - - (** raised when a looked up key doesn't have the required type, parameter is - * an error message *) -exception Type_error of string - - (** raised when a malformed key is encountered - * @param key malformed key *) -exception Malformed_key of string - - (** raised when an error is encountered while parsing a configuration file - * @param fname file name - * @param line line number - * @param col column number - * @param msg error description - *) -exception Parse_error of string * int * int * string - -(** {2 Generic untyped interface} - * Using the functions below this module could be used as a repository of - * key/value pairs *) - - (** lookup key in registry with environment variable override *) -val get: string -> string -val set: key:string -> value:string -> unit -val has: string -> bool - - (** remove a key from the current environment, next get over this key will - * raise Key_not_found until the key will be redefined *) -val unset: string -> unit - - (** @param interpolate defaults to true *) -val fold: - ?prefix:string -> ?interpolate:bool -> - ('a -> string -> string -> 'a) -> 'a -> 'a - - (** @param interpolate defaults to true *) -val iter: - ?prefix:string -> ?interpolate:bool -> - (string -> string -> unit) -> unit - - (** @param interpolate defaults to true *) -val to_list: - ?prefix:string -> ?interpolate:bool -> - unit -> (string * string) list - - (** @param prefix key representing the section whose contents should be listed - * @return section list * key list *) -val ls: string -> string list * string list - -(** {2 Typed interface} - * Three basic types are supported: strings, int and strings list. Strings - * correspond literally to what is written inside double quotes; int to the - * parsing of an integer number from ; strings list to the splitting at blanks - * of it (heading and trailing blanks are removed before splitting) *) - -(** {3 Unmarshallers} *) - -val string: string -> string -val int: string -> int -val float: string -> float -val bool: string -> bool - -(** {3 Typed getters} *) - - (** like get, with an additional unmarshaller - * @param unmarshaller conversion function from string to the desired type. - * Use one of the above unmarshallers *) -val get_typed: (string -> 'a) -> string -> 'a - -val get_opt: (string -> 'a) -> string -> 'a option -val get_opt_default: (string -> 'a) -> default:'a -> string -> 'a - - (** never fails with Key_not_found, instead return the empty list *) -val get_list: (string -> 'a) -> string -> 'a list - - (** decode values which are blank separated list of values, of length 2 *) -val get_pair: (string -> 'a) -> (string -> 'b) -> string -> 'a * 'b - -(** {4 Shorthands} *) - -val get_string: string -> string -val get_int: string -> int -val get_float: string -> float -val get_bool: string -> bool - -(** {3 Marshallers} *) - -val of_string: string -> string -val of_int: int -> string -val of_float: float -> string -val of_bool: bool -> string - -(** {3 Typed setters} *) - - (** like set, with an additional marshaller - * @param marshaller conversion function to string. - * Use one of the above marshallers *) -val set_typed: ('a -> string) -> key:string -> value:'a -> unit - -val set_opt: ('a -> string) -> key:string -> value:'a option -> unit -val set_list: ('a -> string) -> key:string -> value:'a list -> unit - -(** {4 Shorthands} *) - -val set_string: key:string -> value:string -> unit -val set_int: key:string -> value:int -> unit -val set_float: key:string -> value:float -> unit -val set_bool: key:string -> value:bool -> unit - -(** {2 Persistent configuration} *) - - (** @param fname file to which save current configuration *) -val save_to: string -> unit - - (** @param fname file from which load new configuration. If it's an absolute - * file name "path" argument is ignored. - * Otherwise given file name is looked up in each directory member of the - * given path. Each matching file is loaded overriding previous settings. If - * no path is given a default path composed of just the current working - * directory is used. - *) -val load_from: ?path:string list -> string -> unit - - (** removes all keys *) -val clear: unit -> unit - diff --git a/helm/ocaml/registry/test.ml b/helm/ocaml/registry/test.ml deleted file mode 100644 index d0b91a28c..000000000 --- a/helm/ocaml/registry/test.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf;; -Helm_registry.load_from Sys.argv.(1); -Helm_registry.iter ~interpolate:false (fun k v -> printf "%s = %s\n" k v); -Helm_registry.save_to Sys.argv.(2) - diff --git a/helm/ocaml/registry/tests/sample.xml b/helm/ocaml/registry/tests/sample.xml deleted file mode 100644 index b0edbdae0..000000000 --- a/helm/ocaml/registry/tests/sample.xml +++ /dev/null @@ -1,34 +0,0 @@ - - -
    - file:///home/zack/miohelm/objects - file:///home/zack/miohelm/objects -
    -
    - remote - http://localhost:58081 -
    -
    - yes -
    -
    - -
    -
    - yes -
    -
    - debian - 1 - false - 2.5 - 11 - 13 - 17 - 19 - 19 23.2 -
    -
    - http://localhost:58080/ -
    -     diff --git a/helm/ocaml/registry/tests/sample_include.xml b/helm/ocaml/registry/tests/sample_include.xml deleted file mode 100644 index 8a6851998..000000000 --- a/helm/ocaml/registry/tests/sample_include.xml +++ /dev/null @@ -1,15 +0,0 @@ - -
    - aaa - bbb -
    -
    - quux -
    - /public/helm_library - $(triciclo.basedir)/constanttype - $(triciclo.basedir)/environment - $(triciclo.basedir)/innertypes - $(triciclo.basedir)/currentproof - $(triciclo.basedir)/currentprooftype -     diff --git a/helm/ocaml/tactics/.depend b/helm/ocaml/tactics/.depend deleted file mode 100644 index 4769431a4..000000000 --- a/helm/ocaml/tactics/.depend +++ /dev/null @@ -1,164 +0,0 @@ -proofEngineHelpers.cmi: proofEngineTypes.cmi -continuationals.cmi: proofEngineTypes.cmi -tacticals.cmi: proofEngineTypes.cmi continuationals.cmi -reductionTactics.cmi: proofEngineTypes.cmi -proofEngineStructuralRules.cmi: proofEngineTypes.cmi -primitiveTactics.cmi: proofEngineTypes.cmi -metadataQuery.cmi: proofEngineTypes.cmi -paramodulation/inference.cmi: paramodulation/utils.cmi proofEngineTypes.cmi -paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \ - paramodulation/inference.cmi -paramodulation/indexing.cmi: paramodulation/utils.cmi \ - paramodulation/inference.cmi paramodulation/equality_indexing.cmi -paramodulation/saturation.cmi: proofEngineTypes.cmi -variousTactics.cmi: proofEngineTypes.cmi -autoTactic.cmi: proofEngineTypes.cmi -introductionTactics.cmi: proofEngineTypes.cmi -eliminationTactics.cmi: proofEngineTypes.cmi -negationTactics.cmi: proofEngineTypes.cmi -equalityTactics.cmi: proofEngineTypes.cmi -discriminationTactics.cmi: proofEngineTypes.cmi -inversion.cmi: proofEngineTypes.cmi -ring.cmi: proofEngineTypes.cmi -fourierR.cmi: proofEngineTypes.cmi -fwdSimplTactic.cmi: proofEngineTypes.cmi -statefulProofEngine.cmi: proofEngineTypes.cmi -tactics.cmi: proofEngineTypes.cmi -proofEngineTypes.cmo: proofEngineTypes.cmi -proofEngineTypes.cmx: proofEngineTypes.cmi -proofEngineHelpers.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi -proofEngineHelpers.cmx: proofEngineTypes.cmx proofEngineHelpers.cmi -proofEngineReduction.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi \ - proofEngineReduction.cmi -proofEngineReduction.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \ - proofEngineReduction.cmi -continuationals.cmo: proofEngineTypes.cmi continuationals.cmi -continuationals.cmx: proofEngineTypes.cmx continuationals.cmi -tacticals.cmo: proofEngineTypes.cmi continuationals.cmi tacticals.cmi -tacticals.cmx: proofEngineTypes.cmx continuationals.cmx tacticals.cmi -reductionTactics.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \ - proofEngineHelpers.cmi reductionTactics.cmi -reductionTactics.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \ - proofEngineHelpers.cmx reductionTactics.cmi -proofEngineStructuralRules.cmo: proofEngineTypes.cmi \ - proofEngineStructuralRules.cmi -proofEngineStructuralRules.cmx: proofEngineTypes.cmx \ - proofEngineStructuralRules.cmi -primitiveTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi -primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineHelpers.cmx primitiveTactics.cmi -hashtbl_equiv.cmo: hashtbl_equiv.cmi -hashtbl_equiv.cmx: hashtbl_equiv.cmi -metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ - hashtbl_equiv.cmi metadataQuery.cmi -metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ - hashtbl_equiv.cmx metadataQuery.cmi -paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi -paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi -paramodulation/inference.cmo: paramodulation/utils.cmi \ - proofEngineReduction.cmi proofEngineHelpers.cmi metadataQuery.cmi \ - paramodulation/inference.cmi -paramodulation/inference.cmx: paramodulation/utils.cmx \ - proofEngineReduction.cmx proofEngineHelpers.cmx metadataQuery.cmx \ - paramodulation/inference.cmi -paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \ - paramodulation/inference.cmi paramodulation/equality_indexing.cmi -paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \ - paramodulation/inference.cmx paramodulation/equality_indexing.cmi -paramodulation/indexing.cmo: paramodulation/utils.cmi \ - paramodulation/inference.cmi paramodulation/equality_indexing.cmi \ - paramodulation/indexing.cmi -paramodulation/indexing.cmx: paramodulation/utils.cmx \ - paramodulation/inference.cmx paramodulation/equality_indexing.cmx \ - paramodulation/indexing.cmi -paramodulation/saturation.cmo: paramodulation/utils.cmi reductionTactics.cmi \ - proofEngineTypes.cmi proofEngineReduction.cmi primitiveTactics.cmi \ - paramodulation/inference.cmi paramodulation/indexing.cmi \ - paramodulation/saturation.cmi -paramodulation/saturation.cmx: paramodulation/utils.cmx reductionTactics.cmx \ - proofEngineTypes.cmx proofEngineReduction.cmx primitiveTactics.cmx \ - paramodulation/inference.cmx paramodulation/indexing.cmx \ - paramodulation/saturation.cmi -variousTactics.cmo: tacticals.cmi proofEngineTypes.cmi \ - proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ - variousTactics.cmi -variousTactics.cmx: tacticals.cmx proofEngineTypes.cmx \ - proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ - variousTactics.cmi -autoTactic.cmo: paramodulation/saturation.cmi proofEngineTypes.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi metadataQuery.cmi \ - paramodulation/inference.cmi autoTactic.cmi -autoTactic.cmx: paramodulation/saturation.cmx proofEngineTypes.cmx \ - proofEngineHelpers.cmx primitiveTactics.cmx metadataQuery.cmx \ - paramodulation/inference.cmx autoTactic.cmi -introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ - introductionTactics.cmi -introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ - introductionTactics.cmi -eliminationTactics.cmo: tacticals.cmi proofEngineTypes.cmi \ - proofEngineStructuralRules.cmi proofEngineHelpers.cmi \ - primitiveTactics.cmi eliminationTactics.cmi -eliminationTactics.cmx: tacticals.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineHelpers.cmx \ - primitiveTactics.cmx eliminationTactics.cmi -negationTactics.cmo: variousTactics.cmi tacticals.cmi proofEngineTypes.cmi \ - primitiveTactics.cmi eliminationTactics.cmi negationTactics.cmi -negationTactics.cmx: variousTactics.cmx tacticals.cmx proofEngineTypes.cmx \ - primitiveTactics.cmx eliminationTactics.cmx negationTactics.cmi -equalityTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - proofEngineStructuralRules.cmi proofEngineReduction.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi introductionTactics.cmi \ - equalityTactics.cmi -equalityTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineReduction.cmx \ - proofEngineHelpers.cmx primitiveTactics.cmx introductionTactics.cmx \ - equalityTactics.cmi -discriminationTactics.cmo: tacticals.cmi reductionTactics.cmi \ - proofEngineTypes.cmi primitiveTactics.cmi introductionTactics.cmi \ - equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi -discriminationTactics.cmx: tacticals.cmx reductionTactics.cmx \ - proofEngineTypes.cmx primitiveTactics.cmx introductionTactics.cmx \ - equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmi -inversion.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineReduction.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi equalityTactics.cmi \ - inversion.cmi -inversion.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineReduction.cmx \ - proofEngineHelpers.cmx primitiveTactics.cmx equalityTactics.cmx \ - inversion.cmi -ring.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineStructuralRules.cmi \ - primitiveTactics.cmi equalityTactics.cmi eliminationTactics.cmi ring.cmi -ring.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineStructuralRules.cmx \ - primitiveTactics.cmx equalityTactics.cmx eliminationTactics.cmx ring.cmi -fourier.cmo: fourier.cmi -fourier.cmx: fourier.cmi -fourierR.cmo: tacticals.cmi ring.cmi reductionTactics.cmi \ - proofEngineTypes.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ - fourier.cmi equalityTactics.cmi fourierR.cmi -fourierR.cmx: tacticals.cmx ring.cmx reductionTactics.cmx \ - proofEngineTypes.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ - fourier.cmx equalityTactics.cmx fourierR.cmi -fwdSimplTactic.cmo: tacticals.cmi proofEngineTypes.cmi \ - proofEngineStructuralRules.cmi proofEngineHelpers.cmi \ - primitiveTactics.cmi fwdSimplTactic.cmi -fwdSimplTactic.cmx: tacticals.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineHelpers.cmx \ - primitiveTactics.cmx fwdSimplTactic.cmi -history.cmo: history.cmi -history.cmx: history.cmi -statefulProofEngine.cmo: proofEngineTypes.cmi history.cmi \ - statefulProofEngine.cmi -statefulProofEngine.cmx: proofEngineTypes.cmx history.cmx \ - statefulProofEngine.cmi -tactics.cmo: variousTactics.cmi tacticals.cmi paramodulation/saturation.cmi \ - ring.cmi reductionTactics.cmi proofEngineStructuralRules.cmi \ - primitiveTactics.cmi negationTactics.cmi inversion.cmi \ - introductionTactics.cmi fwdSimplTactic.cmi fourierR.cmi \ - equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi \ - autoTactic.cmi tactics.cmi -tactics.cmx: variousTactics.cmx tacticals.cmx paramodulation/saturation.cmx \ - ring.cmx reductionTactics.cmx proofEngineStructuralRules.cmx \ - primitiveTactics.cmx negationTactics.cmx inversion.cmx \ - introductionTactics.cmx fwdSimplTactic.cmx fourierR.cmx \ - equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmx \ - autoTactic.cmx tactics.cmi diff --git a/helm/ocaml/tactics/Makefile b/helm/ocaml/tactics/Makefile deleted file mode 100644 index 0b8f4fb69..000000000 --- a/helm/ocaml/tactics/Makefile +++ /dev/null @@ -1,36 +0,0 @@ -PACKAGE = tactics - -INTERFACE_FILES = \ - proofEngineTypes.mli \ - proofEngineHelpers.mli proofEngineReduction.mli \ - continuationals.mli \ - tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \ - primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \ - paramodulation/utils.mli \ - paramodulation/inference.mli\ - paramodulation/equality_indexing.mli\ - paramodulation/indexing.mli \ - paramodulation/saturation.mli \ - variousTactics.mli autoTactic.mli \ - introductionTactics.mli eliminationTactics.mli negationTactics.mli \ - equalityTactics.mli discriminationTactics.mli inversion.mli ring.mli \ - fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \ - statefulProofEngine.mli tactics.mli - -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - - -all: - -tactics.mli: tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli - @echo " OCAMLC -i $< > $@" - $(H)echo "(* GENERATED FILE, DO NOT EDIT *)" > $@ - $(H)$(OCAMLC) -I paramodulation -i $< >> $@ - -STATS_EXCLUDE = tactics.mli - -include ../../Makefile.defs -include ../Makefile.common - -OCAMLOPTIONS+= -I paramodulation -OCAMLDEPOPTIONS+= -I paramodulation diff --git a/helm/ocaml/tactics/autoTactic.ml b/helm/ocaml/tactics/autoTactic.ml deleted file mode 100644 index 42df90768..000000000 --- a/helm/ocaml/tactics/autoTactic.ml +++ /dev/null @@ -1,349 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - - let debug = false - let debug_print s = if debug then prerr_endline (Lazy.force s) - -(* let debug_print = fun _ -> () *) - -(* Profiling code -let new_experimental_hint = - let profile = CicUtil.profile "new_experimental_hint" in - fun ~dbd ~facts ?signature ~universe status -> - profile.profile (MetadataQuery.new_experimental_hint ~dbd ~facts ?signature ~universe) status -*) let new_experimental_hint = MetadataQuery.new_experimental_hint - -(* In this versions of auto_tac we maintain an hash table of all inspected - goals. We assume that the context is invariant for application. - To this aim, it is essential to sall hint_verbose, that in turns calls - apply_verbose. *) - -type exitus = - No of int - | Yes of Cic.term * int - | NotYetInspected - -let inspected_goals = Hashtbl.create 503;; - -let search_theorems_in_context status = - let (proof, goal) = status in - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module PET = ProofEngineTypes in - let module PT = PrimitiveTactics in - let _,metasenv,_,_ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let rec find n = function - | [] -> [] - | hd::tl -> - let res = - (* we should check that the hypothesys has not been cleared *) - if List.nth context (n-1) = None then - None - else - try - let (subst,(proof, goal_list)) = - PT.apply_tac_verbose ~term:(C.Rel n) status - in - (* - let goal_list = - List.stable_sort (compare_goal_list proof) goal_list in - *) - Some (subst,(proof, goal_list)) - with - PET.Fail _ -> None - in - (match res with - | Some res -> res::(find (n+1) tl) - | None -> find (n+1) tl) - in - try - find 1 context - with Failure s -> [] -;; - - -let compare_goals proof goal1 goal2 = - let _,metasenv,_,_ = proof in - let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in - let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in - let ty_sort1,_ = CicTypeChecker.type_of_aux' metasenv ey1 ty1 - CicUniv.empty_ugraph in - let ty_sort2,_ = CicTypeChecker.type_of_aux' metasenv ey2 ty2 - CicUniv.empty_ugraph in - let prop1 = - let b,_ = CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1 - CicUniv.empty_ugraph in - if b then 0 else 1 - in - let prop2 = - let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2 - CicUniv.empty_ugraph in - if b then 0 else 1 - in - prop1 - prop2 - - -let new_search_theorems f dbd proof goal depth sign = - let choices = f (proof,goal) - in - List.map - (function (subst,(proof, goallist)) -> - (* let goallist = reorder_goals dbd sign proof goallist in *) - let goallist = List.sort (compare_goals proof) goallist in - (subst,(proof,(List.map (function g -> (g,depth)) goallist), sign))) - choices -;; - -exception NoOtherChoices;; - -let rec auto_single dbd proof goal ey ty depth width sign already_seen_goals - universe - = - if depth = 0 then [] else - if List.mem ty already_seen_goals then [] else - let already_seen_goals = ty::already_seen_goals in - let facts = (depth = 1) in - let _,metasenv,p,_ = proof in - (* first of all we check if the goal has been already - inspected *) - assert (CicUtil.exists_meta goal metasenv); - let exitus = - try Hashtbl.find inspected_goals ty - with Not_found -> NotYetInspected in - let is_meta_closed = CicUtil.is_meta_closed ty in - begin - match exitus with - Yes (bo,_) -> - (* - debug_print (lazy "ALREADY PROVED!!!!!!!!!!!!!!!!!!!!!!!!!!!!"); - debug_print (lazy (CicPp.ppterm ty)); - *) - let subst_in = - (* if we just apply the subtitution, the type - is irrelevant: we may use Implicit, since it will - be dropped *) - CicMetaSubst.apply_subst - [(goal,(ey, bo, Cic.Implicit None))] in - let (proof,_) = - ProofEngineHelpers.subst_meta_and_metasenv_in_proof - proof goal subst_in metasenv in - [(subst_in,(proof,[],sign))] - | No d when (d >= depth) -> - (* debug_print (lazy "PRUNED!!!!!!!!!!!!!!!!!!!!!!!!!!!!"); *) - [] (* the empty list means no choices, i.e. failure *) - | No _ - | NotYetInspected -> - debug_print (lazy ("CURRENT GOAL = " ^ CicPp.ppterm ty)); - debug_print (lazy ("CURRENT PROOF = " ^ CicPp.ppterm p)); - debug_print (lazy ("CURRENT HYP = " ^ CicPp.ppcontext ey)); - let sign, new_sign = - if is_meta_closed then - None, Some (MetadataConstraints.signature_of ty) - else sign,sign in (* maybe the union ? *) - let local_choices = - new_search_theorems - search_theorems_in_context dbd - proof goal (depth-1) new_sign in - let global_choices = - new_search_theorems - (fun status -> - List.map snd - (new_experimental_hint - ~dbd ~facts:facts ?signature:sign ~universe status)) - dbd proof goal (depth-1) new_sign in - let all_choices = - local_choices@global_choices in - let sorted_choices = - List.stable_sort - (fun (_, (_, goals1, _)) (_, (_, goals2, _)) -> - Pervasives.compare - (List.length goals1) (List.length goals2)) - all_choices in - (match (auto_new dbd width already_seen_goals universe sorted_choices) - with - [] -> - (* no proof has been found; we update the - hastable *) - (* if is_meta_closed then *) - Hashtbl.add inspected_goals ty (No depth); - [] - | (subst,(proof,[],sign))::tl1 -> - (* a proof for goal has been found: - in order to get the proof we apply subst to - Meta[goal] *) - if is_meta_closed then - begin - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable ey in - let meta_proof = - subst (Cic.Meta(goal,irl)) in - Hashtbl.add inspected_goals - ty (Yes (meta_proof,depth)); -(* - begin - let cty,_ = - CicTypeChecker.type_of_aux' metasenv ey meta_proof CicUniv.empty_ugraph - in - if not (cty = ty) then - begin - debug_print (lazy ("ty = "^CicPp.ppterm ty)); - debug_print (lazy ("cty = "^CicPp.ppterm cty)); - assert false - end - Hashtbl.add inspected_goals - ty (Yes (meta_proof,depth)); - end; -*) - end; - (subst,(proof,[],sign))::tl1 - | _ -> assert false) - end - -and auto_new dbd width already_seen_goals universe = function - | [] -> [] - | (subst,(proof, goals, sign))::tl -> - let _,metasenv,_,_ = proof in - let goals'= - List.filter (fun (goal, _) -> CicUtil.exists_meta goal metasenv) goals - in - auto_new_aux dbd - width already_seen_goals universe ((subst,(proof, goals', sign))::tl) - -and auto_new_aux dbd width already_seen_goals universe = function - | [] -> [] - | (subst,(proof, [], sign))::tl -> (subst,(proof, [], sign))::tl - | (subst,(proof, (goal,0)::_, _))::tl -> - auto_new dbd width already_seen_goals universe tl - | (subst,(proof, goals, _))::tl when - (List.length goals) > width -> - auto_new dbd width already_seen_goals universe tl - | (subst,(proof, (goal,depth)::gtl, sign))::tl -> - let _,metasenv,p,_ = proof in - let (_, ey ,ty) = CicUtil.lookup_meta goal metasenv in - match (auto_single dbd proof goal ey ty depth - (width - (List.length gtl)) sign already_seen_goals) universe - with - [] -> auto_new dbd width already_seen_goals universe tl - | (local_subst,(proof,[],sign))::tl1 -> - let new_subst f t = f (subst t) in - let is_meta_closed = CicUtil.is_meta_closed ty in - let all_choices = - if is_meta_closed then - (new_subst local_subst,(proof,gtl,sign))::tl - else - let tl2 = - (List.map - (function (f,(p,l,s)) -> (new_subst f,(p,l@gtl,s))) tl1) - in - (new_subst local_subst,(proof,gtl,sign))::tl2@tl in - auto_new dbd width already_seen_goals universe all_choices - | _ -> assert false - ;; - -let default_depth = 5 -let default_width = 3 - -(* -let auto_tac ?(depth=default_depth) ?(width=default_width) ~(dbd:HMysql.dbd) - () -= - let auto_tac dbd (proof,goal) = - let universe = MetadataQuery.signature_of_goal ~dbd (proof,goal) in - Hashtbl.clear inspected_goals; - debug_print (lazy "Entro in Auto"); - let id t = t in - let t1 = Unix.gettimeofday () in - match auto_new dbd width [] universe [id,(proof, [(goal,depth)],None)] with - [] -> debug_print (lazy "Auto failed"); - raise (ProofEngineTypes.Fail "No Applicable theorem") - | (_,(proof,[],_))::_ -> - let t2 = Unix.gettimeofday () in - debug_print (lazy "AUTO_TAC HA FINITO"); - let _,_,p,_ = proof in - debug_print (lazy (CicPp.ppterm p)); - Printf.printf "tempo: %.9f\n" (t2 -. t1); - (proof,[]) - | _ -> assert false - in - ProofEngineTypes.mk_tactic (auto_tac dbd) -;; -*) - -(* -let paramodulation_tactic = ref - (fun dbd ?full ?depth ?width status -> - raise (ProofEngineTypes.Fail (lazy "Not Ready yet...")));; - -let term_is_equality = ref - (fun term -> debug_print (lazy "term_is_equality E` DUMMY!!!!"); false);; -*) - -let auto_tac ?(depth=default_depth) ?(width=default_width) ?paramodulation - ?full ~(dbd:HMysql.dbd) () = - let auto_tac dbd (proof, goal) = - let normal_auto () = - let universe = MetadataQuery.signature_of_goal ~dbd (proof, goal) in - Hashtbl.clear inspected_goals; - debug_print (lazy "Entro in Auto"); - let id t = t in - let t1 = Unix.gettimeofday () in - match - auto_new dbd width [] universe [id, (proof, [(goal, depth)], None)] - with - [] -> debug_print(lazy "Auto failed"); - raise (ProofEngineTypes.Fail (lazy "No Applicable theorem")) - | (_,(proof,[],_))::_ -> - let t2 = Unix.gettimeofday () in - debug_print (lazy "AUTO_TAC HA FINITO"); - let _,_,p,_ = proof in - debug_print (lazy (CicPp.ppterm p)); - debug_print (lazy (Printf.sprintf "tempo: %.9f\n" (t2 -. t1))); - (proof,[]) - | _ -> assert false - in - let full = match full with None -> false | Some _ -> true in - let paramodulation_ok = - match paramodulation with - | None -> false - | Some _ -> - let _, metasenv, _, _ = proof in - let _, _, meta_goal = CicUtil.lookup_meta goal metasenv in - full || (Inference.term_is_equality meta_goal) - in - if paramodulation_ok then ( - debug_print (lazy "USO PARAMODULATION..."); -(* try *) - Saturation.saturate dbd ~depth ~width ~full (proof, goal) -(* with ProofEngineTypes.Fail _ -> *) -(* normal_auto () *) - ) else - normal_auto () - in - ProofEngineTypes.mk_tactic (auto_tac dbd) -;; diff --git a/helm/ocaml/tactics/autoTactic.mli b/helm/ocaml/tactics/autoTactic.mli deleted file mode 100644 index fe72629f0..000000000 --- a/helm/ocaml/tactics/autoTactic.mli +++ /dev/null @@ -1,31 +0,0 @@ - -(* 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 auto_tac: - ?depth:int -> ?width:int -> ?paramodulation:string -> ?full:string -> - dbd:HMysql.dbd -> unit -> - ProofEngineTypes.tactic - diff --git a/helm/ocaml/tactics/continuationals.ml b/helm/ocaml/tactics/continuationals.ml deleted file mode 100644 index 3ed167a71..000000000 --- a/helm/ocaml/tactics/continuationals.ml +++ /dev/null @@ -1,357 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) else () - -exception Error of string lazy_t -let fail msg = raise (Error msg) - -type goal = ProofEngineTypes.goal - -module Stack = -struct - type switch = Open of goal | Closed of goal - type locator = int * switch - type tag = [ `BranchTag | `FocusTag | `NoTag ] - type entry = locator list * locator list * locator list * tag - type t = entry list - - let empty = [ [], [], [], `NoTag ] - - let fold ~env ~cont ~todo init stack = - let rec aux acc depth = - function - | [] -> acc - | (locs, todos, conts, tag) :: tl -> - let acc = List.fold_left (fun acc -> env acc depth tag) acc locs in - let acc = List.fold_left (fun acc -> cont acc depth tag) acc conts in - let acc = List.fold_left (fun acc -> todo acc depth tag) acc todos in - aux acc (depth + 1) tl - in - assert (stack <> []); - aux init 0 stack - - let iter ~env ~cont ~todo = - fold ~env:(fun _ -> env) ~cont:(fun _ -> cont) ~todo:(fun _ -> todo) () - - let map ~env ~cont ~todo = - let depth = ref ~-1 in - List.map - (fun (s, t, c, tag) -> - incr depth; - let d = !depth in - env d tag s, todo d tag t, cont d tag c, tag) - - let is_open = function _, Open _ -> true | _ -> false - let close = function n, Open g -> n, Closed g | l -> l - let filter_open = List.filter is_open - let is_fresh = function n, Open _ when n > 0 -> true | _ -> false - let goal_of_loc = function _, Open g | _, Closed g -> g - let goal_of_switch = function Open g | Closed g -> g - let switch_of_loc = snd - - let zero_pos = List.map (fun g -> 0, Open g) - - let init_pos locs = - let pos = ref 0 in (* positions are 1-based *) - List.map (function _, sw -> incr pos; !pos, sw) locs - - let extract_pos i = - let rec aux acc = - function - | [] -> fail (lazy (sprintf "relative position %d not found" i)) - | (i', _) as loc :: tl when i = i' -> loc, (List.rev acc) @ tl - | hd :: tl -> aux (hd :: acc) tl - in - aux [] - - let deep_close gs = - let close _ _ = - List.map (fun l -> if List.mem (goal_of_loc l) gs then close l else l) - in - let rm _ _ = List.filter (fun l -> not (List.mem (goal_of_loc l) gs)) in - map ~env:close ~cont:rm ~todo:rm - - let rec find_goal = - function - | [] -> raise (Failure "Continuationals.find_goal") - | (l :: _, _ , _ , _) :: _ -> goal_of_loc l - | ( _ , _ , l :: _, _) :: _ -> goal_of_loc l - | ( _ , l :: _, _ , _) :: _ -> goal_of_loc l - | _ :: tl -> find_goal tl - - let is_empty = - function - | [] -> assert false - | [ [], [], [], `NoTag ] -> true - | _ -> false - - let of_metasenv metasenv = - let goals = List.map (fun (g, _, _) -> g) metasenv in - [ zero_pos goals, [], [], `NoTag ] - - let head_switches = - function - | (locs, _, _, _) :: _ -> List.map switch_of_loc locs - | [] -> assert false - - let head_goals = - function - | (locs, _, _, _) :: _ -> List.map goal_of_loc locs - | [] -> assert false - - let head_tag = - function - | (_, _, _, tag) :: _ -> tag - | [] -> assert false - - let shift_goals = - function - | _ :: (locs, _, _, _) :: _ -> List.map goal_of_loc locs - | [] -> assert false - | _ -> [] - - let open_goals stack = - let add_open acc _ _ l = if is_open l then goal_of_loc l :: acc else acc in - List.rev (fold ~env:add_open ~cont:add_open ~todo:add_open [] stack) - - let (@+) = (@) (* union *) - - let (@-) s1 s2 = (* difference *) - List.fold_right - (fun e acc -> if List.mem e s2 then acc else e :: acc) - s1 [] - - let (@~-) locs gs = (* remove some goals from a locators list *) - List.fold_right - (fun loc acc -> if List.mem (goal_of_loc loc) gs then acc else loc :: acc) - locs [] - - let pp stack = - let pp_goal = string_of_int in - let pp_switch = - function Open g -> "o" ^ pp_goal g | Closed g -> "c" ^ pp_goal g - in - let pp_loc (i, s) = string_of_int i ^ pp_switch s in - let pp_env env = sprintf "[%s]" (String.concat ";" (List.map pp_loc env)) in - let pp_tag = function `BranchTag -> "B" | `FocusTag -> "F" | `NoTag -> "N" in - let pp_stack_entry (env, todo, cont, tag) = - sprintf "(%s, %s, %s, %s)" (pp_env env) (pp_env todo) (pp_env cont) - (pp_tag tag) - in - String.concat " :: " (List.map pp_stack_entry stack) -end - -module type Status = -sig - type input_status - type output_status - - type tactic - - val id_tactic : tactic - val mk_tactic : (input_status -> output_status) -> tactic - val apply_tactic : tactic -> input_status -> output_status - - val goals : output_status -> goal list * goal list (** opened, closed goals *) - val set_goals: goal list * goal list -> output_status -> output_status - val get_stack : input_status -> Stack.t - val set_stack : Stack.t -> output_status -> output_status - - val inject : input_status -> output_status - val focus : goal -> output_status -> input_status -end - -module type C = -sig - type input_status - type output_status - type tactic - - type tactical = - | Tactic of tactic - | Skip - - type t = - | Dot - | Semicolon - - | Branch - | Shift - | Pos of int - | Merge - - | Focus of goal list - | Unfocus - - | Tactical of tactical - - val eval: t -> input_status -> output_status -end - -module Make (S: Status) = -struct - open Stack - - type input_status = S.input_status - type output_status = S.output_status - type tactic = S.tactic - - type tactical = - | Tactic of tactic - | Skip - - type t = - | Dot - | Semicolon - | Branch - | Shift - | Pos of int - | Merge - | Focus of goal list - | Unfocus - | Tactical of tactical - - let pp_t = - function - | Dot -> "Dot" - | Semicolon -> "Semicolon" - | Branch -> "Branch" - | Shift -> "Shift" - | Pos i -> "Pos " ^ string_of_int i - | Merge -> "Merge" - | Focus gs -> - sprintf "Focus [%s]" (String.concat "; " (List.map string_of_int gs)) - | Unfocus -> "Unfocus" - | Tactical _ -> "Tactical " - - let eval_tactical tactical ostatus switch = - match tactical, switch with - | Tactic tac, Open n -> - let ostatus = S.apply_tactic tac (S.focus n ostatus) in - let opened, closed = S.goals ostatus in - ostatus, opened, closed - | Skip, Closed n -> ostatus, [], [n] - | Tactic _, Closed _ -> fail (lazy "can't apply tactic to a closed goal") - | Skip, Open _ -> fail (lazy "can't skip an open goal") - - let eval cmd istatus = - let stack = S.get_stack istatus in - debug_print (lazy (sprintf "EVAL CONT %s <- %s" (pp_t cmd) (pp stack))); - let new_stack stack = S.inject istatus, stack in - let ostatus, stack = - match cmd, stack with - | _, [] -> assert false - | Tactical tac, (g, t, k, tag) :: s -> - if g = [] then fail (lazy "can't apply a tactic to zero goals"); - debug_print (lazy ("context length " ^string_of_int (List.length g))); - let rec aux s go gc = - function - | [] -> s, go, gc - | loc :: loc_tl -> - debug_print (lazy "inner eval tactical"); - let s, go, gc = - if List.exists ((=) (goal_of_loc loc)) gc then - s, go, gc - else - let s, go', gc' = eval_tactical tac s (switch_of_loc loc) in - s, (go @- gc') @+ go', gc @+ gc' - in - aux s go gc loc_tl - in - let s0, go0, gc0 = S.inject istatus, [], [] in - let sn, gon, gcn = aux s0 go0 gc0 g in - debug_print (lazy ("opened: " - ^ String.concat " " (List.map string_of_int gon))); - debug_print (lazy ("closed: " - ^ String.concat " " (List.map string_of_int gcn))); - let stack = - (zero_pos gon, t @~- gcn, k @~- gon, tag) :: deep_close gcn s - in - sn, stack - | Dot, ([], _, [], _) :: _ -> - (* backward compatibility: do-nothing-dot *) - new_stack stack - | Dot, (g, t, k, tag) :: s -> - (match filter_open g, k with - | loc :: loc_tl, _ -> new_stack (([ loc ], t, loc_tl @+ k, tag) :: s) - | [], loc :: k -> - assert (is_open loc); - new_stack (([ loc ], t, k, tag) :: s) - | _ -> fail (lazy "can't use \".\" here")) - | Semicolon, _ -> new_stack stack - | Branch, (g, t, k, tag) :: s -> - (match init_pos g with - | [] | [ _ ] -> fail (lazy "too few goals to branch"); - | loc :: loc_tl -> - new_stack - (([ loc ], [], [], `BranchTag) :: (loc_tl, t, k, tag) :: s)) - | Shift, (g, t, k, `BranchTag) :: (g', t', k', tag) :: s -> - (match g' with - | [] -> fail (lazy "no more goals to shift") - | loc :: loc_tl -> - new_stack - (([ loc ], t @+ filter_open g, [],`BranchTag) - :: (loc_tl, t', k', tag) :: s)) - | Shift, _ -> fail (lazy "can't shift goals here") - | Pos i, ([ loc ], [], [],`BranchTag) :: (g', t', k', tag) :: s - when is_fresh loc -> - let loc_i, g' = extract_pos i g' in - new_stack - (([ loc_i ], [], [],`BranchTag) - :: ([ loc ] @+ g', t', k', tag) :: s) - | Pos i, (g, t, k,`BranchTag) :: (g', t', k', tag) :: s -> - let loc_i, g' = extract_pos i g' in - new_stack - (([ loc_i ], [], [],`BranchTag) - :: (g', t' @+ filter_open g, k', tag) :: s) - | Pos _, _ -> fail (lazy "can't use relative positioning here") - | Merge, (g, t, k,`BranchTag) :: (g', t', k', tag) :: s -> - new_stack ((t @+ filter_open g @+ g' @+ k, t', k', tag) :: s) - | Merge, _ -> fail (lazy "can't merge goals here") - | Focus [], _ -> assert false - | Focus gs, s -> - let stack_locs = - let add_l acc _ _ l = if is_open l then l :: acc else acc in - Stack.fold ~env:add_l ~cont:add_l ~todo:add_l [] s - in - List.iter - (fun g -> - if not (List.exists (fun l -> goal_of_loc l = g) stack_locs) then - fail (lazy (sprintf "goal %d not found (or closed)" g))) - gs; - new_stack ((zero_pos gs, [], [], `FocusTag) :: deep_close gs s) - | Unfocus, ([], [], [], `FocusTag) :: s -> new_stack s - | Unfocus, _ -> fail (lazy "can't unfocus, some goals are still open") - in - debug_print (lazy (sprintf "EVAL CONT %s -> %s" (pp_t cmd) (pp stack))); - S.set_stack stack ostatus -end - diff --git a/helm/ocaml/tactics/continuationals.mli b/helm/ocaml/tactics/continuationals.mli deleted file mode 100644 index d40202d4b..000000000 --- a/helm/ocaml/tactics/continuationals.mli +++ /dev/null @@ -1,126 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -exception Error of string Lazy.t - -type goal = ProofEngineTypes.goal - -(** {2 Goal stack} *) - -module Stack: -sig - type switch = Open of goal | Closed of goal - type locator = int * switch - type tag = [ `BranchTag | `FocusTag | `NoTag ] - type entry = locator list * locator list * locator list * tag - type t = entry list - - val empty: t - - val find_goal: t -> goal (** find "next" goal *) - val is_empty: t -> bool (** a singleton empty level *) - val of_metasenv: Cic.metasenv -> t - val head_switches: t -> switch list (** top level switches *) - val head_goals: t -> goal list (** top level goals *) - val head_tag: t -> tag (** top level tag *) - val shift_goals: t -> goal list (** second level goals *) - val open_goals: t -> goal list (** all (Open) goals *) - val goal_of_switch: switch -> goal - - (** @param int depth, depth 0 is the top of the stack *) - val fold: - env: ('a -> int -> tag -> locator -> 'a) -> - cont:('a -> int -> tag -> locator -> 'a) -> - todo:('a -> int -> tag -> locator -> 'a) -> - 'a -> t -> 'a - - val iter: (** @param depth as above *) - env: (int -> tag -> locator -> unit) -> - cont:(int -> tag -> locator -> unit) -> - todo:(int -> tag -> locator -> unit) -> - t -> unit - - val map: (** @param depth as above *) - env: (int -> tag -> locator list -> locator list) -> - cont:(int -> tag -> locator list -> locator list) -> - todo:(int -> tag -> locator list -> locator list) -> - t -> t - - val pp: t -> string -end - -(** {2 Functorial interface} *) - -module type Status = -sig - type input_status - type output_status - - type tactic - - val id_tactic : tactic - val mk_tactic : (input_status -> output_status) -> tactic - val apply_tactic : tactic -> input_status -> output_status - - val goals : output_status -> goal list * goal list (** opened, closed goals *) - val set_goals: goal list * goal list -> output_status -> output_status - val get_stack : input_status -> Stack.t - val set_stack : Stack.t -> output_status -> output_status - - val inject : input_status -> output_status - val focus : goal -> output_status -> input_status -end - -module type C = -sig - type input_status - type output_status - type tactic - - type tactical = - | Tactic of tactic - | Skip - - type t = - | Dot - | Semicolon - - | Branch - | Shift - | Pos of int - | Merge - | Focus of goal list - | Unfocus - - | Tactical of tactical - - val eval: t -> input_status -> output_status -end - -module Make (S: Status) : C - with type tactic = S.tactic - and type input_status = S.input_status - and type output_status = S.output_status - diff --git a/helm/ocaml/tactics/discriminationTactics.ml b/helm/ocaml/tactics/discriminationTactics.ml deleted file mode 100644 index 9e5bc7f43..000000000 --- a/helm/ocaml/tactics/discriminationTactics.ml +++ /dev/null @@ -1,554 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let debug_print = fun _ -> () - -let rec injection_tac ~term = - let injection_tac ~term status = - let (proof, goal) = status in - 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,_ = CicUtil.lookup_meta goal metasenv in - let termty,_ = (* TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in - ProofEngineTypes.apply_tactic - (match termty with - (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]) - when LibraryObjects.is_eq_URI equri -> ( - 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 (lazy "Discriminate: i 2 termini hanno in testa lo stesso costruttore, ma applicato a un numero diverso di termini. possibile???")) - 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 (lazy "Injection: not a projectable equality")) - ) - | _ -> raise (ProofEngineTypes.Fail (lazy "Injection: not an equation")) - ) status - in - ProofEngineTypes.mk_tactic (injection_tac ~term) - -and injection1_tac ~term ~i = - let injection1_tac ~term ~i status = - let (proof, goal) = status in - (* 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,_ = CicUtil.lookup_meta goal metasenv in - let termty,_ = (* TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in - match termty with (* an equality *) - (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]) - when LibraryObjects.is_eq_URI equri -> ( - match tty with (* some inductive type *) - (C.MutInd (turi,typeno,exp_named_subst)) - | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::_)) -> - 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 - | _ -> assert false - in - let tty',_ = - CicTypeChecker.type_of_aux' metasenv context t1' - CicUniv.empty_ugraph in - let pattern = - match fst(CicEnvironment.get_obj - CicUniv.empty_ugraph 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 (lazy "Discriminate: object is not an Inductive Definition: it's imposible")) - in - ProofEngineTypes.apply_tactic - (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:(ProofEngineTypes.mk_tactic - (fun status -> - let (proof, goal) = status in - let _,metasenv,_,_ = proof in - let _,context,gty = CicUtil.lookup_meta goal metasenv in - let new_t1' = - match gty with - (C.Appl (C.MutInd (_,_,_)::arglist)) -> - List.nth arglist 1 - | _ -> raise (ProofEngineTypes.Fail (lazy "Injection: goal after cut is not correct")) - in - ProofEngineTypes.apply_tactic - (ReductionTactics.change_tac - ~pattern:(ProofEngineTypes.conclusion_pattern - (Some new_t1')) - (fun _ m u -> - 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], m, u)) - status - )) - ~continuation: - (T.then_ - ~start: - (EqualityTactics.rewrite_simpl_tac - ~direction:`LeftToRight - ~pattern:(ProofEngineTypes.conclusion_pattern None) - term) - ~continuation:EqualityTactics.reflexivity_tac - ) - ]) - status - | _ -> raise (ProofEngineTypes.Fail (lazy "Discriminate: not a discriminable equality")) - ) - | _ -> raise (ProofEngineTypes.Fail (lazy "Discriminate: not an equality")) - in - ProofEngineTypes.mk_tactic (injection1_tac ~term ~i) -;; - -exception TwoDifferentSubtermsFound of int - -(* term ha tipo t1=t2; funziona solo se t1 e t2 hanno in testa costruttori -diversi *) - -let discriminate'_tac ~term = - let module C = Cic in - let module U = UriManager in - let module P = PrimitiveTactics in - let module T = Tacticals in - let fail msg = raise (ProofEngineTypes.Fail (lazy ("Discriminate: " ^ msg))) in - let find_discriminating_consno t1 t2 = - let rec aux t1 t2 = - match t1, t2 with - | C.MutConstruct _, C.MutConstruct _ when t1 = t2 -> None - | C.Appl ((C.MutConstruct _ as constr1) :: args1), - C.Appl ((C.MutConstruct _ as constr2) :: args2) - when constr1 = constr2 -> - let rec aux_list l1 l2 = - match l1, l2 with - | [], [] -> None - | hd1 :: tl1, hd2 :: tl2 -> - (match aux hd1 hd2 with - | None -> aux_list tl1 tl2 - | Some _ as res -> res) - | _ -> (* same constructor applied to a different number of args *) - assert false - in - aux_list args1 args2 - | ((C.MutConstruct (_,_,consno1,subst1)), - (C.MutConstruct (_,_,consno2,subst2))) - | ((C.MutConstruct (_,_,consno1,subst1)), - (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _))) - | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)), - (C.MutConstruct (_,_,consno2,subst2))) - | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)), - (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _))) - when (consno1 <> consno2) || (subst1 <> subst2) -> - Some consno2 - | _ -> fail "not a discriminable equality" - in - aux t1 t2 - in - let mk_pattern turi typeno consno context left_args = - (* a list of "True" except for the element in position consno which - * is "False" *) - match fst (CicEnvironment.get_obj CicUniv.empty_ugraph turi) with - | C.InductiveDefinition (ind_type_list,_,nr_ind_params,_) -> - let _,_,_,constructor_list = List.nth ind_type_list typeno in - let false_constr_id,_ = List.nth constructor_list (consno - 1) in - List.map - (fun (id,cty) -> - (* dubbio: e' corretto ridurre in questo context ??? *) - let red_ty = CicReduction.whd context cty in - let rec aux t k = - match t with - | C.Prod (_,_,target) when (k <= nr_ind_params) -> - CicSubstitution.subst (List.nth left_args (k-1)) - (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(LibraryObjects.false_URI (),0,[])) - else (C.MutInd(LibraryObjects.true_URI (),0,[])) - in - (CicSubstitution.lift 1 (aux red_ty 1))) - constructor_list - | _ -> (* object is not an inductive definition *) - assert false - in - let discriminate'_tac ~term status = - let (proof, goal) = status in - let _,metasenv,_,_ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let termty,_ = - CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph - in - match termty with - | (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]) - when LibraryObjects.is_eq_URI equri -> - let turi,typeno,exp_named_subst,left_args = - match tty with - | (C.MutInd (turi,typeno,exp_named_subst)) -> - turi,typeno,exp_named_subst,[] - | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::left_args)) -> - turi,typeno,exp_named_subst,left_args - | _ -> fail "not a discriminable equality" - in - let consno = - match find_discriminating_consno t1 t2 with - | Some consno -> consno - | None -> fail "discriminating terms are structurally equal" - in - let pattern = mk_pattern turi typeno consno context left_args in - let (proof',goals') = - ProofEngineTypes.apply_tactic - (EliminationTactics.elim_type_tac - (C.MutInd (LibraryObjects.false_URI (), 0, []))) - status - in - (match goals' with - | [goal'] -> - let _,metasenv',_,_ = proof' in - let _,context',gty' = CicUtil.lookup_meta goal' metasenv' in - ProofEngineTypes.apply_tactic - (T.then_ - ~start: - (ReductionTactics.change_tac - ~pattern:(ProofEngineTypes.conclusion_pattern (Some gty')) - (fun _ m u -> - C.Appl [ - C.Lambda ( C.Name "x", tty, - C.MutCase (turi, typeno, - (C.Lambda ((C.Name "x"), - (CicSubstitution.lift 1 tty), - (C.Sort C.Prop))), - (C.Rel 1), pattern)); - t2 ], m, u)) - ~continuation: - (T.then_ - ~start: - (EqualityTactics.rewrite_simpl_tac - ~direction:`RightToLeft - ~pattern:(ProofEngineTypes.conclusion_pattern None) - term) - ~continuation: - (IntroductionTactics.constructor_tac ~n:1))) - (proof',goal') - | [] -> fail "ElimType False left no goals" - | _ -> fail "ElimType False left more than one goal") - | _ -> fail "not an equality" - in - ProofEngineTypes.mk_tactic (discriminate'_tac ~term) - -let discriminate_tac ~term = - let discriminate_tac ~term status = - ProofEngineTypes.apply_tactic - (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 - in - ProofEngineTypes.mk_tactic (discriminate_tac ~term) - -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 = Tacticals.id_tac - (* -(* 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 = CicUtil.lookup_meta 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 = - let module C = Cic in - let module U = UriManager in - let module P = PrimitiveTactics in - let module T = Tacticals in - let (proof, goal) = status in - let _,metasenv,_,_ = proof in - let _,context,_ = CicUtil.lookup_meta 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 = -debug_print (lazy ("XXXX t1 " ^ CicPp.ppterm t1)) ; -debug_print (lazy ("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 -debug_print (lazy ("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 fst(CicEnvironment.get_obj turi - CicUniv.empty_ugraph) with - C.InductiveDefinition (ind_type_list,_,nr_ind_params) -> -debug_print (lazy ("XXXX nth " ^ (string_of_int (List.length ind_type_list)) ^ " " ^ (string_of_int typeno))) ; - let _,_,_,constructor_list = (List.nth ind_type_list typeno) in -debug_print (lazy ("XXXX nth " ^ (string_of_int (List.length constructor_list)) ^ " " ^ (string_of_int consno2'))) ; - let false_constr_id,_ = List.nth constructor_list (consno2' - 1) in -debug_print (lazy "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' = - CicUtil.lookup_meta goal' metasenv' - in - 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: - ( -debug_print (lazy ("XXXX rewrite<-: " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1' ; t2'])))); -debug_print (lazy ("XXXX rewrite<-: " ^ CicPp.ppterm (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1' ; t2']))) ; -debug_print (lazy ("XXXX equri: " ^ U.string_of_uri equri)) ; -debug_print (lazy ("XXXX tty : " ^ CicPp.ppterm tty)) ; -debug_print (lazy ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1'))) ; -debug_print (lazy ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2'))) ; -if (CicTypeChecker.type_of_aux' metasenv' context' t1') <> tty then debug_print (lazy ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1'))) ; -if (CicTypeChecker.type_of_aux' metasenv' context' t2') <> tty then debug_print (lazy ("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 debug_print (lazy ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' - metasenv' context' t1'))) ; debug_print (lazy ("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 - -debug_print (lazy ("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) - ) - (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") -;; - -*) - - - diff --git a/helm/ocaml/tactics/discriminationTactics.mli b/helm/ocaml/tactics/discriminationTactics.mli deleted file mode 100644 index f1153256f..000000000 --- a/helm/ocaml/tactics/discriminationTactics.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/tactics/doc/Makefile b/helm/ocaml/tactics/doc/Makefile deleted file mode 100644 index b7d8fb45c..000000000 --- a/helm/ocaml/tactics/doc/Makefile +++ /dev/null @@ -1,124 +0,0 @@ - -# -# Generic makefile for latex -# -# Author: Stefano Zacchiroli -# -# Created: Sun, 29 Jun 2003 12:00:55 +0200 zack -# Last-Modified: Mon, 10 Oct 2005 15:37:12 +0200 zack -# - -######################################################################## - -# list of .tex _main_ files -TEXS = main.tex - -# number of runs of latex (for table of contents, list of figures, ...) -RUNS = 1 - -# do you need bibtex? -BIBTEX = no - -# would you like to use pdflatex? -PDF_VIA_PDFLATEX = yes - -# which formats generated by default ("all" target)? -# (others will be generated by "world" target) -# see AVAILABLE_FORMATS below -BUILD_FORMATS = dvi - -# which format to be shown on "make show" -SHOW_FORMAT = dvi - -######################################################################## - -AVAILABLE_FORMATS = dvi ps ps.gz pdf html - -ADVI = advi -BIBTEX = bibtex -BROWSER = galeon -DVIPDF = dvipdf -DVIPS = dvips -GV = gv -GZIP = gzip -HEVEA = hevea -ISPELL = ispell -LATEX = latex -PDFLATEX = pdflatex -PRINT = lpr -XDVI = xdvi -XPDF = xpdf - -ALL_FORMATS = $(BUILD_FORMATS) -WORLD_FORMATS = $(AVAILABLE_FORMATS) - -all: $(ALL_FORMATS) -world: $(WORLD_FORMATS) - -DVIS = $(TEXS:.tex=.dvi) -PSS = $(TEXS:.tex=.ps) -PSGZS = $(TEXS:.tex=.ps.gz) -PDFS = $(TEXS:.tex=.pdf) -HTMLS = $(TEXS:.tex=.html) - -dvi: $(DVIS) -ps: $(PSS) -ps.gz: $(PSGZS) -pdf: $(PDFS) -html: $(HTMLS) - -show: show$(SHOW_FORMAT) -showdvi: $(DVIS) - $(XDVI) $< -showps: $(PSS) - $(GV) $< -showpdf: $(PDFS) - $(XPDF) $< -showpsgz: $(PSGZS) - $(GV) $< -showps.gz: showpsgz -showhtml: $(HTMLS) - $(BROWSER) $< - -print: $(PSS) - $(PRINT) $^ - -clean: - rm -f \ - $(TEXS:.tex=.dvi) $(TEXS:.tex=.ps) $(TEXS:.tex=.ps.gz) \ - $(TEXS:.tex=.pdf) $(TEXS:.tex=.aux) $(TEXS:.tex=.log) \ - $(TEXS:.tex=.html) $(TEXS:.tex=.out) $(TEXS:.tex=.haux) \ - $(TEXS:.tex=.htoc) $(TEXS:.tex=.tmp) - -%.dvi: %.tex - $(LATEX) $< - if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi - if [ "$(RUNS)" -gt 1 ]; then \ - for i in seq 1 `expr $(RUNS) - 1`; do \ - $(LATEX) $<; \ - done; \ - fi -ifeq ($(PDF_VIA_PDFLATEX),yes) -%.pdf: %.tex - $(PDFLATEX) $< - if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi - if [ "$(RUNS)" -gt 1 ]; then \ - for i in seq 1 `expr $(RUNS) - 1`; do \ - $(PDFLATEX) $<; \ - done; \ - fi -else -%.pdf: %.dvi - $(DVIPDF) $< $@ -endif -%.ps: %.dvi - $(DVIPS) $< -%.ps.gz: %.ps - $(GZIP) -c $< > $@ -%.html: %.tex - $(HEVEA) -fix $< - -.PHONY: all ps pdf html clean - -######################################################################## - diff --git a/helm/ocaml/tactics/doc/body.tex b/helm/ocaml/tactics/doc/body.tex deleted file mode 100644 index 8b7bbc9b0..000000000 --- a/helm/ocaml/tactics/doc/body.tex +++ /dev/null @@ -1,474 +0,0 @@ - -\section{Tinycals: \MATITA{} tacticals} - -\subsection{Introduction} - -% outline: -% - script - -Most of modern mainstream proof assistants enable input of proofs of -propositions using a textual language. Compilation units written in such -languages are sequence of textual \emph{statements} and are usually called -\emph{scripts} as a whole. Scripts are so entangled with proof assistants that -they drived the design of state of the art of their Graphical User Interfaces -(GUIs). Fig.~\ref{fig:proofgeneral} is a screenshot of Proof General, a generic -proof assistant interface based on Emacs widely used and compatible with systems -like Coq, Isabelle, PhoX, LEGO, and many more. Other system specific GUIs exist -but share the same design, understanding it and they way such GUIs are operated -is relevant to our discussion. - -%\begin{figure}[ht] -% \begin{center} -% \includegraphic{pics/pg-coq-screenshot} -% \caption{Proof General: a generic interface for proof assistants} -% \label{fig:proofgeneral} -% \end{center} -%\end{figure} - -% - modo di lavorare - -The paradigm behind such GUIs is quite simple. The window on the left is an -editable text area containing the script and split in two by an \emph{execution -point} (the point where background color changes). The part starting at the -beginning of the script and ending at the marker (distinguishable for having a -light blue background in the picture) contains the sequence of statements which -have already been fed into the system. We will call this former part -\emph{locked area} since the user is not free to change it as her willing. The -remaining part, which extends until the end of the script, is named -\emph{scratch area} and can be freely modified. The window on the right is -read-only for the user and includes at the top the current proof status, when -some proof is ongoing, and at the bottom a message area used for error messages -or other feedback from the system to the user. The user usually proceed -alternating editing of the scratch area and execution point movements (forward -to evaluate statements and backward to retract statements if she need to change -something in the locked area). - -Execution point movements are not free, but constrained by the structure of the -script language used. The granularity is that of statements. In systems like Coq -or \MATITA{} examples of statements are: inductive definitions, theorems, and -tactics. \emph{Tactics} are the building blocks of proofs. For example, the -following script snippet contains a theorem about a relationship of natural -minus with natural plus, along with its proof (line numbers have been added for -the sake of presentation) as it can be found in the standard library of the -\MATITA{} proof assistant: - -%\begin{example} -%\begin{Verbatim} -%theorem eq_minus_minus_minus_plus: \forall n,m,p:nat. (n-m)-p = n-(m+p). -% intros. -% cut (m+p \le n \or m+p \nleq n). -% elim Hcut. -% symmetry. -% apply plus_to_minus. -% rewrite > assoc_plus. -% rewrite > (sym_plus p). -% rewrite < plus_minus_m_m. -% rewrite > sym_plus. -% rewrite < plus_minus_m_m. -% reflexivity. -% apply (trans_le ? (m+p)). -% rewrite < sym_plus. -% apply le_plus_n. -% assumption. -% apply le_plus_to_minus_r. -% rewrite > sym_plus. -% assumption. -% rewrite > (eq_minus_n_m_O n (m+p)). -% rewrite > (eq_minus_n_m_O (n-m) p). -% reflexivity. -% apply le_plus_to_minus. -% apply lt_to_le. -% rewrite < sym_plus. -% apply not_le_to_lt. -% assumption. -% apply lt_to_le. -% apply not_le_to_lt. -% assumption. -% apply (decidable_le (m+p) n). -%qed. -%\end{Verbatim} -%\end{example} - -The script snippet is made of 32 statements, one per line (but this is not a -requirement of the \MATITA{} script language, namely \emph{Grafite}). The first -statement is the assertion that the user want to prove a proposition with a -given type, specified after the ``\texttt{:}'', its execution will cause -\MATITA{} to enter the proof state showing to the user the list of goals that -still need to be proved to conclude the proof. The last statement (\texttt{Qed}) -is an assertion that the proof is completed. All intertwining statements are -tactic applications. - -Given the constraint we mentioned about execution point, while inserting (or -replaying) the above script, the user may position it at the end of any line, -having feedback about the status of the proof in that point. See for example -Fig.~\ref{fig:matita} where an intermediate proof status is shown. - -%\begin{figure}[ht] -% \begin{center} -% \includegraphic{matita_screenshot} -% \caption{Matita: ongoing proof} -% \label{fig:matita} -% \end{center} -%\end{figure} - -% - script: sorgenti di un linguaggio imperativo, oggetti la loro semantica -% - script = sequenza di comandi - -You can create an analogy among scripts and sources written in an imperative -programming language, seeing proofs as the denotational semantics of that -language. In such analogy the language used in the script of -Fig.~\ref{fig:matita} is rather poor offering as the only programming construct -the sequential composition of tactic application. What enables step by step -execution is the operational semantics of each tactic application (i.e. how it -changes the current proof status). - -% - pro: concisi - -This kind of scripts have both advantages and drawbacks. Among advantages we can -for sure list the effectiveness of the language. In spite of being longer than -the corresponding informal text version of the proof (a gap hardly fillable with -proof assistants~\cite{debrujinfactor}), the script is fast to write in -interactive use, enable cut and paste approaches, and gives a lot of flexibility -(once the syntax is known of course) in tactic application via additional flags -that can be easily passed to them. - -% - cons: non strutturati, hanno senso solo via reply - -Unfortunately, drawbacks are non negligible. Scripts like those of -Fig.~\ref{fig:matita} are completely unstructured and hardly can be assigned a -meaning simply looking at them. Even experienced users, that knows the details -of all involved tactics, can hardly figure what a script mean without replaying -the proof in their heads. This indeed is a key aspect of scripts: they are -meaningful via \emph{reply}. People interested in understanding a formal proof -written as a script usually start the preferred tool and execute it step by -step. A contrasting approach compared to what happens with high level -programming languages where looking at the code is usually enough to understand -its details. - -% - cons: poco robusti (wrt cambiamenti nelle tattiche, nello statement, ...) - -Additionally, scripts are usually not robust against changes, intending with -that term both changes in the statement that need to be proved (e.g. -strenghtening of an inductive hypothesis) and changes in the implementation of -involved tactics. This drawback can force backward compatibility and slow down -systems development. A real-life example in the history of \MATITA{} was the -reordering of goals after tactic application; the total time needed to port the -(tiny at the time) standard library of no more that 30 scripts was 2 days work. -Having the scripts being structured the task could have been done in much less -time and even automated. - -Tacticals are an attempt at solving this drawbacks. - -\subsection{Tacticals} - -% - script = sequenza di comandi + tatticali - -\ldots descrizione dei tatticali \ldots - -% - pro: fattorizzazione - -Tacticals as described above have several advantages with respect to plain -sequential application of tactics. First of all they enable a great amount of -factorization of proofs using the sequential composition ``;'' operator. Think -for example at proofs by induction on inductive types with several constructors, -which are so frequent when formalizing properties from the computer science -field. It is often the case that several, or even all, cases can be dealt with -uniform strategies, which can in turn by coded in a single script snipped which -can appear only once, at the right hand side of a ``;''. - -% - pro: robustezza - -Scripts properly written using the tacticals above are even more robust with -respect to changes. The additional amount of flexibility is given by -``conditional'' constructs like \texttt{try}, \texttt{solve}, and -\texttt{first}. Using them the scripts no longer contain a single way of -proceeding from one status of the proof to another, they can list more. The wise -proof coder may exploit this mechanism providing fallbacks in order to be more -robust to future changes in tactics implementation. Of course she is not -required to! - -% - pro: strutturazione delle prove (via branching) - -Finally, the branching constructs \texttt{[}, \texttt{|}, and \texttt{]} enable -proof structuring. Consider for example an alternative, branching based, version -of the example above: - -%\begin{example} -%\begin{Verbatim} -%... -%\end{Verbatim} -%\end{example} - -Tactic applications are the same of the previous version of the script, but -branching tacticals are used. The above version is highly more readable and -without executing it key points of the proofs like induction cases can be -observed. - -% - tradeoff: utilizzo dei tatticali vs granularita' dell'esecuzione -% (impossibile eseguire passo passo) - -One can now wonder why thus all scripts are not written in a robust, concise and -structured fashion. The reason is the existence of an unfortunate tradeoff -between the need of using tacticals and the impossibility of executing step by -step \emph{inside} them. Indeed, trying to mimic the structured version of the -proof above in GUIs like Proof General or CoqIDE will result in a single macro -step that will bring you from the beginning of the proof directly at the end of -it! - -Tinycals as implemented in \MATITA{} are a solution to this problem, preserving -the usual tacticals semantics, giving meaning to intermediate execution point -inside complex tacticals. - -\subsection{Tinycals} - -\subsection{Tinycals semantics} - -\subsubsection{Language} - -\[ -\begin{array}{rcll} - S & ::= & & \mbox{(\textbf{continuationals})}\\ - & & \TACTIC{T} & \mbox{(tactic)}\\[2ex] - & | & \DOT & \mbox{(dot)} \\ - & | & \SEMICOLON & \mbox{(semicolon)} \\ - & | & \BRANCH & \mbox{(branch)} \\ - & | & \SHIFT & \mbox{(shift)} \\ - & | & \POS{i} & \mbox{(relative positioning)} \\ - & | & \MERGE & \mbox{(merge)} \\[2ex] - & | & \FOCUS{g_1,\dots,g_n} & \mbox{(absolute positioning)} \\ - & | & \UNFOCUS & \mbox{(unfocus)} \\[2ex] - & | & S ~ S & \mbox{(sequential composition)} \\[2ex] - T & : := & & \mbox{(\textbf{tactics})}\\ - & & \SKIP & \mbox{(skip)} \\ - & | & \mathtt{reflexivity} & \\ - & | & \mathtt{apply}~t & \\ - & | & \dots & -\end{array} -\] - -\subsubsection{Status} - -\[ -\begin{array}{rcll} - \xi & & & \mbox{(proof status)} \\ - \mathit{goal} & & & \mbox{(proof goal)} \\[2ex] - - \SWITCH & = & \OPEN~\mathit{goal} ~ | ~ \CLOSED~\mathit{goal} & \\ - \mathit{locator} & = & \INT\times\SWITCH & \\ - \mathit{tag} & = & \BRANCHTAG ~ | ~ \FOCUSTAG \\[2ex] - - \Gamma & = & \mathit{locator}~\LIST & \mbox{(context)} \\ - \tau & = & \mathit{locator}~\LIST & \mbox{(todo)} \\ - \kappa & = & \mathit{locator}~\LIST & \mbox{(dot's future)} \\[2ex] - - \mathit{stack} & = & (\Gamma\times\tau\times\kappa\times\mathit{tag})~\LIST - \\[2ex] - - \mathit{status} & = & \xi\times\mathit{stack} \\ -\end{array} -\] - -\paragraph{Utilities} -\begin{itemize} - \item $\ZEROPOS([g_1;\cdots;g_n]) = - [\langle 0,\OPEN~g_1\rangle;\cdots;\langle 0,\OPEN~g_n\rangle]$ - \item $\INITPOS([\langle i_1,s_1\rangle;\cdots;\langle i_n,s_n\rangle]) = - [\langle 1,s_1\rangle;\cdots;\langle n,s_n\rangle]$ - \item $\ISFRESH(s) = - \left\{ - \begin{array}{ll} - \mathit{true} & \mathrm{if} ~ s = \langle n, \OPEN~g\rangle\land n > 0 \\ - \mathit{false} & \mathrm{otherwise} \\ - \end{array} - \right.$ - \item $\FILTEROPEN(\mathit{locs})= - \left\{ - \begin{array}{ll} - [] & \mathrm{if}~\mathit{locs} = [] \\ - \langle i,\OPEN~g\rangle :: \FILTEROPEN(\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} \\ - \FILTEROPEN(\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\ - \end{array} - \right.$ - \item $\REMOVEGOALS(G,\mathit{locs}) = - \left\{ - \begin{array}{ll} - [] & \mathrm{if}~\mathit{locs} = [] \\ - \REMOVEGOALS(G,\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} - \land g\in G\\ - hd :: \REMOVEGOALS(G,\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\ - \end{array} - \right.$ - \item $\DEEPCLOSE(G,S)$: (intuition) given a set of goals $G$ and a stack $S$ - it returns a new stack $S'$ identical to the given one with the exceptions - that each locator whose goal is in $G$ is marked as closed in $\Gamma$ stack - components and removed from $\tau$ and $\kappa$ components. - \item $\GOALS(S)$: (inutition) return all goals appearing in whatever position - on a given stack $S$, appearing in an \OPEN{} switch. -\end{itemize} - -\paragraph{Invariants} -\begin{itemize} - \item $\forall~\mathrm{entry}~\ENTRY{\Gamma}{\tau}{\kappa}{t}, \forall s - \in\tau\cup\kappa, \exists g, s = \OPEN~g$ (each locator on the stack in - $\tau$ and $\kappa$ components has an \OPEN~switch). - \item Unless \FOCUS{} is used the stack contains no duplicate goals. - \item $\forall~\mathrm{locator}~l\in\Gamma \mbox{(with the exception of the - top-level $\Gamma$)}, \ISFRESH(l)$. -\end{itemize} - -\subsubsection{Semantics} - -\[ -\begin{array}{rcll} - \SEMOP{\cdot} & : & C -> \mathit{status} -> \mathit{status} & - \mbox{(continuationals semantics)} \\ - \TSEMOP{\cdot} & : & T -> \xi -> \SWITCH -> - \xi\times\GOAL~\LIST\times\GOAL~\LIST & \mbox{(tactics semantics)} \\ -\end{array} -\] - -\[ -\begin{array}{rcl} - \mathit{apply\_tac} & : & T -> \xi -> \GOAL -> - \xi\times\GOAL~\LIST\times\GOAL~\LIST -\end{array} -\] - -\[ -\begin{array}{rlcc} - \TSEM{T}{\xi}{\OPEN~g} & = & \mathit{apply\_tac}(T,\xi,n) & T\neq\SKIP\\ - \TSEM{\SKIP}{\xi}{\CLOSED~g} & = & \langle \xi, [], [g]\rangle & -\end{array} -\] - -\[ -\begin{array}{rcl} - - \SEM{\TACTIC{T}}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S} - & = - & \langle - \xi_n, - \ENTRY{\Gamma'}{\tau'}{\kappa'}{t} -% \ENTRY{\ZEROPOS(G^o_n)}{\tau\setminus G^c_n}{\kappa\setminus G^o_n}{t} - :: \DEEPCLOSE(G^c_n,S) - \rangle - \\[1ex] - \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{where} ~ n\geq 1} - \\[1ex] - \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~ - \Gamma' = \ZEROPOS(G^o_n) - \land \tau' = \REMOVEGOALS(G^c_n,\tau) - \land \kappa' = \REMOVEGOALS(G^o_n,\kappa) - } - \\[1ex] - \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~ - \left\{ - \begin{array}{rcll} - \langle\xi_0, G^o_0, G^c_0\rangle & = & \langle\xi, [], []\rangle \\ - \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle - & = - & \langle\xi_i, G^o_i, G^c_i\rangle - & l_{i+1}\in G^c_i \\ - \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle - & = - & \langle\xi, (G^o_i\setminus G^c)\cup G^o, G^c_i\cup G^c\rangle - & l_{i+1}\not\in G^c_i \\[1ex] - & & \mathit{where} ~ \langle\xi,G^o,G^c\rangle=\TSEM{T}{\xi_i}{l_{i+1}} \\ - \end{array} - \right. - } - \\[6ex] - - \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{\kappa}{t}::S} - & = - & \langle \xi, \ENTRY{l_1}{\tau}{\GIN[2]\cup\kappa}{t}::S \rangle - \\[1ex] - & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=\GIN \land n\geq 1 - \\[2ex] - - \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{l::\kappa}{t}::S} - & = - & \langle \xi, \ENTRY{[l]}{\tau}{\kappa}{t}::S \rangle - \\[1ex] - & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=[] - \\[2ex] - - \SEM{~\SEMICOLON~}{S} & = & \langle \xi, S \rangle \\[1ex] - - \SEM{~\BRANCH~}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S} - \quad - & = - & \langle\xi, \ENTRY{[l_1']}{[]}{[]}{\BRANCHTAG} - ::\ENTRY{[l_2';\cdots;l_n']}{\tau}{\kappa}{t}::S - \\[1ex] - & & \mathrm{where} ~ n\geq 2 ~ \land ~ \INITPOS(\GIN)=[l_1';\cdots;l_n'] - \\[2ex] - - \SEM{~\SHIFT~} - {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\GIN}{\tau'}{\kappa'}{t'} - ::S} - & = - & \langle - \xi, \ENTRY{[l_1]}{\tau\cup\FILTEROPEN(\Gamma)}{[]}{\BRANCHTAG} - ::\ENTRY{\GIN[2]}{\tau'}{\kappa'}{t'}::S - \rangle - \\[1ex] - & & \mathrm{where} ~ n\geq 1 - \\[2ex] - - \SEM{~\POS{i}~} - {\ENTRY{[l]}{[]}{[]}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S} - & = - & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG} - ::\ENTRY{l :: (\Gamma'\setminus [l_i])}{\tau'}{\kappa'}{t'}::S \rangle - \\[1ex] - & & \mathrm{where} ~ \langle i,l'\rangle = l_i\in \Gamma'~\land~\ISFRESH(l) - \\[2ex] - - \SEM{~\POS{i}~} - {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG} - ::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S} - & = - & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG} - ::\ENTRY{\Gamma'\setminus [l_i]}{\tau'\cup\FILTEROPEN(\Gamma)}{\kappa'}{t'}::S - \rangle - \\[1ex] - & & \mathrm{where} ~ \langle i, l'\rangle = l_i\in \Gamma' - \\[2ex] - - \SEM{~\MERGE~} - {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'} - ::S} - & = - & \langle \xi, - \ENTRY{\tau\cup\FILTEROPEN(\Gamma)\cup\Gamma'\cup\kappa}{\tau'}{\kappa'}{t'} - :: S - \rangle - \\[2ex] - - \SEM{\FOCUS{g_1,\dots,g_n}}{S} - & = - & \langle \xi, \ENTRY{\ZEROPOS([g_1;\cdots;g_n])}{[]}{[]}{\FOCUSTAG} - ::\DEEPCLOSE(S) - \rangle - \\[1ex] - & & \mathrm{where} ~ - \forall i=1,\dots,n,~g_i\in\GOALS(S) - \\[2ex] - - \SEM{\UNFOCUS}{\ENTRY{[]}{[]}{[]}{\FOCUSTAG}::S} - & = - & \langle \xi, S\rangle \\[2ex] - -\end{array} -\] - -\subsection{Related works} - -In~\cite{fk:strata2003}, Kirchner described a small step semantics for Coq -tacticals and PVS strategies. - diff --git a/helm/ocaml/tactics/doc/infernce.sty b/helm/ocaml/tactics/doc/infernce.sty deleted file mode 100644 index fc4afeaaf..000000000 --- a/helm/ocaml/tactics/doc/infernce.sty +++ /dev/null @@ -1,217 +0,0 @@ -%% -%% This is file `infernce.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,inference') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from infernce.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\@@tempa,\@@tempb,\@adjustPremises,\@inference} -\TestForConflict{\@inferenceBack,\@inferenceFront,\@inferenceOrPremis} -\TestForConflict{\@premises,\@processInference,\@processPremiseLine} -\TestForConflict{\@setLengths,\inference,\predicate,\predicatebegin} -\TestForConflict{\predicateend,\setnamespace,\setpremisesend} -\TestForConflict{\setpremisesspace,\@makeLength,\@@space} -\TestForConflict{\@@aLineBox,\if@@shortDivider} -\newtoks\@@tempa -\newtoks\@@tempb -\newcommand{\@makeLength}[4]{ - \@@tempa=\expandafter{\csname @@#2\endcsname} - \@@tempb=\expandafter{\csname @set#2\endcsname} % - \expandafter \newlength \the\@@tempa - \expandafter \newcommand \the\@@tempb {} - \expandafter \newcommand \csname set#1\endcsname[1]{} - \expandafter \xdef \csname set#1\endcsname##1% - {{\dimen0=##1}% - \noexpand\renewcommand{\the\@@tempb}{% - \noexpand\setlength{\the \@@tempa}{##1 #4}}% - }% - \csname set#1\endcsname{#3} - \@@tempa=\expandafter{\@setLengths} % - \edef\@setLengths{\the\@@tempa \the\@@tempb} % - } - -\newcommand{\@setLengths}{% - \setlength{\baselineskip}{1.166em}% - \setlength{\lineskip}{1pt}% - \setlength{\lineskiplimit}{1pt}} -\@makeLength{premisesspace}{pSpace}{1.5em}{plus 1fil} -\@makeLength{premisesend}{pEnd}{.75em}{plus 0.5fil} -\@makeLength{namespace}{nSpace}{.5em}{} -\newbox\@@aLineBox -\newif\if@@shortDivider -\newcommand{\@@space}{ } -\newcommand{\predicate}[1]{\predicatebegin #1\predicateend} -\newcommand{\predicatebegin}{$} -\newcommand{\predicateend}{$} -\def\inference{% - \@@shortDividerfalse - \expandafter\hbox\bgroup - \@ifstar{\@@shortDividertrue\@inferenceFront}% - \@inferenceFront -} -\def\@inferenceFront{% - \@ifnextchar[% - {\@inferenceFrontName}% - {\@inferenceMiddle}% -} -\def\@inferenceFrontName[#1]{% - \setbox3=\hbox{\footnotesize #1}% - \ifdim \wd3 > \z@ - \unhbox3% - \hskip\@@nSpace - \fi - \@inferenceMiddle -} -\long\def\@inferenceMiddle#1{% - \@setLengths% - \setbox\@@pBox= - \vbox{% - \@premises{#1}% - \unvbox\@@pBox - }% - \@inferenceBack -} -\long\def\@inferenceBack#1{% - \setbox\@@cBox=% - \hbox{\hskip\@@pEnd \predicate{\ignorespaces#1}\unskip\hskip\@@pEnd}% - \setbox1=\hbox{$ $}% - \setbox\@@pBox=\vtop{\unvbox\@@pBox - \vskip 4\fontdimen8\textfont3}% - \setbox\@@cBox=\vbox{\vskip 4\fontdimen8\textfont3% - \box\@@cBox}% - \if@@shortDivider - \ifdim\wd\@@pBox >\wd\@@cBox% - \dimen1=\wd\@@pBox% - \else% - \dimen1=\wd\@@cBox% - \fi% - \dimen0=\wd\@@cBox% - \hbox to \dimen1{% - \hss - $\frac{\hbox to \dimen0{\hss\box\@@pBox\hss}}% - {\box\@@cBox}$% - \hss - }% - \else - $\frac{\box\@@pBox}% - {\box\@@cBox}$% - \fi - \@ifnextchar[% - {\@inferenceBackName}%{}% - {\egroup} -} -\def\@inferenceBackName[#1]{% - \setbox3=\hbox{\footnotesize #1}% - \ifdim \wd3 > \z@ - \hskip\@@nSpace - \unhbox3% - \fi - \egroup -} -\newcommand{\@premises}[1]{% - \setbox\@@pBox=\vbox{}% - \dimen\@@maxwidth=\wd\@@cBox% - \@processPremises #1\\\end% - \@adjustPremises% -} -\newcommand{\@adjustPremises}{% - \setbox\@@pBox=\vbox{% - \@@moreLinestrue % - \loop % - \setbox\@@pBox=\vbox{% - \unvbox\@@pBox % - \global\setbox\@@aLineBox=\lastbox % - }% - \ifvoid\@@aLineBox % - \@@moreLinesfalse % - \else % - \hbox to \dimen\@@maxwidth{\unhbox\@@aLineBox}% - \fi % - \if@@moreLines\repeat% - }% -} -\def\@processPremises#1\\#2\end{% - \setbox\@@pLineBox=\hbox{}% - \@processPremiseLine #1&\end% - \setbox\@@pLineBox=\hbox{\unhbox\@@pLineBox \unskip}% - \ifdim \wd\@@pLineBox > \z@ % - \setbox\@@pLineBox=% - \hbox{\hskip\@@pEnd \unhbox\@@pLineBox \hskip\@@pEnd}% - \ifdim \wd\@@pLineBox > \dimen\@@maxwidth % - \dimen\@@maxwidth=\wd\@@pLineBox % - \fi % - \setbox\@@pBox=\vbox{\box\@@pLineBox\unvbox\@@pBox}% - \fi % - \def\sem@tmp{#2}% - \ifx \sem@tmp\empty \else % - \@ReturnAfterFi{% - \@processPremises #2\end % - }% - \fi% -} -\def\@processPremiseLine#1\end{% - \def\sem@tmp{#1}% - \ifx \sem@tmp\empty \else% - \ifx \sem@tmp\@@space \else% - \setbox\@@pLineBox=% - \hbox{\unhbox\@@pLineBox% - \@inferenceOrPremis #1\inference\end% - \hskip\@@pSpace}% - \fi% - \fi% - \def\sem@tmp{#2}% - \ifx \sem@tmp\empty \else% - \@ReturnAfterFi{% - \@processPremiseLine#2\end% - }% - \fi% -} -\def\@inferenceOrPremis#1\inference{% - \@ifnext \end - {\@dropnext{\predicate{\ignorespaces #1}\unskip}}% - {\@processInference #1\inference}% -} -\def\@processInference#1\inference\end{% - \ignorespaces #1% - \setbox3=\lastbox - \dimen3=\dp3 - \advance\dimen3 by -\fontdimen22\textfont2 - \advance\dimen3 by \fontdimen8\textfont3 - \expandafter\raise\dimen3\box3% -} -\long\def\@ReturnAfterFi#1\fi{\fi#1} -\fi -\endinput -%% -%% End of file `infernce.sty'. diff --git a/helm/ocaml/tactics/doc/ligature.sty b/helm/ocaml/tactics/doc/ligature.sty deleted file mode 100644 index a914d91d1..000000000 --- a/helm/ocaml/tactics/doc/ligature.sty +++ /dev/null @@ -1,169 +0,0 @@ -%% -%% This is file `ligature.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,ligature') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from ligature.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\@addligto,\@addligtofollowlist,\@def@ligstep} -\TestForConflict{\@@trymathlig,\@defactive,\@defligstep} -\TestForConflict{\@definemathlig,\@domathligfirsts,\@domathligfollows} -\TestForConflict{\@exitmathlig,\@firstmathligs,\@ifactive,\@ifcharacter} -\TestForConflict{\@ifinlist,\@lastvalidmathlig,\@mathliglink} -\TestForConflict{\@mathligredefactive,\@mathligsoff,\@mathligson} -\TestForConflict{\@seentoks,\@setupfirstligchar,\@try@mathlig} -\TestForConflict{\@trymathlig,\if@mathligon,\mathlig,\mathligprotect} -\TestForConflict{\mathligsoff,\mathligson,\@startmathlig,\@pushedtoks} -\newif\if@mathligon -\DeclareRobustCommand\mathlig[1]{\@addligtolists#1\@@ - \if@mathligon\mathligson\fi - \@setupfirstligchar#1\@@ - \@defligstep{}#1\@@} -\def\@mathligson{\if@mathligon\mathligson\fi} -\def\@mathligsoff{\if@mathligon\mathligsoff\@mathligontrue\fi} -\DeclareRobustCommand\mathligprotect[1]{\expandafter - \def\expandafter#1\expandafter{% - \expandafter\@mathligsoff#1\@mathligson}} -\DeclareRobustCommand\mathligson{\def\do##1##2##3{\mathcode`##1="8000}% - \@domathligfirsts\@mathligontrue} -\AtBeginDocument{\mathligson} -\DeclareRobustCommand\mathligsoff{\def\do##1##2##3{\mathcode`##1=##2}% - \@domathligfirsts\@mathligonfalse} -\edef\@mathliglink{Error: \noexpand\verb|\string\@mathliglink| expanded} -{\catcode`\A=11\catcode`\1=12\catcode`\~=13 % Letter, Other and Active -\gdef\@ifcharacter#1{\ifcat A\noexpand#1\let\next\@firstoftwo - \else\ifcat 1\noexpand#1\let\next\@firstoftwo - \else\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo - \else\let\next\@secondoftwo\fi\fi\fi\next}% -\gdef\@ifactive#1{\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo - \else\let\next\@secondoftwo\fi\next}} -\def\@domathligfollows{}\def\@domathligfirsts{} -\def\@makemathligsactive{\mathligson - \def\do##1##2##3{\catcode`##1=12}\@domathligfollows} -\def\@makemathligsnormal{\mathligsoff - \def\do##1##2##3{\catcode`##1=##3}\@domathligfollows} -\def\@ifinlist#1#2{\@tempswafalse - \def\do##1##2##3{\ifnum`##1=`#2\relax\@tempswatrue\fi}#1% - \if@tempswa\let\next\@firstoftwo\else\let\next\@secondoftwo\fi\next} -\def\@addligto#1#2{% - \@ifinlist#1#2{\def\do##1##2##3{\noexpand\do\noexpand##1% - \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}% - \else{##2}{##3}\fi}% - \edef#1{#1}}% - {\def\do##1##2##3{\noexpand\do\noexpand##1% - \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}% - \else{##2}{##3}\fi}% - \edef#1{#1\do#2{\the\mathcode`#2}{\the\catcode`#2}}}} -\def\@addligtolists#1{\expandafter\@addligto - \expandafter\@domathligfirsts - \csname\string#1\endcsname\@addligtofollowlist} -\def\@addligtofollowlist#1{\ifx#1\@@\let\next\relax\else - \def\next{\expandafter\@addligto - \expandafter\@domathligfollows - \csname\string#1\endcsname - \@addligtofollowlist}\fi\next} -\def\@defligstep#1#2{\def\@tempa##1{\ifx##1\endcsname - \expandafter\endcsname\else - \string##1\expandafter\@tempa\fi}% - \expandafter\@def@ligstep\csname @mathlig\@tempa#1#2\endcsname{#1#2}} -\def\@def@ligstep#1#2#3{% - \ifx#3\@@ - \def\next{\def#1}% - \else - \ifx#1\relax - \def\next{\let#1\@mathliglink\@defligstep{#2}#3}% - \else - \def\next{\@defligstep{#2}#3}% - \fi - \fi\next} -\def\@setupfirstligchar#1#2\@@{% - \@ifactive{#1}{% - \expandafter\expandafter\expandafter\@mathligredefactive - \expandafter\string\expandafter#1\expandafter{#1}{#1}}% - {\@defactive#1{\@startmathlig #1}\@namedef{@mathlig#1}{#1}}} -\def\@mathligredefactive#1#2#3{% - \def#3{{}\ifmmode\def\next{\@startmathlig#1}\else - \def\next{#2}\fi\next}% - \@namedef{@mathlig#1}{#2}} -\def\@defactive#1{\@ifundefined{@definemathlig\string#1}% - {\@latex@error{Illegal first character in math ligature} - {You can only use \@firstmathligs\space as the first^^J - character of a math ligature}}% - {\csname @definemathlig\string#1\endcsname}} - -{\def\@firstmathligs{}\def\do#1{\catcode`#1=\active - \expandafter\gdef\expandafter\@firstmathligs - \expandafter{\@firstmathligs\space\string#1}\next} - \def\next#1{\expandafter\gdef\csname - @definemathlig\string#1\endcsname{\def#1}} - \do{"}"\do{@}@\do{/}/\do{(}(\do{)})\do{[}[\do{]}]\do{=}= - \do{?}?\do{!}!\do{`}`\do{'}'\do{|}|\do{~}~\do{<}<\do{>}> - \do{+}+\do{-}-\do{*}*\do{.}.\do{,},\do{:}:\do{;};} -\newtoks\@pushedtoks -\newtoks\@seentoks -\def\@startmathlig{\def\@lastvalidmathlig{}\@pushedtoks{}% - \@seentoks{}\@trymathlig} -\def\@trymathlig{\futurelet\next\@@trymathlig} -\def\@@trymathlig{\@ifcharacter\next{\@try@mathlig}{\@exitmathlig{}}} -\def\@exitmathlig#1{% - \expandafter\@makemathligsnormal\@lastvalidmathlig\mathligson - \the\@pushedtoks#1} -\def\@try@mathlig#1{%\typeout{char: #1 catcode: \the\catcode`#1 - \@ifundefined{@mathlig\the\@seentoks#1}{\@exitmathlig{#1}}% - {\expandafter\ifx - \csname @mathlig\the\@seentoks#1\endcsname - \@mathliglink - \expandafter\@pushedtoks - \expandafter=\expandafter{\the\@pushedtoks#1}% - \else - \expandafter\let\expandafter\@lastvalidmathlig - \csname @mathlig\the\@seentoks#1\endcsname - \@pushedtoks={}% - \fi - \expandafter\@seentoks\expandafter=\expandafter% - {\the\@seentoks#1}\@makemathligsactive\obeyspaces\@trymathlig}} -\edef\patch@newmcodes@{% - \mathcode\number`\'=39 - \mathcode\number`\*=42 - \mathcode\number`\.=\string "613A - \mathchardef\noexpand\std@minus=\the\mathcode`\-\relax - \mathcode\number`\-=45 - \mathcode\number`\/=47 - \mathcode\number`\:=\string "603A\relax -} -\AtBeginDocument{\let\newmcodes@=\patch@newmcodes@} -\fi -\endinput -%% -%% End of file `ligature.sty'. diff --git a/helm/ocaml/tactics/doc/main.tex b/helm/ocaml/tactics/doc/main.tex deleted file mode 100644 index 06952d61c..000000000 --- a/helm/ocaml/tactics/doc/main.tex +++ /dev/null @@ -1,70 +0,0 @@ -\documentclass[a4paper]{article} - -\usepackage{a4wide} -\usepackage{pifont} -\usepackage{semantic} -\usepackage{stmaryrd} -\usepackage{graphicx} - -\newcommand{\MATITA}{\ding{46}\textsf{\textbf{Matita}}} - -\title{Continuationals semantics for \MATITA} -\author{Claudio Sacerdoti Coen \quad Enrico Tassi \quad Stefano Zacchiroli \\ -\small Department of Computer Science, University of Bologna \\ -\small Mura Anteo Zamboni, 7 -- 40127 Bologna, ITALY \\ -\small \{\texttt{sacerdot}, \texttt{tassi}, \texttt{zacchiro}\}\texttt{@cs.unibo.it}} - -\newcommand{\MATHIT}[1]{\ensuremath{\mathit{#1}}} -\newcommand{\MATHTT}[1]{\ensuremath{\mathtt{#1}}} - -\newcommand{\DOT}{\ensuremath{\mbox{\textbf{.}}}} -\newcommand{\SEMICOLON}{\ensuremath{\mbox{\textbf{;}}}} -\newcommand{\BRANCH}{\ensuremath{\mbox{\textbf{[}}}} -\newcommand{\SHIFT}{\ensuremath{\mbox{\textbf{\textbar}}}} -\newcommand{\POS}[1]{\ensuremath{#1\mbox{\textbf{:}}}} -\newcommand{\MERGE}{\ensuremath{\mbox{\textbf{]}}}} -\newcommand{\FOCUS}[1]{\ensuremath{\mathtt{focus}~#1}} -\newcommand{\UNFOCUS}{\ensuremath{\mathtt{unfocus}}} -\newcommand{\SKIP}{\MATHTT{skip}} -\newcommand{\TACTIC}[1]{\ensuremath{\mathtt{tactic}~#1}} - -\newcommand{\APPLY}[1]{\ensuremath{\mathtt{apply}~\mathit{#1}}} - -\newcommand{\GOAL}{\MATHIT{goal}} -\newcommand{\SWITCH}{\MATHIT{switch}} -\newcommand{\LIST}{\MATHTT{list}} -\newcommand{\INT}{\MATHTT{int}} -\newcommand{\OPEN}{\MATHTT{Open}} -\newcommand{\CLOSED}{\MATHTT{Closed}} - -\newcommand{\SEMOP}[1]{|[#1|]} -\newcommand{\TSEMOP}[1]{{}_t|[#1|]} -\newcommand{\SEM}[3][\xi]{\SEMOP{#2}_{{#1},{#3}}} -\newcommand{\ENTRY}[4]{\langle#1,#2,#3,#4\rangle} -\newcommand{\TSEM}[3]{\TSEMOP{#1}_{#2,#3}} - -\newcommand{\GIN}[1][1]{\ensuremath{[l_{#1};\cdots;l_n]}} - -\newcommand{\ZEROPOS}{\MATHIT{zero\_pos}} -\newcommand{\INITPOS}{\MATHIT{init\_pos}} -\newcommand{\ISFRESH}{\MATHIT{is\_fresh}} -\newcommand{\FILTER}{\MATHIT{filter}} -\newcommand{\FILTEROPEN}{\MATHIT{filter\_open}} -\newcommand{\ISOPEN}{\MATHIT{is\_open}} -\newcommand{\DEEPCLOSE}{\MATHIT{deep\_close}} -\newcommand{\REMOVEGOALS}{\MATHIT{remove\_goals}} -\newcommand{\GOALS}{\MATHIT{open\_goals}} - -\newcommand{\BRANCHTAG}{\ensuremath{\mathtt{B}}} -\newcommand{\FOCUSTAG}{\ensuremath{\mathtt{F}}} - -\newlength{\sidecondlen} -\setlength{\sidecondlen}{2cm} - -\begin{document} -\maketitle - -\input{body.tex} - -\end{document} - diff --git a/helm/ocaml/tactics/doc/reserved.sty b/helm/ocaml/tactics/doc/reserved.sty deleted file mode 100644 index c0d56b8aa..000000000 --- a/helm/ocaml/tactics/doc/reserved.sty +++ /dev/null @@ -1,80 +0,0 @@ -%% -%% This is file `reserved.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,reservedWords') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from reserved.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\reservestyle,\@reservestyle,\setreserved,\<} -\TestForConflict{\@parseDefineReserved,\@xparseDefineReserved} -\TestForConflict{\@defineReserved,\@xdefineReserved} -\newcommand{\reservestyle}[3][]{ - \newcommand{#2}{\@parseDefineReserved{#1}{#3}} - \expandafter\expandafter\expandafter\def - \expandafter\csname set\expandafter\@gobble\string#2\endcsname##1% - {#1{#3{##1}}}} -\newtoks\@@spacing -\newtoks\@@formating -\def\@parseDefineReserved#1#2{% - \@ifnextchar[{\@xparseDefineReserved{#2}}% - {\@xparseDefineReserved{#2}[#1]}} -\def\@xparseDefineReserved#1[#2]#3{% - \@@formating{#1}% - \@@spacing{#2}% - \expandafter\@defineReserved#3,\end -} -\def\@defineReserved#1,{% - \@ifnextchar\end - {\@xdefineReserved #1[]\END\@gobble}% - {\@xdefineReserved#1[]\END\@defineReserved}} -\def\@xdefineReserved#1[#2]#3\END{% - \def\reserved@a{#2}% - \ifx \reserved@a\empty \toks0{#1}\else \toks0{#2} \fi - \expandafter\edef\csname\expandafter<#1>\endcsname - {\the\@@formating{\the\@@spacing{\the\toks0}}}} -\def\setreserved#1>{% - \expandafter\let\expandafter\reserved@a\csname<#1>\endcsname - \@ifundefined{reserved@a}{\PackageError{Semantic} - {``#1'' is not defined as a reserved word}% - {Before referring to a name as a reserved word, it % - should be defined\MessageBreak using an appropriate style - definer. A style definer is defined \MessageBreak - using \protect\reservestyle.\MessageBreak% - Type to proceed --- nothing will be set.}}% - {\reserved@a}} -\let\<=\setreserved -\fi -\endinput -%% -%% End of file `reserved.sty'. diff --git a/helm/ocaml/tactics/doc/semantic.sty b/helm/ocaml/tactics/doc/semantic.sty deleted file mode 100644 index 98257cab8..000000000 --- a/helm/ocaml/tactics/doc/semantic.sty +++ /dev/null @@ -1,137 +0,0 @@ -%% -%% This is file `semantic.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `general') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from semantic.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\NeedsTeXFormat{LaTeX2e} -\newcommand{\semanticVersion}{2.0(epsilon)} -\newcommand{\semanticDate}{2003/10/28} -\ProvidesPackage{semantic} - [\semanticDate\space v\semanticVersion\space] -\typeout{Semantic Package v\semanticVersion\space [\semanticDate]} -\typeout{CVSId: $Id$} -\newcounter{@@conflict} -\newcommand{\@semanticNotDefinable}{% - \typeout{Command \@backslashchar\reserved@a\space already defined} - \stepcounter{@@conflict}} -\newcommand{\@oldNotDefinable}{} -\let\@oldNotDefinable=\@notdefinable -\let\@notdefinable=\@semanticNotDefinable -\newcommand{\TestForConflict}{} -\def\TestForConflict#1{\sem@test #1,,} -\newcommand{\sem@test}{} -\newcommand{\sem@tmp}{} -\newcommand{\@@next}{} -\def\sem@test#1,{% - \def\sem@tmp{#1}% - \ifx \sem@tmp\empty \let\@@next=\relax \else - \@ifdefinable{#1}{} \let\@@next=\sem@test \fi - \@@next} -\TestForConflict{\@inputLigature,\@inputInference,\@inputTdiagram} -\TestForConflict{\@inputReservedWords,\@inputShorthand} -\TestForConflict{\@ddInput,\sem@nticsLoader,\lo@d} -\def\@inputLigature{\input{ligature.sty}\message{ math mode ligatures,}% - \let\@inputLigature\relax} -\def\@inputInference{\input{infernce.sty}\message{ inference rules,}% - \let\@inputInference\relax} -\def\@inputTdiagram{\input{tdiagram.sty}\message{ T diagrams,}% - \let\@inputTdiagram\relax} -\def\@inputReservedWords{\input{reserved.sty}\message{ reserved words,}% - \let\@inputReservedWords\relax} -\def\@inputShorthand{\input{shrthand.sty}\message{ short hands,}% - \let\@inputShorthand\relax} -\toks1={} -\newcommand{\@ddInput}[1]{% - \toks1=\expandafter{\the\toks1\noexpand#1}} -\DeclareOption{ligature}{\@ddInput\@inputLigature} -\DeclareOption{inference}{\@ddInput\@inputInference} -\DeclareOption{tdiagram}{\@ddInput\@inputTdiagram} -\DeclareOption{reserved}{\@ddInput\@inputReservedWords} -\DeclareOption{shorthand}{\@ddInput\@inputLigature - \@ddInput\@inputShorthand} -\ProcessOptions* -\typeout{Loading features: } -\def\sem@nticsLoader{} -\edef\lo@d{\the\toks1} -\ifx\lo@d\empty - \@inputLigature - \@inputInference - \@inputTdiagram - \@inputReservedWords - \@inputShorthand -\else - \lo@d -\fi -\typeout{and general definitions.^^J} -\let\@ddInput\relax -\let\@inputInference\relax -\let\@inputLigature\relax -\let\@inputTdiagram\relax -\let\@inputReservedWords\relax -\let\@inputShorthand\relax -\let\sem@nticsLoader\realx -\let\lo@d\relax -\TestForConflict{\@dropnext,\@ifnext,\@ifn,\@ifNextMacro,\@ifnMacro} -\TestForConflict{\@@maxwidth,\@@pLineBox,\if@@Nested,\@@cBox} -\TestForConflict{\if@@moreLines,\@@pBox} -\def\@ifnext#1#2#3{% - \let\reserved@e=#1\def\reserved@a{#2}\def\reserved@b{#3}\futurelet% - \reserved@c\@ifn} -\def\@ifn{% - \ifx \reserved@c \reserved@e\let\reserved@d\reserved@a\else% - \let\reserved@d\reserved@b\fi \reserved@d} -\def\@ifNextMacro#1#2{% - \def\reserved@a{#1}\def\reserved@b{#2}% - \futurelet\reserved@c\@ifnMacro} -\def\@ifnMacro{% - \ifcat\noexpand\reserved@c\noexpand\@ifnMacro - \let\reserved@d\reserved@a - \else \let\reserved@d\reserved@b\fi \reserved@d} -\newcommand{\@dropnext}[2]{#1} -\ifnum \value{@@conflict} > 0 - \PackageError{Semantic} - {The \the@@conflict\space command(s) listed above have been - redefined.\MessageBreak - Please report this to turtle@bu.edu} - {Some of the commands defined in semantic was already defined % - and has\MessageBreak now be redefined. There is a risk that % - these commands will be used\MessageBreak by other packages % - leading to spurious errors.\MessageBreak - \space\space Type and cross your fingers% -}\fi -\let\@notdefinable=\@oldNotDefinable -\let\@semanticNotDefinable=\relax -\let\@oldNotDefinable=\relax -\let\TestForConflict=\relax -\let\@endmark=\relax -\let\sem@test=\relax -\newdimen\@@maxwidth -\newbox\@@pLineBox -\newbox\@@cBox -\newbox\@@pBox -\newif\if@@moreLines -\newif\if@@Nested \@@Nestedfalse -\endinput -%% -%% End of file `semantic.sty'. diff --git a/helm/ocaml/tactics/doc/shrthand.sty b/helm/ocaml/tactics/doc/shrthand.sty deleted file mode 100644 index b73af4470..000000000 --- a/helm/ocaml/tactics/doc/shrthand.sty +++ /dev/null @@ -1,96 +0,0 @@ -%% -%% This is file `shrthand.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,shorthand') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from shrthand.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\IfFileExists{DONOTUSEmathbbol.sty}{% - \RequirePackage{mathbbol} - \newcommand{\@bblb}{\textbb{[}} - \newcommand{\@bbrb}{\textbb{]}} - \newcommand{\@mbblb}{\mathopen{\mbox{\textbb{[}}}} - \newcommand{\@mbbrb}{\mathclose{\mbox{\textbb{]}}}} -} -{ \newcommand{\@bblb}{\textnormal{[\kern-.15em[}} - \newcommand{\@bbrb}{\textnormal{]\kern-.15em]}} - \newcommand{\@mbblb}{\mathopen{[\mkern-2.67mu[}} - \newcommand{\@mbbrb}{\mathclose{]\mkern-2.67mu]}} -} -\mathlig{|-}{\vdash} -\mathlig{|=}{\models} -\mathlig{->}{\rightarrow} -\mathlig{->*}{\mathrel{\rightarrow^*}} -\mathlig{->+}{\mathrel{\rightarrow^+}} -\mathlig{-->}{\longrightarrow} -\mathlig{-->*}{\mathrel{\longrightarrow^*}} -\mathlig{-->+}{\mathrel{\longrightarrow^+}} -\mathlig{=>}{\Rightarrow} -\mathlig{=>*}{\mathrel{\Rightarrow^*}} -\mathlig{=>+}{\mathrel{\Rightarrow^+}} -\mathlig{==>}{\Longrightarrow} -\mathlig{==>*}{\mathrel{\Longrightarrow^*}} -\mathlig{==>+}{\mathrel{\Longrightarrow^+}} -\mathlig{<-}{\leftarrow} -\mathlig{*<-}{\mathrel{{}^*\mkern-1mu\mathord\leftarrow}} -\mathlig{+<-}{\mathrel{{}^+\mkern-1mu\mathord\leftarrow}} -\mathlig{<--}{\longleftarrow} -\mathlig{*<--}{\mathrel{{}^*\mkern-1mu\mathord{\longleftarrow}}} -\mathlig{+<--}{\mathrel{{}^+\mkern-1mu\mathord{\longleftarrow}}} -\mathlig{<=}{\Leftarrow} -\mathlig{*<=}{\mathrel{{}^*\mkern-1mu\mathord\Leftarrow}} -\mathlig{+<=}{\mathrel{{}^+\mkern-1mu\mathord\Leftarrow}} -\mathlig{<==}{\Longleftarrow} -\mathlig{*<==}{\mathrel{{}^*\mkern-1mu\mathord{\Longleftarrow}}} -\mathlig{+<==}{\mathrel{{}^+\mkern-1mu\mathord{\Longleftarrow}}} -\mathlig{<->}{\longleftrightarrow} -\mathlig{<=>}{\Longleftrightarrow} -\mathlig{|[}{\@mbblb} -\mathlig{|]}{\@mbbrb} -\newcommand{\evalsymbol}[1][]{\ensuremath{\mathcal{E}^{#1}}} -\newcommand{\compsymbol}[1][]{\ensuremath{\mathcal{C}^{#1}}} -\newcommand{\eval}[3][]% - {\mbox{$\mathcal{E}^{#1}$\@bblb \texttt{#2}\@bbrb}% - \ensuremath{\mathtt{#3}}} -\newcommand{\comp}[3][]% - {\mbox{$\mathcal{C}^{#1}$\@bblb \texttt{#2}\@bbrb}% - \ensuremath{\mathtt{#3}}} -\newcommand{\@exe}[3]{} -\newcommand{\exe}[1]{\@ifnextchar[{\@exe{#1}}{\@exe{#1}[]}} -\def\@exe#1[#2]#3{% - \mbox{\@bblb\texttt{#1}\@bbrb$^\mathtt{#2}\mathtt{(#3)}$}} -\fi -\endinput -%% -%% End of file `shrthand.sty'. diff --git a/helm/ocaml/tactics/doc/tdiagram.sty b/helm/ocaml/tactics/doc/tdiagram.sty deleted file mode 100644 index 02202b34a..000000000 --- a/helm/ocaml/tactics/doc/tdiagram.sty +++ /dev/null @@ -1,166 +0,0 @@ -%% -%% This is file `tdiagram.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,Tdiagram') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from tdiagram.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\@getSymbol,\@interpreter,\@parseArg,\@program} -\TestForConflict{\@putSymbol,\@saveBeforeSymbolMacro,\compiler} -\TestForConflict{\interpreter,\machine,\program,\@compiler} -\newif\if@@Left -\newif\if@@Up -\newcount\@@xShift -\newcount\@@yShift -\newtoks\@@symbol -\newtoks\@@tempSymbol -\newcommand{\compiler}[1]{\@compiler#1\end} -\def\@compiler#1,#2,#3\end{% - \if@@Nested % - \if@@Up % - \@@yShift=40 \if@@Left \@@xShift=-50 \else \@@xShift=-30 \fi - \else% - \@@yShift=20 \@@xShift =0 % - \fi% - \else% - \@@yShift=40 \@@xShift=-40% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(1,0){80}}% - \put(0,-20){\line(1,0){30}}% - \put(50,-20){\line(1,0){30}}% - \put(30,-40){\line(1,0){20}}% - \put(0,0){\line(0,-1){20}}% - \put(80,0){\line(0,-1){20}}% - \put(30,-20){\line(0,-1){20}}% - \put(50,-20){\line(0,-1){20}}% - \put(30,-20){\makebox(20,20){$\rightarrow$}} % - {\@@Uptrue \@@Lefttrue \@parseArg(0,-20)(5,-20)#1\end}% - \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi - {\@@Uptrue \@@Leftfalse \@parseArg(80,-20)(55,-20)#3\end}% - {\@@Upfalse \@@Lefttrue \@parseArg(50,-40)(30,-40)#2\end}% - \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi - \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi% - }% -} -\newcommand{\interpreter}[1]{\@interpreter#1\end} -\def\@interpreter#1,#2\end{% - \if@@Nested % - \if@@Up % - \@@yShift=40 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi - \else% - \@@yShift=0 \@@xShift =0 % - \fi% - \else% - \@@yShift=40 \@@xShift=10% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(-1,0){20}}% - \put(0,-40){\line(-1,0){20}}% - \put(0,0){\line(0,-1){40}}% - \put(-20,0){\line(0,-1){40}}% - {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-20)#1\end}% - \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi - {\@@Upfalse \@@Lefttrue \@parseArg(0,-40)(-20,-40)#2\end}% - \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi - \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi% - }% -} -\newcommand{\program}[1]{\@program#1\end} -\def\@program#1,#2\end{% - \if@@Nested % - \if@@Up % - \@@yShift=0 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi - \else% - \PackageError{semantic}{% - A program cannot be at the bottom} - {% - You have tried to use a \protect\program\space as the - bottom\MessageBreak parameter to \protect\compiler, - \protect\interpreter\space or \protect\program.\MessageBreak - Type to proceed --- Output can be distorted.}% - \fi% - \else% - \@@yShift=0 \@@xShift=10% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(-1,0){20}}% - \put(0,0){\line(0,1){30}}% - \put(-20,0){\line(0,1){30}}% - \put(-10,30){\oval(20,20)[t]}% - \@putSymbol[#1]{-20,20}% - {\@@Upfalse \@@Lefttrue \@parseArg(0,0)(-20,0)#2\end}% - }% -} -\newcommand{\machine}[1]{% - \if@@Nested % - \if@@Up % - \PackageError{semantic}{% - A machine cannot be at the top} - {% - You have tried to use a \protect\machine\space as a - top\MessageBreak parameter to \protect\compiler or - \protect\interpreter.\MessageBreak - Type to proceed --- Output can be distorted.}% - \else \@@yShift=0 \@@xShift=0 - \fi% - \else% - \@@yShift=20 \@@xShift=10% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(-1,0){20}} \put(-20,0){\line(3,-5){10}} - \put(0,0){\line(-3,-5){10}}% - {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-15)#1\end}% - }% -} -\def\@parseArg(#1)(#2){% - \@ifNextMacro{\@doSymbolMacro(#1)(#2)}{\@getSymbol(#2)}} -\def\@getSymbol(#1)#2\end{\@putSymbol[#2]{#1}} -\def\@doSymbolMacro(#1)(#2)#3{% - \@ifnextchar[{\@saveBeforeSymbolMacro(#1)(#2)#3}% - {\@symbolMacro(#1)(#2)#3}} -\def\@saveBeforeSymbolMacro(#1)(#2)#3[#4]#5\end{% - \@@tempSymbol={#4}% - \@@Nestedtrue\put(#1){#3#5}% - \@putSymbol[\the\@@tempSymbol]{#2}} -\def\@symbolMacro(#1)(#2)#3\end{% - \@@Nestedtrue\put(#1){#3}% - \@putSymbol{#2}} -\newcommand{\@putSymbol}[2][\the\@@symbol]{% - \global\@@symbol=\expandafter{#1}% - \put(#2){\makebox(20,20){\texttt{\the\@@symbol}}}} -\fi -\endinput -%% -%% End of file `tdiagram.sty'. diff --git a/helm/ocaml/tactics/eliminationTactics.ml b/helm/ocaml/tactics/eliminationTactics.ml deleted file mode 100644 index e98bcd3c8..000000000 --- a/helm/ocaml/tactics/eliminationTactics.ml +++ /dev/null @@ -1,217 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -module C = Cic -module P = PrimitiveTactics -module T = Tacticals -module S = ProofEngineStructuralRules -module F = FreshNamesGenerator -module E = ProofEngineTypes -module H = ProofEngineHelpers - -(* -let induction_tac ~term status = - let (proof, goal) = status in - 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 = CicUtil.lookup_meta 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 -;; -*) - -(* unexported tactics *******************************************************) - -let get_name context index = - try match List.nth context (pred index) with - | Some (Cic.Name name, _) -> Some name - | _ -> None - with Invalid_argument "List.nth" -> None - -let rec scan_tac ~old_context_length ~index ~tactic = - let scan_tac status = - let (proof, goal) = status in - let _, metasenv, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let context_length = List.length context in - let rec aux index = - match get_name context index with - | _ when index <= 0 -> (proof, [goal]) - | None -> aux (pred index) - | Some what -> - let tac = T.then_ ~start:(tactic ~what) - ~continuation:(scan_tac ~old_context_length:context_length ~index ~tactic) - in - try E.apply_tactic tac status - with E.Fail _ -> aux (pred index) - in aux (index + context_length - old_context_length - 1) - in - E.mk_tactic scan_tac - -let rec check_inductive_types types = function - | C.MutInd (uri, typeno, _) -> List.mem (uri, typeno) types - | C.Appl (hd :: tl) -> check_inductive_types types hd - | _ -> false - -let elim_clear_tac ~mk_fresh_name_callback ~types ~what = - let elim_clear_tac status = - let (proof, goal) = status in - let _, metasenv, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let index, ty = H.lookup_type metasenv context what in - if check_inductive_types types ty then - let tac = T.then_ ~start:(P.elim_intros_tac ~mk_fresh_name_callback (C.Rel index)) - ~continuation:(S.clear what) - in - E.apply_tactic tac status - else raise (E.Fail (lazy "unexported elim_clear: not an eliminable type")) - in - E.mk_tactic elim_clear_tac - -(* elim type ****************************************************************) - -let elim_type_tac ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) ?depth - ?using what -= - let elim what = - P.elim_intros_simpl_tac ?using ?depth ~mk_fresh_name_callback what - in - let elim_type_tac status = - let tac = - T.thens ~start: (P.cut_tac what) ~continuations:[elim (C.Rel 1); T.id_tac] - in - E.apply_tactic tac status - in - E.mk_tactic elim_type_tac - -(* decompose ****************************************************************) - -(* robaglia --------------------------------------------------------------- *) - - (** perform debugging output? *) -let debug = false -let debug_print = fun _ -> () - - (** debugging print *) -let warn s = debug_print (lazy ("DECOMPOSE: " ^ (Lazy.force s))) - -(* search in term the Inductive Types and return a list of uris as triples like this: (uri,typeno,exp_named_subst) *) -let search_inductive_types ty = - let rec aux types = function - | C.MutInd (uri, typeno, _) when (not (List.mem (uri, typeno) types)) -> - (uri, typeno) :: types - | C.Appl applist -> List.fold_left aux types applist - | _ -> types - in - aux [] ty -(* N.B: in un caso tipo (and A forall C:Prop.(or B C)) l'or *non* viene selezionato! *) - -(* roba seria ------------------------------------------------------------- *) - -let decompose_tac ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) - ?(user_types=[]) ~dbd what = - let decompose_tac status = - let (proof, goal) = status in - let _, metasenv,_,_ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let types = List.rev_append user_types (FwdQueries.decomposables dbd) in - let tactic = elim_clear_tac ~mk_fresh_name_callback ~types in - let old_context_length = List.length context in - let tac = T.then_ ~start:(tactic ~what) - ~continuation:(scan_tac ~old_context_length ~index:1 ~tactic) - in - E.apply_tactic tac status - in - E.mk_tactic decompose_tac - -(* -module R = CicReduction - - let rec elim_clear_tac ~term' ~nr_of_hyp_still_to_elim status = - let (proof, goal) = status in - warn (lazy ("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,_ = CicUtil.lookup_meta goal metasenv in - let old_context_len = List.length context in - let termty,_ = - CicTypeChecker.type_of_aux' metasenv context term' - CicUniv.empty_ugraph in - warn (lazy ("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 (lazy ("elim " ^ CicPp.ppterm termty)); - ProofEngineTypes.apply_tactic - (T.then_ - ~start:(P.elim_intros_simpl_tac term') - ~continuation:( - (* clear the hyp that has just been eliminated *) - ProofEngineTypes.mk_tactic (fun status -> - let (proof, goal) = status in - let _,metasenv,_,_ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let new_context_len = List.length context in - warn (lazy ("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 - let hyp_name = - match List.nth context new_nr_of_hyp_still_to_elim with - None - | Some (Cic.Anonymous,_) -> assert false - | Some (Cic.Name name,_) -> name - in - ProofEngineTypes.apply_tactic - (T.then_ - ~start:( - if (term'==term) (* if it's the first application of elim, there's no need to clear the hyp *) - then begin debug_print (lazy ("%%%%%%% no clear")); T.id_tac end - else begin debug_print (lazy ("%%%%%%% clear " ^ (string_of_int (new_nr_of_hyp_still_to_elim)))); (S.clear ~hyp:hyp_name) end) - ~continuation:(ProofEngineTypes.mk_tactic (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 (lazy ("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 *) - ProofEngineTypes.apply_tactic T.id_tac status - - in - elim_clear_tac ~term':term ~nr_of_hyp_still_to_elim:1 status -*) diff --git a/helm/ocaml/tactics/eliminationTactics.mli b/helm/ocaml/tactics/eliminationTactics.mli deleted file mode 100644 index cf6589f9a..000000000 --- a/helm/ocaml/tactics/eliminationTactics.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* 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: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic - -val decompose_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?user_types:((UriManager.uri * int) list) -> - dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/equalityTactics.ml b/helm/ocaml/tactics/equalityTactics.ml deleted file mode 100644 index da7f599a9..000000000 --- a/helm/ocaml/tactics/equalityTactics.ml +++ /dev/null @@ -1,356 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let rec rewrite_tac ~direction ~(pattern: ProofEngineTypes.lazy_pattern) equality = - let _rewrite_tac ~direction ~pattern:(wanted,hyps_pat,concl_pat) equality status - = - let module C = Cic in - let module U = UriManager in - let module PET = ProofEngineTypes in - let module PER = ProofEngineReduction in - let module PEH = ProofEngineHelpers in - let module PT = PrimitiveTactics in - assert (wanted = None); (* this should be checked syntactically *) - let proof,goal = status in - let curi, metasenv, pbo, pty = proof in - let (metano,context,gty) = CicUtil.lookup_meta goal metasenv in - match hyps_pat with - he::(_::_ as tl) -> - PET.apply_tactic - (Tacticals.then_ - (rewrite_tac ~direction - ~pattern:(None,[he],None) equality) - (rewrite_tac ~direction ~pattern:(None,tl,concl_pat) equality) - ) status - | [_] as hyps_pat when concl_pat <> None -> - PET.apply_tactic - (Tacticals.then_ - (rewrite_tac ~direction - ~pattern:(None,hyps_pat,None) equality) - (rewrite_tac ~direction ~pattern:(None,[],concl_pat) equality) - ) status - | _ -> - let arg,dir2,tac,concl_pat,gty = - match hyps_pat with - [] -> None,true,(fun ~term _ -> PT.exact_tac term),concl_pat,gty - | [name,pat] -> - let rec find_hyp n = - function - [] -> assert false - | Some (Cic.Name s,Cic.Decl ty)::_ when name = s -> - Cic.Rel n, CicSubstitution.lift n ty - | Some (Cic.Name s,Cic.Def _)::_ -> assert false (*CSC: not implemented yet! But does this make any sense?*) - | _::tl -> find_hyp (n+1) tl - in - let arg,gty = find_hyp 1 context in - let dummy = "dummy" in - Some arg,false, - (fun ~term typ -> - Tacticals.seq - ~tactics: - [ProofEngineStructuralRules.rename name dummy; - PT.letin_tac - ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name name) term; - ProofEngineStructuralRules.clearbody name; - ReductionTactics.change_tac - ~pattern: - (None,[name,Cic.Implicit (Some `Hole)], None) - (ProofEngineTypes.const_lazy_term typ); - ProofEngineStructuralRules.clear dummy - ]), - Some pat,gty - | _::_ -> assert false - in - let if_right_to_left do_not_change a b = - match direction with - | `RightToLeft -> if do_not_change then a else b - | `LeftToRight -> if do_not_change then b else a - in - let ty_eq,ugraph = - CicTypeChecker.type_of_aux' metasenv context equality - CicUniv.empty_ugraph in - let (ty_eq,metasenv',arguments,fresh_meta) = - ProofEngineHelpers.saturate_term - (ProofEngineHelpers.new_meta_of_proof proof) metasenv context ty_eq 0 in - let equality = - if List.length arguments = 0 then - equality - else - C.Appl (equality :: arguments) in - (* t1x is t2 if we are rewriting in an hypothesis *) - let eq_ind, ty, t1, t2, t1x = - match ty_eq with - | C.Appl [C.MutInd (uri, 0, []); ty; t1; t2] - when LibraryObjects.is_eq_URI uri -> - let ind_uri = - if_right_to_left dir2 - LibraryObjects.eq_ind_URI LibraryObjects.eq_ind_r_URI - in - let eq_ind = C.Const (ind_uri uri,[]) in - if dir2 then - if_right_to_left true (eq_ind,ty,t2,t1,t2) (eq_ind,ty,t1,t2,t1) - else - if_right_to_left true (eq_ind,ty,t1,t2,t2) (eq_ind,ty,t2,t1,t1) - | _ -> raise (PET.Fail (lazy "Rewrite: argument is not a proof of an equality")) in - (* now we always do as if direction was `LeftToRight *) - let fresh_name = - FreshNamesGenerator.mk_fresh_name - ~subst:[] metasenv' context C.Anonymous ~typ:ty in - let lifted_t1 = CicSubstitution.lift 1 t1x in - let lifted_gty = CicSubstitution.lift 1 gty in - let lifted_conjecture = - metano,(Some (fresh_name,Cic.Decl ty))::context,lifted_gty in - let lifted_pattern = - let lifted_concl_pat = - match concl_pat with - | None -> None - | Some term -> Some (CicSubstitution.lift 1 term) in - Some (fun _ m u -> lifted_t1, m, u),[],lifted_concl_pat - in - let subst,metasenv',ugraph,_,selected_terms_with_context = - ProofEngineHelpers.select - ~metasenv:metasenv' ~ugraph ~conjecture:lifted_conjecture - ~pattern:lifted_pattern in - let metasenv' = CicMetaSubst.apply_subst_metasenv subst metasenv' in - let what,with_what = - (* Note: Rel 1 does not live in the context context_of_t *) - (* The replace_lifting_csc 0 function will take care of lifting it *) - (* to context_of_t *) - List.fold_right - (fun (context_of_t,t) (l1,l2) -> t::l1, Cic.Rel 1::l2) - selected_terms_with_context ([],[]) in - let t1 = CicMetaSubst.apply_subst subst t1 in - let t2 = CicMetaSubst.apply_subst subst t2 in - let equality = CicMetaSubst.apply_subst subst equality in - let abstr_gty = - ProofEngineReduction.replace_lifting_csc 0 - ~equality:(==) ~what ~with_what:with_what ~where:lifted_gty in - let abstr_gty = CicMetaSubst.apply_subst subst abstr_gty in - let pred = C.Lambda (fresh_name, ty, abstr_gty) in - (* The argument is either a meta if we are rewriting in the conclusion - or the hypothesis if we are rewriting in an hypothesis *) - let metasenv',arg,newtyp = - match arg with - None -> - let gty' = CicSubstitution.subst t2 abstr_gty in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - let metasenv' = (fresh_meta,context,gty')::metasenv' in - metasenv', C.Meta (fresh_meta,irl), Cic.Rel (-1) (* dummy term, never used *) - | Some arg -> - let gty' = CicSubstitution.subst t1 abstr_gty in - metasenv',arg,gty' - in - let exact_proof = - C.Appl [eq_ind ; ty ; t2 ; pred ; arg ; t1 ;equality] - in - let (proof',goals) = - PET.apply_tactic - (tac ~term:exact_proof newtyp) ((curi,metasenv',pbo,pty),goal) - in - let goals = - goals@(ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv - ~newmetasenv:metasenv') - in - (proof',goals) - in - ProofEngineTypes.mk_tactic (_rewrite_tac ~direction ~pattern equality) - - -let rewrite_simpl_tac ~direction ~pattern equality = - let rewrite_simpl_tac ~direction ~pattern equality status = - ProofEngineTypes.apply_tactic - (Tacticals.then_ - ~start:(rewrite_tac ~direction ~pattern equality) - ~continuation: - (ReductionTactics.simpl_tac - ~pattern:(ProofEngineTypes.conclusion_pattern None))) - status - in - ProofEngineTypes.mk_tactic (rewrite_simpl_tac ~direction ~pattern equality) -;; - -let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what = - let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what status = - let _wanted, hyps_pat, concl_pat = pattern in - let (proof, goal) = status in - let module C = Cic in - let module U = UriManager in - let module P = PrimitiveTactics in - let module T = Tacticals in - let uri,metasenv,pbo,pty = proof in - let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in - assert (hyps_pat = []); (*CSC: not implemented yet *) - let context_len = List.length context in - let subst,metasenv,u,_,selected_terms_with_context = - ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph - ~conjecture ~pattern in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let with_what, metasenv, u = with_what context metasenv u in - let with_what = CicMetaSubst.apply_subst subst with_what in - let pbo = CicMetaSubst.apply_subst subst pbo in - let pty = CicMetaSubst.apply_subst subst pty in - let status = (uri,metasenv,pbo,pty),goal in - let ty_of_with_what,u = - CicTypeChecker.type_of_aux' - metasenv context with_what CicUniv.empty_ugraph in - let whats = - match selected_terms_with_context with - [] -> raise (ProofEngineTypes.Fail (lazy "Replace: no term selected")) - | l -> - List.map - (fun (context_of_t,t) -> - let t_in_context = - try - let context_of_t_len = List.length context_of_t in - if context_of_t_len = context_len then t - else - (let t_in_context,subst,metasenv' = - CicMetaSubst.delift_rels [] metasenv - (context_of_t_len - context_len) t - in - assert (subst = []); - assert (metasenv = metasenv'); - t_in_context) - with - CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> - (*CSC: we could implement something stronger by completely changing - the semantics of the tactic *) - raise (ProofEngineTypes.Fail - (lazy "Replace: one of the selected terms is not closed")) in - let ty_of_t_in_context,u = (* TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv context t_in_context - CicUniv.empty_ugraph in - let b,u = CicReduction.are_convertible ~metasenv context - ty_of_with_what ty_of_t_in_context u in - if b then - let concl_pat_for_t = ProofEngineHelpers.pattern_of ~term:ty [t] in - let pattern_for_t = None,[],Some concl_pat_for_t in - t_in_context,pattern_for_t - else - raise - (ProofEngineTypes.Fail - (lazy "Replace: one of the selected terms and the term to be replaced with have not convertible types")) - ) l in - let rec aux n whats status = - match whats with - [] -> ProofEngineTypes.apply_tactic T.id_tac status - | (what,lazy_pattern)::tl -> - let what = CicSubstitution.lift n what in - let with_what = CicSubstitution.lift n with_what in - let ty_of_with_what = CicSubstitution.lift n ty_of_with_what in - ProofEngineTypes.apply_tactic - (T.thens - ~start:( - P.cut_tac - (C.Appl [ - (C.MutInd (LibraryObjects.eq_URI (), 0, [])) ; - ty_of_with_what ; - what ; - with_what])) - ~continuations:[ - T.then_ - ~start:( - rewrite_tac ~direction:`LeftToRight ~pattern:lazy_pattern (C.Rel 1)) - ~continuation:( - T.then_ - ~start:( - ProofEngineTypes.mk_tactic - (function ((proof,goal) as status) -> - let _,metasenv,_,_ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let hyp = - try - match List.hd context with - Some (Cic.Name name,_) -> name - | _ -> assert false - with (Failure "hd") -> assert false - in - ProofEngineTypes.apply_tactic - (ProofEngineStructuralRules.clear ~hyp) status)) - ~continuation:(aux_tac (n + 1) tl)); - T.id_tac]) - status - and aux_tac n tl = ProofEngineTypes.mk_tactic (aux n tl) in - aux 0 whats status - in - ProofEngineTypes.mk_tactic (replace_tac ~pattern ~with_what) -;; - - -(* All these tacs do is applying the right constructor/theorem *) - -let reflexivity_tac = - IntroductionTactics.constructor_tac ~n:1 -;; - -let symmetry_tac = - let symmetry_tac (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 = CicUtil.lookup_meta goal metasenv in - match (R.whd context ty) with - (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) - when LibraryObjects.is_eq_URI uri -> - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac - ~term: (C.Const (LibraryObjects.sym_eq_URI uri, []))) - (proof,goal) - - | _ -> raise (ProofEngineTypes.Fail (lazy "Symmetry failed")) - in - ProofEngineTypes.mk_tactic symmetry_tac -;; - -let transitivity_tac ~term = - let transitivity_tac ~term status = - let (proof, goal) = status in - 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 = CicUtil.lookup_meta goal metasenv in - match (R.whd context ty) with - (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) - when LibraryObjects.is_eq_URI uri -> - ProofEngineTypes.apply_tactic - (T.thens - ~start:(PrimitiveTactics.apply_tac - ~term: (C.Const (LibraryObjects.trans_eq_URI uri, []))) - ~continuations: - [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac]) - status - - | _ -> raise (ProofEngineTypes.Fail (lazy "Transitivity failed")) - in - ProofEngineTypes.mk_tactic (transitivity_tac ~term) -;; - - diff --git a/helm/ocaml/tactics/equalityTactics.mli b/helm/ocaml/tactics/equalityTactics.mli deleted file mode 100644 index 1d60ae149..000000000 --- a/helm/ocaml/tactics/equalityTactics.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* 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: - direction:[`LeftToRight | `RightToLeft] -> - pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> ProofEngineTypes.tactic - -val rewrite_simpl_tac: - direction:[`LeftToRight | `RightToLeft] -> - pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> ProofEngineTypes.tactic - -val replace_tac: - pattern:ProofEngineTypes.lazy_pattern -> - with_what:Cic.lazy_term -> ProofEngineTypes.tactic - -val reflexivity_tac: ProofEngineTypes.tactic -val symmetry_tac: ProofEngineTypes.tactic -val transitivity_tac: term:Cic.term -> ProofEngineTypes.tactic - diff --git a/helm/ocaml/tactics/fourier.ml b/helm/ocaml/tactics/fourier.ml deleted file mode 100644 index d7728c0b3..000000000 --- a/helm/ocaml/tactics/fourier.ml +++ /dev/null @@ -1,244 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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;; - -*) diff --git a/helm/ocaml/tactics/fourier.mli b/helm/ocaml/tactics/fourier.mli deleted file mode 100644 index 8b26bc21a..000000000 --- a/helm/ocaml/tactics/fourier.mli +++ /dev/null @@ -1,27 +0,0 @@ -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 diff --git a/helm/ocaml/tactics/fourierR.ml b/helm/ocaml/tactics/fourierR.ml deleted file mode 100644 index 8b910bded..000000000 --- a/helm/ocaml/tactics/fourierR.ml +++ /dev/null @@ -1,1201 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - - -(******************** 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 -open ProofEngineTypes - - -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) -> - if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then - rat_of_unop rop next - else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then - rat_of_unop rinv next - else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then - rat_of_binop rmult next - else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then - rat_of_binop rdiv next - else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then - rat_of_binop rplus next - else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then - rat_of_binop rminus next - else failwith "not a rational" - | _ -> failwith "not a rational") - | Cic.Const (u,boh) -> - if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then r1 - else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then r0 - else failwith "not a rational" - | _ -> failwith "not a rational" -;; - -(* coq wrapper -let rational_of_const = rational_of_term;; -*) -let fails f a = - try - ignore (f a); - 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 - if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then - flin_emult (rop r1) (flin_of_term (List.hd next)) - else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then - fl_of_binop flin_plus next - else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then - fl_of_binop flin_minus next - else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then - 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 - else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then - let a=(rational_of_term (List.hd next)) in - flin_add_cste (flin_zero()) (rinv a) - else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then - 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 - else assert false - end - |_ -> assert false - end - | Cic.Const (u,boh) -> - begin - if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then flin_one () - else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then flin_zero () - else 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) -> - if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then - [{hname=h; - htype="Rlt"; - hleft=arg1; - hright=arg2; - hflin= flin_minus (flin_of_term arg1) - (flin_of_term arg2); - hstrict=true}] - else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then - [{hname=h; - htype="Rgt"; - hleft=arg2; - hright=arg1; - hflin= flin_minus (flin_of_term arg2) - (flin_of_term arg1); - hstrict=true}] - else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then - [{hname=h; - htype="Rle"; - hleft=arg1; - hright=arg2; - hflin= flin_minus (flin_of_term arg1) - (flin_of_term arg2); - hstrict=false}] - else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then - [{hname=h; - htype="Rge"; - hleft=arg2; - hright=arg1; - hflin= flin_minus (flin_of_term arg2) - (flin_of_term arg1); - hstrict=false}] - else assert false - | Cic.MutInd (u,i,o) -> - if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then - 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) -> - if UriManager.eq u HelmLibraryObjects.Reals.r_URI then - [{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}] - else assert false - |_-> assert false) - else 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(HelmLibraryObjects.Logic.eq_URI, 0, []) ;; -let _False = Cic.MutInd (HelmLibraryObjects.Logic.false_URI, 0, []) ;; -let _not = Cic.Const (HelmLibraryObjects.Logic.not_URI,[]);; -let _R0 = Cic.Const (HelmLibraryObjects.Reals.r0_URI,[]);; -let _R1 = Cic.Const (HelmLibraryObjects.Reals.r1_URI,[]);; -let _R = Cic.Const (HelmLibraryObjects.Reals.r_URI,[]);; -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 (HelmLibraryObjects.Reals.rinv_URI, []);; -let _Rinv_R1 = Cic.Const(HelmLibraryObjects.Reals.rinv_r1_URI, []);; -let _Rle = Cic.Const (HelmLibraryObjects.Reals.rle_URI, []);; -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 _Rlt = Cic.Const (HelmLibraryObjects.Reals.rlt_URI, []);; -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 (HelmLibraryObjects.Reals.rminus_URI, []);; -let _Rmult = Cic.Const (HelmLibraryObjects.Reals.rmult_URI, []);; -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 (HelmLibraryObjects.Reals.ropp_URI, []);; -let _Rplus = Cic.Const (HelmLibraryObjects.Reals.rplus_URI, []);; - -(******************************************************************************) - -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 - pall "n0" status _Rlt_zero_1 ; - apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in - let tacd=ref (mk_tactic (fun status -> - pall "d0" status _Rlt_zero_1 ; - apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in - - - for i=1 to n-1 do - tacn:=(Tacticals.then_ - ~start:(mk_tactic (fun status -> - pall ("n"^string_of_int i) status _Rlt_zero_pos_plus1; - apply_tactic - (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) - status)) - ~continuation:!tacn); - done; - for i=1 to d-1 do - tacd:=(Tacticals.then_ - ~start:(mk_tactic (fun status -> - pall "d" status _Rlt_zero_pos_plus1 ; - apply_tactic - (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) status)) - ~continuation:!tacd); - done; - -debug("TAC ZERO INF POS\n"); - apply_tactic - (Tacticals.thens - ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_mult_inv_pos) - ~continuations:[!tacn ;!tacd ] ) - status - in - mk_tactic (tac_zero_inf_pos (n,d)) -;; - - - -(* preuve que 0<=n*1/d -*) - -let tac_zero_infeq_pos gl (n,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; - apply_tactic - (Tacticals.thens - ~start:(PrimitiveTactics.apply_tac ~term:_Rle_mult_inv_pos) - ~continuations:[!tacn;!tacd]) status - in - mk_tactic (tac_zero_infeq_pos gl (n,d)) -;; - - - -(* preuve que 0<(-n)*(1/d) => False -*) - -let tac_zero_inf_false gl (n,d) = - let tac_zero_inf_false gl (n,d) status = - if n=0 then - apply_tactic (PrimitiveTactics.apply_tac ~term:_Rnot_lt0) status - else - apply_tactic (Tacticals.then_ - ~start:(mk_tactic (apply_tactic (PrimitiveTactics.apply_tac ~term:_Rle_not_lt))) - ~continuation:(tac_zero_infeq_pos gl (-n,d))) - status - in - mk_tactic (tac_zero_inf_false gl (n,d)) -;; - -(* preuve que 0<=n*(1/d) => False ; n est negatif -*) - -let tac_zero_infeq_false gl (n,d) = - let tac_zero_infeq_false gl (n,d) status = - let (proof, goal) = status in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta 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 *) - apply_tactic - (Tacticals.then_ - ~start: - (ReductionTactics.fold_tac - ~reduction:(const_lazy_reduction CicReduction.whd) - ~pattern:(ProofEngineTypes.conclusion_pattern None) - ~term: - (const_lazy_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 - mk_tactic (tac_zero_infeq_false gl (n,d)) -;; - - -(* *********** ********** ******** ??????????????? *********** **************) - -let apply_type_tac ~cast:t ~applist:al = - let apply_type_tac ~cast:t ~applist:al (proof,goal) = - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in - let irl = - CicMkImplicit.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 = - apply_tactic - (PrimitiveTactics.apply_tac - (*~term:(Cic.Appl ((Cic.Cast (Cic.Meta (fresh_meta,irl),t))::al)) *) - ~term:(Cic.Appl ((Cic.Meta (fresh_meta,irl))::al))) (* ??? *) - (proof',goal) - in - proof'',fresh_meta::goals - in - mk_tactic (apply_type_tac ~cast:t ~applist:al) -;; - -let my_cut ~term:c = - let my_cut ~term:c (proof,goal) = - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in - let irl = - CicMkImplicit.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_tactic - (apply_type_tac - ~cast:(Cic.Prod(Cic.Name "Anonymous",c,CicSubstitution.lift 1 ty)) - ~applist:[Cic.Meta(fresh_meta,irl)]) - (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 - in - mk_tactic (my_cut ~term:c) -;; - -let exact = PrimitiveTactics.exact_tac;; - -let tac_use h = - let tac_use h status = - let (proof, goal) = status in - debug("Inizio TC_USE\n"); - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - debug ("hname = "^ CicPp.ppterm h.hname ^"\n"); - debug ("ty = "^ CicPp.ppterm ty^"\n"); - apply_tactic - (match h.htype with - "Rlt" -> exact ~term:h.hname - | "Rle" -> exact ~term:h.hname - | "Rgt" -> (Tacticals.then_ - ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_gt_to_lt) - ~continuation:(exact ~term:h.hname)) - | "Rge" -> (Tacticals.then_ - ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_ge_to_le) - ~continuation:(exact ~term:h.hname)) - | "eqTLR" -> (Tacticals.then_ - ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqLR_to_le) - ~continuation:(exact ~term:h.hname)) - | "eqTRL" -> (Tacticals.then_ - ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqRL_to_le) - ~continuation:(exact ~term:h.hname)) - | _->assert false) - status - in - mk_tactic (tac_use h) -;; - -let is_ineq (h,t) = - match t with - Cic.Appl ( Cic.Const(u,boh)::next) -> - (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI or - UriManager.eq u HelmLibraryObjects.Reals.rgt_URI or - UriManager.eq u HelmLibraryObjects.Reals.rle_URI or - UriManager.eq u HelmLibraryObjects.Reals.rge_URI then true - else if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then - (match (List.hd next) with - Cic.Const (uri,_) when - UriManager.eq uri HelmLibraryObjects.Reals.r_URI - -> true - | _ -> false) - else 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 -> - [(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,None))::next -> - [Some(name,Cic.Def((CicSubstitution.lift n a),None))]@ superlift next (n+1) - | Some(name,Cic.Def(a,Some ty))::next -> - [Some(name, - Cic.Def((CicSubstitution.lift n a),Some (CicSubstitution.lift n ty))) - ] @ superlift next (n+1) - | _::next -> superlift next (n+1) (*?? ??*) - -;; - -let equality_replace a b = - 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 = CicUtil.lookup_meta goal metasenv in - let a_eq_b = C.Appl [ _eqT ; _R ; a ; b ] in - let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in - let irl = - CicMkImplicit.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) = apply_tactic - (EqualityTactics.rewrite_simpl_tac - ~direction:`LeftToRight - ~pattern:(ProofEngineTypes.conclusion_pattern None) - (C.Meta (fresh_meta,irl))) - ((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) - in - mk_tactic (equality_replace a b) -;; - -let tcl_fail a (proof,goal) = - match a with - 1 -> raise (ProofEngineTypes.Fail (lazy "fail-tactical")) - | _ -> (proof,[goal]) -;; - -(* Galla: moved in variousTactics.ml -let assumption_tac (proof,goal)= - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta 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.first ~tactics:tac_list (proof,goal) -;; -*) -(* Galla: moved in negationTactics.ml -(* !!!!! fix !!!!!!!!!! *) -let contradiction_tac (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)) - (proof,goal) -;; -*) - -(* ********************* TATTICA ******************************** *) - -let rec fourier (s_proof,s_goal)= - let s_curi,s_metasenv,s_pbo,s_pty = s_proof in - let s_metano,s_context,s_ty = CicUtil.lookup_meta s_goal s_metasenv in - debug ("invoco fourier_tac sul goal "^string_of_int(s_goal)^" e contesto:\n"); - debug_pcontext s_context; - -(* 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) -> - th_to_appl := - (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then - _Rfourier_not_ge_lt - else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then - _Rfourier_not_gt_le - else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then - _Rfourier_not_le_gt - else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then - _Rfourier_not_lt_ge - else 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 = apply_tactic - (Tacticals.then_ - ~start:(PrimitiveTactics.apply_tac ~term:!th_to_appl) - ~continuation:(PrimitiveTactics.intros_tac ())) - (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 = CicUtil.lookup_meta 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 ( mk_tactic (fun status -> - apply_tactic - (if h1.hstrict then - (Tacticals.thens - ~start:(mk_tactic (fun status -> - debug ("inizio t1 strict\n"); - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - debug ("th = "^ CicPp.ppterm _Rfourier_lt ^"\n"); - debug ("ty = "^ CicPp.ppterm ty^"\n"); - apply_tactic - (PrimitiveTactics.apply_tac ~term:_Rfourier_lt) status)) - ~continuations:[tac_use h1; - tac_zero_inf_pos (rational_to_fraction c1)]) - 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:(mk_tactic (fun status -> - debug("INIZIO TAC 1 2\n"); - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - debug ("th = "^ CicPp.ppterm _Rfourier_lt_le ^"\n"); - debug ("ty = "^ CicPp.ppterm ty^"\n"); - apply_tactic - (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)) (* end fun -> *) - 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.then_ - ~start:( mk_tactic (fun status -> - let (proof, goal) = status in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - apply_tactic - (ReductionTactics.change_tac - ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty)) - (const_lazy_term (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:(mk_tactic (fun status -> - debug("t1 ="^CicPp.ppterm !t1 ^"t2 ="^ - CicPp.ppterm !t2 ^"tc="^ CicPp.ppterm tc^"\n"); - let r = apply_tactic - (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:(mk_tactic (fun status -> - let r = apply_tactic - (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.first - ~tactics:[ "ring",Ring.ring_tac; "id", Tacticals.id_tac] - ]) - ;(*Tacticals.id_tac*) - Tacticals.then_ - ~start:(mk_tactic (fun status -> - let (proof, goal) = status in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta 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 = apply_tactic - (ReductionTactics.change_tac - ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty)) - (const_lazy_term 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 = apply_tactic !tac (proof,goal) in - debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r - - ) -;; - -let fourier_tac = mk_tactic fourier - - diff --git a/helm/ocaml/tactics/fourierR.mli b/helm/ocaml/tactics/fourierR.mli deleted file mode 100644 index e5790ec0f..000000000 --- a/helm/ocaml/tactics/fourierR.mli +++ /dev/null @@ -1,5 +0,0 @@ -(* -val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic -val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic -*) -val fourier_tac: ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/fwdSimplTactic.ml b/helm/ocaml/tactics/fwdSimplTactic.ml deleted file mode 100644 index 0bae64f6c..000000000 --- a/helm/ocaml/tactics/fwdSimplTactic.ml +++ /dev/null @@ -1,144 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -module PEH = ProofEngineHelpers -module U = CicUniv -module TC = CicTypeChecker -module PET = ProofEngineTypes -module S = CicSubstitution -module PT = PrimitiveTactics -module T = Tacticals -module FNG = FreshNamesGenerator -module MI = CicMkImplicit -module PESR = ProofEngineStructuralRules - -let fail_msg0 = "unexported clearbody: invalid argument" -let fail_msg2 = "fwd: no applicable simplification" - -let error msg = raise (PET.Fail (lazy msg)) - -(* unexported tactics *******************************************************) - -let id_tac = - let id_tac (proof,goal) = - try - let _, metasenv, _, _ = proof in - let _, _, _ = CicUtil.lookup_meta goal metasenv in - (proof,[goal]) - with CicUtil.Meta_not_found _ -> (proof, []) - in - PET.mk_tactic id_tac - -let clearbody ~index = - let rec find_name index = function - | Some (Cic.Name name, _) :: _ when index = 1 -> name - | _ :: tail when index > 1 -> find_name (pred index) tail - | _ -> error fail_msg0 - in - let clearbody status = - let (proof, goal) = status in - let _, metasenv, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - PET.apply_tactic (PESR.clearbody ~hyp:(find_name index context)) status - in - PET.mk_tactic clearbody - -(* lapply *******************************************************************) - -let strip_prods metasenv context ?how_many to_what term = - let irl = MI.identity_relocation_list_for_metavariable context in - let mk_meta metasenv its_type = - let index = MI.new_meta metasenv [] in - let metasenv = [index, context, its_type] @ metasenv in - metasenv, Cic.Meta (index, irl), index - in - let update_counters = function - | None, [] -> None, false, id_tac, [] - | None, to_what :: tail -> None, true, PT.apply_tac ~term:to_what, tail - | Some hm, [] -> Some (pred hm), false, id_tac, [] - | Some hm, to_what :: tail -> Some (pred hm), true, PT.apply_tac ~term:to_what, tail - in - let rec aux metasenv metas conts tw = function - | Some hm, _ when hm <= 0 -> metasenv, metas, conts - | xhm, Cic.Prod (Cic.Name _, t1, t2) -> - let metasenv, meta, index = mk_meta metasenv t1 in - aux metasenv (meta :: metas) (conts @ [id_tac, index]) tw (xhm, (S.subst meta t2)) - | xhm, Cic.Prod (Cic.Anonymous, t1, t2) -> - let xhm, pos, tac, tw = update_counters (xhm, tw) in - let metasenv, meta, index = mk_meta metasenv t1 in - let conts = if pos then (tac, index) :: conts else conts @ [tac, index] in - aux metasenv (meta :: metas) conts tw (xhm, (S.subst meta t2)) - | _, t -> metasenv, metas, conts - in - aux metasenv [] [] to_what (how_many, term) - -let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - (* ?(substs = []) *) ?how_many ?(to_what = []) what = - let letin_tac term = PT.letin_tac ~mk_fresh_name_callback term in - let lapply_tac (proof, goal) = - let xuri, metasenv, u, t = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let lemma, _ = TC.type_of_aux' metasenv context what U.empty_ugraph in - let lemma = FNG.clean_dummy_dependent_types lemma in - let metasenv, metas, conts = strip_prods metasenv context ?how_many to_what lemma in - let conclusion = - match metas with [] -> what | _ -> Cic.Appl (what :: List.rev metas) - in - let tac = T.then_ ~start:(letin_tac conclusion) - ~continuation:(clearbody ~index:1) - in - let proof = (xuri, metasenv, u, t) in - let aux (proof, goals) (tac, goal) = - let proof, new_goals = PET.apply_tactic tac (proof, goal) in - proof, goals @ new_goals - in - List.fold_left aux (proof, []) ((tac, goal) :: conts) - in - PET.mk_tactic lapply_tac - -(* fwd **********************************************************************) - -let fwd_simpl_tac - ?(mk_fresh_name_callback = FNG.mk_fresh_name ~subst:[]) - ~dbd hyp = - let lapply_tac to_what lemma = - lapply_tac ~mk_fresh_name_callback ~how_many:1 ~to_what:[to_what] lemma - in - let fwd_simpl_tac status = - let (proof, goal) = status in - let _, metasenv, _, _ = proof in - let _, context, ty = CicUtil.lookup_meta goal metasenv in - let index, major = PEH.lookup_type metasenv context hyp in - match FwdQueries.fwd_simpl ~dbd major with - | [] -> error fail_msg2 - | uri :: _ -> - Printf.eprintf "fwd: %s\n" (UriManager.string_of_uri uri); flush stderr; - let start = lapply_tac (Cic.Rel index) (Cic.Const (uri, [])) in - let tac = T.then_ ~start ~continuation:(PESR.clear hyp) in - PET.apply_tactic tac status - in - PET.mk_tactic fwd_simpl_tac diff --git a/helm/ocaml/tactics/fwdSimplTactic.mli b/helm/ocaml/tactics/fwdSimplTactic.mli deleted file mode 100644 index d75b83320..000000000 --- a/helm/ocaml/tactics/fwdSimplTactic.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* 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 lapply_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?how_many:int -> ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic - -val fwd_simpl_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/hashtbl_equiv.ml b/helm/ocaml/tactics/hashtbl_equiv.ml deleted file mode 100644 index 86448268c..000000000 --- a/helm/ocaml/tactics/hashtbl_equiv.ml +++ /dev/null @@ -1,190 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 8/09/2004 *) -(* *) -(* *) -(*********************************************************************) - -(* $Id$ *) - -(* the file contains an hash table of objects of the library - equivalent to some object in the standard subset; it is - mostly used to filter useless cases in auto *) - - -let equivalent_objects = -(* finte costanti; i.e. costanti senza corpo *) -[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack0.con"(*,"finte costanti"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ac10.con"(*,"finte costanti"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack2.con"(*,"finte costanti"*) - ]@ -(* inutili mostri *) -[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg0.con"(*,"useless monster"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg1.con"(*,"useless monster"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/ResAck0.con"(*,"useless monster"*) - ]@ -(* istanze *) - (UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"*)):: -[ -UriManager.uri_of_string "cic:/Paris/ZF/src/useful/lem_iff_sym.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/iff_sym.con"*); -UriManager.uri_of_string "cic:/Lyon/AUTOMATA/Ensf_types/False_imp_P.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rfunctions/sum_f_R0_triangle.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Misc/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_not_and.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/or_not_and.con"*); -UriManager.uri_of_string "cic:/Rocq/DEMOS/Sorting/diff_true_false.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/diff_true_false.con"*); -UriManager.uri_of_string "cic:/CoRN/metrics/CMetricSpaces/nz.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Max/le_max_l.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Decidable/not_or.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_eq.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_sqrt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_def.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eqT2eq.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_eq_0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rsqr_0_uniq.con"*); -UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/en_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_10.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_pos.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*); -UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/le.ind#xpointer(1/1/1)"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_n_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"*); -UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor1.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_diag_eq_mult_2.con"*); -UriManager.uri_of_string "cic:/Coq/Relations/Newman/caseRxy.con"(*,UriManager.uri_of_string "cic:/Coq/Relations/Newman/Ind_proof.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/S_plus_r.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_n_Sm.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zmult_ab0a0b0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_integral.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax8.con"(*,UriManager.uri_of_string "cic:/Coq/NArith/BinPos/ZC2.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/Zlt_reg_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat_l.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_1.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Classic.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_pos_lt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_sqr.con"*); -UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo_def/sin_antisym.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo/sin_neg.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/false_implies_everything.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*); -UriManager.uri_of_string "cic:/Coq/ring/Setoid_ring_normalize/index_eq_prop.con"(*,UriManager.uri_of_string "cic:/Coq/ring/Ring_normalize/index_eq_prop.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_pred.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_pred.con"*); -UriManager.uri_of_string "cic:/Lannion/continuations/FOUnify_cps/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*); -UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_right.con"(*,UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_cons.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_compat_l.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rplus_lt_0_compat.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/DiscrR/Rplus_lt_pos.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*); -UriManager.uri_of_string "cic:/CoRN/fta/KeyLemma/lem_1c.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA20.con"(*,UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA17.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_2.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/injective_projections.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zle_lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_lt_compat.con"*); -UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); -UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/not_gt_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_gt.con"*); -UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/lt_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_lt_compat_r.con"*); -UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_neg.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_non_eq.con"*); -UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_Sn_m.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Qhomographic_Qpositive_to_Qpositive/one_non_negative.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zle_0_1.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rle_0_1.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/proof_irrel.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_eq.con"*); -UriManager.uri_of_string "cic:/Coq/IntMap/Mapiter/pair_sp.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/ProofIrrelevance/proof_irrelevance_cci.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_or_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_and_or.con"*); -UriManager.uri_of_string "cic:/CoRN/model/structures/Zsec/Zplus_wd0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_eq_compat.con"*); -UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor6.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_0_r_reverse.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/S_inj.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*); -UriManager.uri_of_string "cic:/Coq/ZArith/Wf_Z/Z_of_nat_complete.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/IZN.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_orb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/orb_comm.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/PartSum/plus_sum.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Cauchy_prod/sum_plus.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Qpositive/minus_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_zero.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1_auto/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_andb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/andb_comm.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/canonicite/Prelude0/Morgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/TrueP.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/FalseP.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zminus_eq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zminus_eq.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_1.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*); -UriManager.uri_of_string "cic:/Orsay/Maths/divide/Zabs_ind.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_ind.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/Zmult_minus_distr_r.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_minus_distr_l.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/Sn_eq_Sm_n_eq_m.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"*); -UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA2.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/P_Rmin.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/P_Rmin.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Huffman/Aux/le_minus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_O_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_l.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Berardi/inv2.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Berardi/AC.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/SeqProp/not_Rlt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rnot_lt_ge.con"*); -UriManager.uri_of_string "cic:/Nancy/FOUnify/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_le_0_compat.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le_sym.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_Zmult.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_n_O.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_mult.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat.con"*); -UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_true2.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_left.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_l.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax3.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zgt_pos_0.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_triangle.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Buchberger/Buch/Sdep.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/prod_ind.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rsum_abs.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*); -UriManager.uri_of_string "cic:/Cachan/SMC/mu/minus_n_m_le_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Marseille/GC/lib_arith/lib_S_pred/eqnm_eqSnSm.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/predminus1.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/pred_of_minus.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/Rpower_pow.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/Rpower_pow.con"*); -UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_neq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zlt_not_eq.con"*); -UriManager.uri_of_string "cic:/Coq/Arith/Lt/nat_total_order.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_eq.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/2)"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/1)"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zmult_pos_pos.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_O_compat.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zlt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/pred_ext_and_rel_choice_imp_EM.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Rsa/MiscRsa/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*) -] -;; - -let equiv_table = Hashtbl.create 503 -;; - -let _ = List.iter (fun a -> Hashtbl.add equiv_table a "") equivalent_objects -;; - -let not_a_duplicate u = - try - ignore(Hashtbl.find equiv_table u); false - with - Not_found -> true -;; diff --git a/helm/ocaml/tactics/hashtbl_equiv.mli b/helm/ocaml/tactics/hashtbl_equiv.mli deleted file mode 100644 index d2608b862..000000000 --- a/helm/ocaml/tactics/hashtbl_equiv.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* 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 *) -(* *) -(* Andrea Asperti *) -(* 8/09/2004 *) -(* *) -(* *) -(*********************************************************************) - - -val not_a_duplicate : UriManager.uri -> bool - diff --git a/helm/ocaml/tactics/history.ml b/helm/ocaml/tactics/history.ml deleted file mode 100644 index 7559f367e..000000000 --- a/helm/ocaml/tactics/history.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception History_failure - -class ['a] history size = - let unsome = function Some x -> x | None -> assert false in - object (self) - - val history_data = Array.create (size + 1) None - - val mutable history_hd = 0 (* rightmost index *) - val mutable history_cur = 0 (* current index *) - val mutable history_tl = 0 (* leftmost index *) - - method private is_empty = history_data.(history_cur) = None - - method push (status: 'a) = - if self#is_empty then - history_data.(history_cur) <- Some status - else begin - history_cur <- (history_cur + 1) mod size; - history_data.(history_cur) <- Some status; - history_hd <- history_cur; (* throw away fake future line *) - if history_hd = history_tl then (* tail overwritten *) - history_tl <- (history_tl + 1) mod size - end - - method undo = function - | 0 -> unsome history_data.(history_cur) - | steps when steps > 0 -> - let max_undo_steps = - if history_cur >= history_tl then - history_cur - history_tl - else - history_cur + (size - history_tl) - in - if steps > max_undo_steps then - raise History_failure; - history_cur <- history_cur - steps; - if history_cur < 0 then (* fix underflow *) - history_cur <- size + history_cur; - unsome history_data.(history_cur) - | steps (* when steps > 0 *) -> self#redo ~-steps - - method redo = function - | 0 -> unsome history_data.(history_cur) - | steps when steps > 0 -> - let max_redo_steps = - if history_hd >= history_cur then - history_hd - history_cur - else - history_hd + (size - history_cur) - in - if steps > max_redo_steps then - raise History_failure; - history_cur <- (history_cur + steps) mod size; - unsome history_data.(history_cur) - | steps (* when steps > 0 *) -> self#undo ~-steps - - end - diff --git a/helm/ocaml/tactics/history.mli b/helm/ocaml/tactics/history.mli deleted file mode 100644 index 86bad463f..000000000 --- a/helm/ocaml/tactics/history.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -exception History_failure - -class ['a] history : - int -> - object - method push : 'a -> unit - method redo : int -> 'a - method undo : int -> 'a - end - diff --git a/helm/ocaml/tactics/introductionTactics.ml b/helm/ocaml/tactics/introductionTactics.ml deleted file mode 100644 index 9ed3647c1..000000000 --- a/helm/ocaml/tactics/introductionTactics.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let fake_constructor_tac ~n (proof, goal) = - let module C = Cic in - let module R = CicReduction in - let (_,metasenv,_,_) = proof in - let metano,context,ty = CicUtil.lookup_meta 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))::_)) -> - ProofEngineTypes.apply_tactic ( - PrimitiveTactics.apply_tac - ~term: (C.MutConstruct (uri, typeno, n, exp_named_subst))) - (proof, goal) - | _ -> raise (ProofEngineTypes.Fail (lazy "Constructor: failed")) -;; - -let constructor_tac ~n = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n) - -let exists_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; -let split_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; -let left_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; -let right_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:2) ;; - diff --git a/helm/ocaml/tactics/introductionTactics.mli b/helm/ocaml/tactics/introductionTactics.mli deleted file mode 100644 index c3a12720b..000000000 --- a/helm/ocaml/tactics/introductionTactics.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* 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 diff --git a/helm/ocaml/tactics/inversion.ml b/helm/ocaml/tactics/inversion.ml deleted file mode 100644 index 5e442657d..000000000 --- a/helm/ocaml/tactics/inversion.ml +++ /dev/null @@ -1,252 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple -exception NotAnInductiveTypeToEliminate - -let debug = false;; -let debug_print = - fun msg -> if debug then prerr_endline (Lazy.force msg) else () - - -let inside_obj = function - | Cic.InductiveDefinition (l,params, nleft, _) -> - (l,params,nleft) - | _ -> raise (Invalid_argument "Errore in inside_obj") - -let term_to_list = function - | Cic.Appl l -> l - | _ -> raise (Invalid_argument "Errore in term_to_list") - - -let rec baseuri_of_term = function - | Cic.Appl l -> baseuri_of_term (List.hd l) - | Cic.MutInd (baseuri, tyno, []) -> baseuri - | _ -> raise (Invalid_argument "baseuri_of_term") - - -(* prende il numero dei parametri sinistri, la lista dei parametri, la lista -dei tipi dei parametri, il tipo del GOAL e costruisce il termine per la cut -ossia DX1 = DX1 -> ... DXn=DXn -> GOALTY *) - -let rec foo_cut nleft l param_ty_l body uri_of_eq = - if nleft > 0 then foo_cut (nleft-1) (List.tl l) (List.tl param_ty_l) body - uri_of_eq - else match l with - | hd::tl -> Cic.Prod (Cic.Anonymous, Cic.Appl[Cic.MutInd (uri_of_eq ,0,[]); - (List.hd param_ty_l) ; hd; hd], foo_cut nleft - (List.map (CicSubstitution.lift 1) tl) (List.tl param_ty_l) - (CicSubstitution.lift 1 body) uri_of_eq ) - | [] -> body - ;; - -(* da una catena di prod costruisce una lista dei termini che lo compongono.*) -let rec list_of_prod term = -match term with - | Cic.Prod (Cic.Anonymous,src,tgt) -> [src] @ (list_of_prod tgt) - | _ -> [term] -;; - - -let rec cut_first n l = - if n>0 then - match l with - | hd::tl -> cut_first (n-1) tl - | [] -> [] - else l -;; - - -let rec cut_last l = -match l with - | hd::tl when tl != [] -> hd:: (cut_last tl) - | _ -> [] -;; - - -let foo_appl nleft nright_consno term uri = - let l = [] in - let a = ref l in - for n = 1 to nleft do - a := !a @ [(Cic.Implicit None)] - done; - a:= !a @ [term]; - for n = 1 to nright_consno do - a := !a @ [(Cic.Implicit None)] - done; - Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1]) (*L'ipotesi e' sempre Rel 1. (?) *) -;; - - -let rec foo_prod nright param_ty_l l l2 base_rel body uri_of_eq nleft termty - isSetType term = - match param_ty_l with - | hd::tl -> Cic.Prod ( - Cic.Anonymous, - Cic.Appl[Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd l); Cic.Rel base_rel], - foo_prod (nright-1) tl (List.map (CicSubstitution.lift 1) (List.tl l)) - (List.map (CicSubstitution.lift 1) l2) - base_rel (CicSubstitution.lift 1 body) - uri_of_eq nleft (CicSubstitution.lift 1 termty) - isSetType (CicSubstitution.lift 1 term)) - | [] -> ProofEngineReduction.replace_lifting - ~equality:(ProofEngineReduction.alpha_equivalence) - ~what: (if isSetType - then ((cut_first (1+nleft) (term_to_list termty) ) @ [term] ) - else (cut_first (1+nleft) (term_to_list termty) ) ) - ~with_what: (List.map (CicSubstitution.lift (-1)) l2) - ~where:body -(*TODO lo stesso sottotermine di body puo' essere sia sx che dx!*) -;; - -let rec foo_lambda nright param_ty_l nright_ param_ty_l_ l l2 base_rel body - uri_of_eq nleft termty isSetType ty_indty term = - (*assert nright >0 *) - match param_ty_l with - | hd::tl ->Cic.Lambda ( - (Cic.Name ("lambda" ^ (string_of_int nright))), - hd, (* typ *) - foo_lambda (nright-1) tl nright_ param_ty_l_ - (List.map (CicSubstitution.lift 1) l) - (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1])) - base_rel (CicSubstitution.lift 1 body) - uri_of_eq nleft - (CicSubstitution.lift 1 termty) - isSetType ty_indty - (CicSubstitution.lift 1 term)) - | [] when isSetType -> Cic.Lambda ( - (Cic.Name ("lambda" ^ (string_of_int nright))), - (ProofEngineReduction.replace_lifting - ~equality:(ProofEngineReduction.alpha_equivalence) - ~what: (cut_first (1+nleft) (term_to_list termty) ) - ~with_what: (List.map (CicSubstitution.lift (-1)) l2) - ~where:termty), (* tipo di H con i parametri destri sostituiti *) - foo_prod nright_ param_ty_l_ (List.map (CicSubstitution.lift 1) l) - (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1])) - (base_rel+1) (CicSubstitution.lift 1 body) - uri_of_eq nleft - (CicSubstitution.lift 1 termty) isSetType - (CicSubstitution.lift 1 term)) - | [] -> foo_prod nright_ param_ty_l_ l l2 base_rel body uri_of_eq nleft - termty isSetType term -;; - -let inversion_tac ~term = - let module T = CicTypeChecker in - let module R = CicReduction in - let module C = Cic in - let module P = PrimitiveTactics in - let module PET = ProofEngineTypes in - let module PEH = ProofEngineHelpers in - let inversion_tac ~term (proof, goal) = - let (_,metasenv,_,_) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let uri_of_eq = HelmLibraryObjects.Logic.eq_URI in - - (* dall'indice che indentifica il goal nel metasenv, ritorna il suo tipo, che - e' la terza componente della relativa congettura *) - let (_,_,body) = CicUtil.lookup_meta goal metasenv in - (* estrae il tipo del termine(ipotesi) oggetto di inversion, - di solito un Cic.Appl *) - let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in - let uri = baseuri_of_term termty in - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - let l,params,nleft = inside_obj o in - let (_,_,typeno,_) = - 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 = UriManager.buri_of_uri uri in - let name = - match o with - C.InductiveDefinition (tys,_,_,_) -> - let (name,_,_,_) = List.nth tys typeno in - name - |_ -> assert false - in - let ext = "_ind" in - UriManager.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con") - in - (* il tipo del tipo induttivo da cui viene l'ipotesi oggetto di inversione *) - let (_,_,ty_indty,cons_list) = (List.hd l) in - (*la lista di Cic.term ricavata dal tipo del tipo induttivo. *) - let param_ty_l = list_of_prod ty_indty in - let consno = List.length cons_list in - let nright= (List.length param_ty_l)- (nleft+1) in - let isSetType = ((Pervasives.compare - (List.nth param_ty_l ((List.length param_ty_l)-1)) - (Cic.Sort Cic.Prop)) != 0) - in - (* eliminiamo la testa di termty, in quanto e' il nome del predicato e non un parametro.*) - let cut_term = foo_cut nleft (List.tl (term_to_list termty)) - (list_of_prod ty_indty) body uri_of_eq in - (* cut DXn=DXn \to GOAL *) - let proof1,gl1 = PET.apply_tactic (P.cut_tac cut_term) (proof,goal) in - (* apply Hcut ; reflexivity (su tutti i goals aperti da apply_tac) *) - let proof2, gl2 = PET.apply_tactic - (Tacticals.then_ - ~start: (P.apply_tac (C.Rel 1)) (* apply Hcut *) - ~continuation: (EqualityTactics.reflexivity_tac) - ) (proof1, (List.hd gl1)) - in - (* apply (ledx_ind( lambda x. lambda y, ...)) *) - let (t1,metasenv,t3,t4) = proof2 in - let goal2 = List.hd (List.tl gl1) in - let (metano,context,_) = CicUtil.lookup_meta goal2 metasenv in - let cut_param_ty_l = (cut_first nleft (cut_last param_ty_l)) in - (* la lista dei soli parametri destri *) - let l= cut_first (1+nleft) (term_to_list termty) in - let lambda_t = foo_lambda nright cut_param_ty_l nright cut_param_ty_l l [] - nright body uri_of_eq nleft termty isSetType ty_indty term in - let t = foo_appl nleft (nright+consno) lambda_t eliminator_uri in - debug_print (lazy ("Lambda_t: " ^ (CicPp.ppterm t))); - debug_print (lazy ("Term: " ^ (CicPp.ppterm termty))); - debug_print (lazy ("Body: " ^ (CicPp.ppterm body))); - debug_print (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl l)))); - - let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t - CicUniv.empty_ugraph - in - let proof2 = (t1,metasenv'',t3,t4) in - let proof3,gl3 = PET.apply_tactic (P.apply_tac ref_t) (proof2, goal2) in - let new_goals = ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:metasenv'' - in - let patched_new_goals = - let (_,metasenv''',_,_) = proof3 in - List.filter (function i -> List.exists (function (j,_,_) -> j=i) metasenv''') - new_goals @ gl3 - in - (*prerr_endline ("METASENV: " ^ CicMetaSubst.ppmetasenv metasenv []); DEBUG*) - (proof3, patched_new_goals) -in -ProofEngineTypes.mk_tactic (inversion_tac ~term) -;; diff --git a/helm/ocaml/tactics/inversion.mli b/helm/ocaml/tactics/inversion.mli deleted file mode 100644 index 50bdf58f2..000000000 --- a/helm/ocaml/tactics/inversion.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* 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 inversion_tac: term: Cic.term -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/metadataQuery.ml b/helm/ocaml/tactics/metadataQuery.ml deleted file mode 100644 index b9c053653..000000000 --- a/helm/ocaml/tactics/metadataQuery.ml +++ /dev/null @@ -1,367 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let nonvar uri = not (UriManager.uri_is_var uri) - -module Constr = MetadataConstraints - -exception Goal_is_not_an_equation - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -let ( ** ) x y = int_of_float ((float_of_int x) ** (float_of_int y)) - -let signature_of_hypothesis context = - List.fold_left - (fun set hyp -> - match hyp with - | None -> set - | Some (_, Cic.Decl t) - | Some (_, Cic.Def (t, _)) -> - Constr.UriManagerSet.union set (Constr.constants_of t)) - Constr.UriManagerSet.empty context - -let intersect uris siguris = - let set1 = List.fold_right Constr.UriManagerSet.add uris Constr.UriManagerSet.empty in - let set2 = - List.fold_right Constr.UriManagerSet.add siguris Constr.UriManagerSet.empty - in - let inter = Constr.UriManagerSet.inter set1 set2 in - List.filter (fun s -> Constr.UriManagerSet.mem s inter) uris - -(* Profiling code -let at_most = - let profiler = CicUtil.profile "at_most" in - fun ~dbd ~where uri -> profiler.profile (Constr.at_most ~dbd ~where) uri - -let sigmatch = - let profiler = CicUtil.profile "sigmatch" in - fun ~dbd ~facts ~where signature -> - profiler.profile (MetadataConstraints.sigmatch ~dbd ~facts ~where) signature -*) -let at_most = Constr.at_most -let sigmatch = MetadataConstraints.sigmatch - -let filter_uris_forward ~dbd (main, constants) uris = - let main_uris = - match main with - | None -> [] - | Some (main, types) -> main :: types - in - let full_signature = - List.fold_right Constr.UriManagerSet.add main_uris constants - in - List.filter (at_most ~dbd ~where:`Statement full_signature) uris - -let filter_uris_backward ~dbd ~facts signature uris = - let siguris = - List.map snd - (sigmatch ~dbd ~facts ~where:`Statement signature) - in - intersect uris siguris - -let compare_goal_list proof goal1 goal2 = - let _,metasenv,_,_ = proof in - let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in - let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in - let ty_sort1,_ = - CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.empty_ugraph - in - let ty_sort2,_ = - CicTypeChecker.type_of_aux' metasenv ey2 ty2 CicUniv.empty_ugraph - in - let prop1 = - let b,_ = - CicReduction.are_convertible - ey1 (Cic.Sort Cic.Prop) ty_sort1 CicUniv.empty_ugraph - in - if b then 0 - else 1 - in - let prop2 = - let b,_ = - CicReduction.are_convertible - ey2 (Cic.Sort Cic.Prop) ty_sort2 CicUniv.empty_ugraph - in - if b then 0 - else 1 - in - prop1 - prop2 - -(* experimental_hint is a version of hint for experimental - purposes. It uses auto_tac_verbose instead of auto tac. - Auto_tac verbose also returns a substitution - for the moment - as a function from cic to cic, to be changed into an association - list in the future -. This substitution is used to build a - hash table of the inspected goals with their associated proofs. - The cose is a cut and paste of the previous one: at the end - of the experimentation we shall make a choice. *) - -let close_with_types s metasenv context = - Constr.UriManagerSet.fold - (fun e bag -> - let t = CicUtil.term_of_uri e in - let ty, _ = - CicTypeChecker.type_of_aux' metasenv context t CicUniv.empty_ugraph - in - Constr.UriManagerSet.union bag (Constr.constants_of ty)) - s s - -let close_with_constructors s metasenv context = - Constr.UriManagerSet.fold - (fun e bag -> - let t = CicUtil.term_of_uri e in - match t with - Cic.MutInd (uri,_,_) - | Cic.MutConstruct (uri,_,_,_) -> - (match fst (CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - Cic.InductiveDefinition(tl,_,_,_) -> - snd - (List.fold_left - (fun (i,s) (_,_,_,cl) -> - let _,s = - List.fold_left - (fun (j,s) _ -> - let curi = UriManager.uri_of_uriref uri i (Some j) in - j+1,Constr.UriManagerSet.add curi s) (1,s) cl in - (i+1,s)) (0,bag) tl) - | _ -> assert false) - | _ -> bag) - s s - -(* Profiling code -let apply_tac_verbose = - let profiler = CicUtil.profile "apply_tac_verbose" in - fun ~term status -> profiler.profile (PrimitiveTactics.apply_tac_verbose ~term) status - -let sigmatch = - let profiler = CicUtil.profile "sigmatch" in - fun ~dbd ~facts ?(where=`Conclusion) signature -> profiler.profile (Constr.sigmatch ~dbd ~facts ~where) signature - -let cmatch' = - let profiler = CicUtil.profile "cmatch'" in - fun ~dbd ~facts signature -> profiler.profile (Constr.cmatch' ~dbd ~facts) signature -*) -let apply_tac_verbose = PrimitiveTactics.apply_tac_verbose -let cmatch' = Constr.cmatch' - -let signature_of_goal ~(dbd:HMysql.dbd) ((proof, goal) as _status) = - let (_, metasenv, _, _) = proof in - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let main, sig_constants = Constr.signature_of ty in - let set = signature_of_hypothesis context in - let set = - match main with - None -> set - | Some (main,l) -> - List.fold_right Constr.UriManagerSet.add (main::l) set in - let set = Constr.UriManagerSet.union set sig_constants in - let all_constants_closed = close_with_types set metasenv context in - let uris = - sigmatch ~dbd ~facts:false ~where:`Statement (None,all_constants_closed) in - let uris = List.filter nonvar (List.map snd uris) in - let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in - uris - -let equations_for_goal ~(dbd:HMysql.dbd) ((proof, goal) as _status) = -(* let to_string set = - "{ " ^ - (String.concat ", " - (Constr.UriManagerSet.fold - (fun u l -> (UriManager.string_of_uri u)::l) set [])) - ^ " }" - in *) - let (_, metasenv, _, _) = proof in - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let main, sig_constants = Constr.signature_of ty in -(* Printf.printf "\nsig_constants: %s\n\n" (to_string sig_constants); *) -(* match main with *) -(* None -> raise Goal_is_not_an_equation *) -(* | Some (m,l) -> *) - let m, l = - let eq_URI = - let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (us ^ "#xpointer(1/1)") - in - match main with - | None -> eq_URI, [] - | Some (m, l) when UriManager.eq m eq_URI -> m, l - | Some (m, l) -> eq_URI, [] - in - Printf.printf "\nSome (m, l): %s, [%s]\n\n" - (UriManager.string_of_uri m) - (String.concat "; " (List.map UriManager.string_of_uri l)); - (* if m == UriManager.uri_of_string HelmLibraryObjects.Logic.eq_XURI then ( *) - let set = signature_of_hypothesis context in - (* Printf.printf "\nsignature_of_hypothesis: %s\n\n" (to_string set); *) - let set = Constr.UriManagerSet.union set sig_constants in - let set = close_with_types set metasenv context in - (* Printf.printf "\ndopo close_with_types: %s\n\n" (to_string set); *) - let set = close_with_constructors set metasenv context in - (* Printf.printf "\ndopo close_with_constructors: %s\n\n" (to_string set); *) - let set = List.fold_right Constr.UriManagerSet.remove (m::l) set in - let uris = - sigmatch ~dbd ~facts:false ~where:`Statement (main,set) in - let uris = List.filter nonvar (List.map snd uris) in - let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in - uris - (* ) *) - (* else raise Goal_is_not_an_equation *) - -let experimental_hint - ~(dbd:HMysql.dbd) ?(facts=false) ?signature ((proof, goal) as status) = - let (_, metasenv, _, _) = proof in - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let (uris, (main, sig_constants)) = - match signature with - | Some signature -> - (sigmatch ~dbd ~facts signature, signature) - | None -> - (cmatch' ~dbd ~facts ty, Constr.signature_of ty) - in - let uris = List.filter nonvar (List.map snd uris) in - let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in - let types_constants = - match main with - | None -> Constr.UriManagerSet.empty - | Some (main, types) -> - List.fold_right Constr.UriManagerSet.add (main :: types) - Constr.UriManagerSet.empty - in - let all_constants = - let hyp_and_sug = - Constr.UriManagerSet.union - (signature_of_hypothesis context) - sig_constants - in - let main = - match main with - | None -> Constr.UriManagerSet.empty - | Some (main,_) -> - let ty, _ = - CicTypeChecker.type_of_aux' - metasenv context (CicUtil.term_of_uri main) CicUniv.empty_ugraph - in - Constr.constants_of ty - in - Constr.UriManagerSet.union main hyp_and_sug - in -(* Constr.UriManagerSet.iter debug_print hyp_constants; *) - let all_constants_closed = close_with_types all_constants metasenv context in - let other_constants = - Constr.UriManagerSet.diff all_constants_closed types_constants - in - debug_print (lazy "all_constants_closed"); - if debug then Constr.UriManagerSet.iter (fun s -> debug_print (lazy (UriManager.string_of_uri s))) all_constants_closed; - debug_print (lazy "other_constants"); - if debug then Constr.UriManagerSet.iter (fun s -> debug_print (lazy (UriManager.string_of_uri s))) other_constants; - let uris = - let pow = 2 ** (Constr.UriManagerSet.cardinal other_constants) in - if ((List.length uris < pow) or (pow <= 0)) - then begin - debug_print (lazy "MetadataQuery: large sig, falling back to old method"); - filter_uris_forward ~dbd (main, other_constants) uris - end else - filter_uris_backward ~dbd ~facts (main, other_constants) uris - in - let rec aux = function - | [] -> [] - | uri :: tl -> - (let status' = - try - let (subst,(proof, goal_list)) = - (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *) - apply_tac_verbose - ~term:(CicUtil.term_of_uri uri) - status - in - let goal_list = - List.stable_sort (compare_goal_list proof) goal_list - in - Some (uri, (subst,(proof, goal_list))) - with ProofEngineTypes.Fail _ -> None - in - match status' with - | None -> aux tl - | Some status' -> status' :: aux tl) - in - List.stable_sort - (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) -> - Pervasives.compare (List.length goals1) (List.length goals2)) - (aux uris) - -let new_experimental_hint - ~(dbd:HMysql.dbd) ?(facts=false) ?signature ~universe - ((proof, goal) as status) -= - let (_, metasenv, _, _) = proof in - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let (uris, (main, sig_constants)) = - match signature with - | Some signature -> - (sigmatch ~dbd ~facts signature, signature) - | None -> - (cmatch' ~dbd ~facts ty, Constr.signature_of ty) in - let universe = - List.fold_left - (fun res u -> Constr.UriManagerSet.add u res) - Constr.UriManagerSet.empty universe in - let uris = - List.fold_left - (fun res (_,u) -> Constr.UriManagerSet.add u res) - Constr.UriManagerSet.empty uris in - let uris = Constr.UriManagerSet.inter uris universe in - let uris = Constr.UriManagerSet.elements uris in - let rec aux = function - | [] -> [] - | uri :: tl -> - (let status' = - try - let (subst,(proof, goal_list)) = - (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *) - apply_tac_verbose - ~term:(CicUtil.term_of_uri uri) - status - in - let goal_list = - List.stable_sort (compare_goal_list proof) goal_list - in - Some (uri, (subst,(proof, goal_list))) - with ProofEngineTypes.Fail _ -> None - in - match status' with - | None -> aux tl - | Some status' -> status' :: aux tl) - in - List.stable_sort - (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) -> - Pervasives.compare (List.length goals1) (List.length goals2)) - (aux uris) - diff --git a/helm/ocaml/tactics/metadataQuery.mli b/helm/ocaml/tactics/metadataQuery.mli deleted file mode 100644 index b65a23fa9..000000000 --- a/helm/ocaml/tactics/metadataQuery.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - - (** @param vars if set variables (".var" URIs) are considered. Defaults to - * false - * @param pat shell like pattern matching over object names, a string where "*" - * is interpreted as 0 or more characters and "?" as exactly one character *) - -val signature_of_goal: - dbd:HMysql.dbd -> ProofEngineTypes.status -> UriManager.uri list - -val equations_for_goal: - dbd:HMysql.dbd -> ProofEngineTypes.status -> UriManager.uri list - -val experimental_hint: - dbd:HMysql.dbd -> - ?facts:bool -> - ?signature:MetadataConstraints.term_signature -> - ProofEngineTypes.status -> - (UriManager.uri * - ((Cic.term -> Cic.term) * - (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list - -val new_experimental_hint: - dbd:HMysql.dbd -> - ?facts:bool -> - ?signature:MetadataConstraints.term_signature -> - universe:UriManager.uri list -> - ProofEngineTypes.status -> - (UriManager.uri * - ((Cic.term -> Cic.term) * - (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list - diff --git a/helm/ocaml/tactics/negationTactics.ml b/helm/ocaml/tactics/negationTactics.ml deleted file mode 100644 index 7ee79e534..000000000 --- a/helm/ocaml/tactics/negationTactics.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let absurd_tac ~term = - let absurd_tac ~term status = - let (proof, goal) = status in - let module C = Cic in - let module U = UriManager in - let module P = PrimitiveTactics in - let _,metasenv,_,_ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let ty_term,_ = - CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in - if (ty_term = (C.Sort C.Prop)) (* ma questo controllo serve?? *) - then ProofEngineTypes.apply_tactic - (P.apply_tac - ~term:( - C.Appl [(C.Const (LibraryObjects.absurd_URI (), [] )) ; - term ; ty]) - ) - status - else raise (ProofEngineTypes.Fail (lazy "Absurd: Not a Proposition")) - in - ProofEngineTypes.mk_tactic (absurd_tac ~term) -;; - -(* FG: METTERE I NOMI ANCHE QUI? CSC: in teoria si', per la intros*) -let contradiction_tac = - 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 - ProofEngineTypes.apply_tactic ( - T.then_ - ~start:(P.intros_tac ()) - ~continuation:( - T.then_ - ~start: - (EliminationTactics.elim_type_tac - (C.MutInd (LibraryObjects.false_URI (), 0, []))) - ~continuation: VariousTactics.assumption_tac)) - status - with - ProofEngineTypes.Fail msg when Lazy.force msg = "Assumption: No such assumption" -> raise (ProofEngineTypes.Fail (lazy "Contradiction: No such assumption")) - (* sarebbe piu' elegante se Assumtion sollevasse un'eccezione tutta sua che questa cattura, magari con l'aiuto di try_tactics *) - in - ProofEngineTypes.mk_tactic contradiction_tac -;; - -(* Questa era in fourierR.ml -(* !!!!! fix !!!!!!!!!! *) -let contradiction_tac (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)) - (proof,goal) -;; -*) - - diff --git a/helm/ocaml/tactics/negationTactics.mli b/helm/ocaml/tactics/negationTactics.mli deleted file mode 100644 index bfa3e8d5d..000000000 --- a/helm/ocaml/tactics/negationTactics.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* 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 - diff --git a/helm/ocaml/tactics/paramodulation/.depend b/helm/ocaml/tactics/paramodulation/.depend deleted file mode 100644 index e69de29bb..000000000 diff --git a/helm/ocaml/tactics/paramodulation/Makefile b/helm/ocaml/tactics/paramodulation/Makefile deleted file mode 100644 index f1b613400..000000000 --- a/helm/ocaml/tactics/paramodulation/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -PACKAGE = dummy - -LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser,helm-tactics - -include ../../../Makefile.defs -include ../../Makefile.common - -all $(PACKAGE).cma :saturate - @echo -n -opt $(PACKAGE).cmxa:saturate.opt - @echo -n - -saturate: saturate_main.ml $(LIBRARIES) - @echo " OCAMLC $<" - @$(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $< -saturate.opt: saturate_main.ml $(LIBRARIES) - @echo " OCAMLOPT $<" - @$(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $< - -clean: - rm -f saturate saturate.opt - - diff --git a/helm/ocaml/tactics/paramodulation/README b/helm/ocaml/tactics/paramodulation/README deleted file mode 100644 index bf484ae16..000000000 --- a/helm/ocaml/tactics/paramodulation/README +++ /dev/null @@ -1,45 +0,0 @@ -make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata) - -./saturate -h per vedere una lista di parametri: - -./saturate: unknown option `-h'. -Usage: - -full Enable full mode - -f Enable/disable full-reduction strategy (default: enabled) - -r Weight-Age equality selection ratio (default: 4) - -s symbols-based selection ratio (relative to the weight ratio, default: 0) - -c Configuration file (for the db connection) - -o Term ordering. Possible values are: - kbo: Knuth-Bendix ordering - nr-kbo: Non-recursive variant of kbo (default) - lpo: Lexicographic path ordering - -l Time limit in seconds (default: no limit) - -w Maximal width (default: 3) - -d Maximal depth (default: 3) - -retrieve retrieve only - -help Display this list of options - --help Display this list of options - - -./saturate -l 10 -demod-equalities - -dove -l 10 e` il timeout in secondi. - -Il programma legge da standard input il teorema, per esempio - -\forall n:nat.n + n = 2 * n -\forall n:R.n + n = 2 * n -\forall n:R.n+n=n+n - -l'input termina con una riga vuota (quindi basta un doppio invio alla fine) - -In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi -active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output -su file, per esempio usando tee: - -./saturate -l 10 -demod-equalities | tee output.txt - -Il formato di stampa e` quello per gli oggetti di tipo equality (usa la -funzione Inference.string_of_equality) - - diff --git a/helm/ocaml/tactics/paramodulation/equality_indexing.ml b/helm/ocaml/tactics/paramodulation/equality_indexing.ml deleted file mode 100644 index 1dffb6399..000000000 --- a/helm/ocaml/tactics/paramodulation/equality_indexing.ml +++ /dev/null @@ -1,131 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -module type EqualityIndex = - sig - module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality - val arities : (Cic.term, int) Hashtbl.t - type key = Cic.term - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t - val empty : t - val retrieve_generalizations : t -> key -> PosEqSet.t - val retrieve_unifiables : t -> key -> PosEqSet.t - val init_index : unit -> unit - val remove_index : t -> Inference.equality -> t - val index : t -> Inference.equality -> t - val in_index : t -> Inference.equality -> bool - end - -module DT = -struct - module OrderedPosEquality = struct - type t = Utils.pos * Inference.equality - let compare = Pervasives.compare - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) - - - (* DISCRIMINATION TREES *) - let init_index () = - Hashtbl.clear arities; - ;; - - let remove_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> remove_index tree l (Utils.Left, equality) - | Utils.Lt -> remove_index tree r (Utils.Right, equality) - | _ -> - let tree = remove_index tree r (Utils.Right, equality) in - remove_index tree l (Utils.Left, equality) - - let index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> index tree l (Utils.Left, equality) - | Utils.Lt -> index tree r (Utils.Right, equality) - | _ -> - let tree = index tree r (Utils.Right, equality) in - index tree l (Utils.Left, equality) - - - let in_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let meta_convertibility (pos,equality') = - Inference.meta_convertibility_eq equality equality' - in - in_index tree l meta_convertibility || in_index tree r meta_convertibility - - end - -module PT = - struct - module OrderedPosEquality = struct - type t = Utils.pos * Inference.equality - let compare = Pervasives.compare - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) - - - (* DISCRIMINATION TREES *) - let init_index () = - Hashtbl.clear arities; - ;; - - let remove_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> remove_index tree l (Utils.Left, equality) - | Utils.Lt -> remove_index tree r (Utils.Right, equality) - | _ -> - let tree = remove_index tree r (Utils.Right, equality) in - remove_index tree l (Utils.Left, equality) - - let index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> index tree l (Utils.Left, equality) - | Utils.Lt -> index tree r (Utils.Right, equality) - | _ -> - let tree = index tree r (Utils.Right, equality) in - index tree l (Utils.Left, equality) - - - let in_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let meta_convertibility (pos,equality') = - Inference.meta_convertibility_eq equality equality' - in - in_index tree l meta_convertibility || in_index tree r meta_convertibility -end - diff --git a/helm/ocaml/tactics/paramodulation/equality_indexing.mli b/helm/ocaml/tactics/paramodulation/equality_indexing.mli deleted file mode 100644 index d7c3bec5e..000000000 --- a/helm/ocaml/tactics/paramodulation/equality_indexing.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -module type EqualityIndex = - sig - module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality - val arities : (Cic.term, int) Hashtbl.t - type key = Cic.term - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t - val empty : t - val retrieve_generalizations : t -> key -> PosEqSet.t - val retrieve_unifiables : t -> key -> PosEqSet.t - val init_index : unit -> unit - val remove_index : t -> Inference.equality -> t - val index : t -> Inference.equality -> t - val in_index : t -> Inference.equality -> bool - end - -module DT : EqualityIndex -module PT : EqualityIndex - diff --git a/helm/ocaml/tactics/paramodulation/indexing.ml b/helm/ocaml/tactics/paramodulation/indexing.ml deleted file mode 100644 index 5830b0842..000000000 --- a/helm/ocaml/tactics/paramodulation/indexing.ml +++ /dev/null @@ -1,1052 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -module Index = Equality_indexing.DT (* discrimination tree based indexing *) -(* -module Index = Equality_indexing.DT (* path tree based indexing *) -*) - -let debug_print = Utils.debug_print;; - -(* -for debugging -let check_equation env equation msg = - let w, proof, (eq_ty, left, right, order), metas, args = equation in - let metasenv, context, ugraph = env in - let metasenv' = metasenv @ metas in - try - CicTypeChecker.type_of_aux' metasenv' context left ugraph; - CicTypeChecker.type_of_aux' metasenv' context right ugraph; - () - with - CicUtil.Meta_not_found _ as exn -> - begin - prerr_endline msg; - prerr_endline (CicPp.ppterm left); - prerr_endline (CicPp.ppterm right); - raise exn - end -*) - -type retrieval_mode = Matching | Unification;; - -let print_candidates mode term res = - let _ = - match mode with - | Matching -> - Printf.printf "| candidates Matching %s\n" (CicPp.ppterm term) - | Unification -> - Printf.printf "| candidates Unification %s\n" (CicPp.ppterm term) - in - print_endline - (String.concat "\n" - (List.map - (fun (p, e) -> - Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p) - (Inference.string_of_equality e)) - res)); - print_endline "|"; -;; - - -let indexing_retrieval_time = ref 0.;; - - -let apply_subst = CicMetaSubst.apply_subst - -let index = Index.index -let remove_index = Index.remove_index -let in_index = Index.in_index -let empty = Index.empty -let init_index = Index.init_index - -(* returns a list of all the equalities in the tree that are in relation - "mode" with the given term, where mode can be either Matching or - Unification. - - Format of the return value: list of tuples in the form: - (position - Left or Right - of the term that matched the given one in this - equality, - equality found) - - Note that if equality is "left = right", if the ordering is left > right, - the position will always be Left, and if the ordering is left < right, - position will be Right. -*) -let get_candidates mode tree term = - let t1 = Unix.gettimeofday () in - let res = - let s = - match mode with - | Matching -> Index.retrieve_generalizations tree term - | Unification -> Index.retrieve_unifiables tree term - in - Index.PosEqSet.elements s - in - (* print_candidates mode term res; *) -(* print_endline (Discrimination_tree.string_of_discrimination_tree tree); *) -(* print_newline (); *) - let t2 = Unix.gettimeofday () in - indexing_retrieval_time := !indexing_retrieval_time +. (t2 -. t1); - res -;; - - -let match_unif_time_ok = ref 0.;; -let match_unif_time_no = ref 0.;; - - -(* - finds the first equality in the index that matches "term", of type "termty" - termty can be Implicit if it is not needed. The result (one of the sides of - the equality, actually) should be not greater (wrt the term ordering) than - term - - Format of the return value: - - (term to substitute, [Cic.Rel 1 properly lifted - see the various - build_newtarget functions inside the various - demodulation_* functions] - substitution used for the matching, - metasenv, - ugraph, [substitution, metasenv and ugraph have the same meaning as those - returned by CicUnification.fo_unif] - (equality where the matching term was found, [i.e. the equality to use as - rewrite rule] - uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of - the equality: this is used to build the proof term, again see one of - the build_newtarget functions] - )) -*) -let rec find_matches metasenv context ugraph lift_amount term termty = - let module C = Cic in - let module U = Utils in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let cmp = !Utils.compare_terms in - let check = match termty with C.Implicit None -> false | _ -> true in - function - | [] -> None - | candidate::tl -> - let pos, (_, proof, (ty, left, right, o), metas, args) = candidate in - if check && not (fst (CicReduction.are_convertible - ~metasenv context termty ty ugraph)) then ( - find_matches metasenv context ugraph lift_amount term termty tl - ) else - let do_match c eq_URI = - let subst', metasenv', ugraph' = - let t1 = Unix.gettimeofday () in - try - let r = - Inference.matching (metasenv @ metas) context - term (S.lift lift_amount c) ugraph - in - let t2 = Unix.gettimeofday () in - match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); - r - with - | Inference.MatchingFailure as e -> - let t2 = Unix.gettimeofday () in - match_unif_time_no := !match_unif_time_no +. (t2 -. t1); - raise e - | CicUtil.Meta_not_found _ as exn -> - prerr_endline "zurg"; - raise exn - in - Some (C.Rel (1 + lift_amount), subst', metasenv', ugraph', - (candidate, eq_URI)) - in - let c, other, eq_URI = - if pos = Utils.Left then left, right, Utils.eq_ind_URI () - else right, left, Utils.eq_ind_r_URI () - in - if o <> U.Incomparable then - try - do_match c eq_URI - with Inference.MatchingFailure -> - find_matches metasenv context ugraph lift_amount term termty tl - else - let res = - try do_match c eq_URI - with Inference.MatchingFailure -> None - in - match res with - | Some (_, s, _, _, _) -> - let c' = apply_subst s c in - (* - let other' = U.guarded_simpl context (apply_subst s other) in *) - let other' = apply_subst s other in - let order = cmp c' other' in - if order = U.Gt then - res - else - find_matches - metasenv context ugraph lift_amount term termty tl - | None -> - find_matches metasenv context ugraph lift_amount term termty tl -;; - - -(* - as above, but finds all the matching equalities, and the matching condition - can be either Inference.matching or Inference.unification -*) -let rec find_all_matches ?(unif_fun=Inference.unification) - metasenv context ugraph lift_amount term termty = - let module C = Cic in - let module U = Utils in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let cmp = !Utils.compare_terms in - function - | [] -> [] - | candidate::tl -> - let pos, (_, _, (ty, left, right, o), metas, args) = candidate in - let do_match c eq_URI = - let subst', metasenv', ugraph' = - let t1 = Unix.gettimeofday () in - try - let r = - unif_fun (metasenv @ metas) context - term (S.lift lift_amount c) ugraph in - let t2 = Unix.gettimeofday () in - match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); - r - with - | Inference.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ as e -> - let t2 = Unix.gettimeofday () in - match_unif_time_no := !match_unif_time_no +. (t2 -. t1); - raise e - in - (C.Rel (1 + lift_amount), subst', metasenv', ugraph', - (candidate, eq_URI)) - in - let c, other, eq_URI = - if pos = Utils.Left then left, right, Utils.eq_ind_URI () - else right, left, Utils.eq_ind_r_URI () - in - if o <> U.Incomparable then - try - let res = do_match c eq_URI in - res::(find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl) - with - | Inference.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl - else - try - let res = do_match c eq_URI in - match res with - | _, s, _, _, _ -> - let c' = apply_subst s c - and other' = apply_subst s other in - let order = cmp c' other' in - if order <> U.Lt && order <> U.Le then - res::(find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl) - else - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl - with - | Inference.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl -;; - - -(* - returns true if target is subsumed by some equality in table -*) -let subsumption env table target = - let _, _, (ty, left, right, _), tmetas, _ = target in - let metasenv, context, ugraph = env in - let metasenv = metasenv @ tmetas in - let samesubst subst subst' = - let tbl = Hashtbl.create (List.length subst) in - List.iter (fun (m, (c, t1, t2)) -> Hashtbl.add tbl m (c, t1, t2)) subst; - List.for_all - (fun (m, (c, t1, t2)) -> - try - let c', t1', t2' = Hashtbl.find tbl m in - if (c = c') && (t1 = t1') && (t2 = t2') then true - else false - with Not_found -> - true) - subst' - in - let leftr = - match left with - | Cic.Meta _ -> [] - | _ -> - let leftc = get_candidates Matching table left in - find_all_matches ~unif_fun:Inference.matching - metasenv context ugraph 0 left ty leftc - in - let rec ok what = function - | [] -> false, [] - | (_, subst, menv, ug, ((pos, (_, _, (_, l, r, o), m, _)), _))::tl -> - try - let other = if pos = Utils.Left then r else l in - let subst', menv', ug' = - let t1 = Unix.gettimeofday () in - try - let r = - Inference.matching (metasenv @ menv @ m) context what other ugraph - in - let t2 = Unix.gettimeofday () in - match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); - r - with Inference.MatchingFailure as e -> - let t2 = Unix.gettimeofday () in - match_unif_time_no := !match_unif_time_no +. (t2 -. t1); - raise e - in - if samesubst subst subst' then - true, subst - else - ok what tl - with Inference.MatchingFailure -> - ok what tl - in - let r, subst = ok right leftr in - let r, s = - if r then - true, subst - else - let rightr = - match right with - | Cic.Meta _ -> [] - | _ -> - let rightc = get_candidates Matching table right in - find_all_matches ~unif_fun:Inference.matching - metasenv context ugraph 0 right ty rightc - in - ok left rightr - in -(* (if r then *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "SUBSUMPTION! %s\n%s\n" *) -(* (Inference.string_of_equality target) (Utils.print_subst s)))); *) - r, s -;; - - -let rec demodulation_aux ?(typecheck=false) - metasenv context ugraph table lift_amount term = - (* Printf.eprintf "term = %s\n" (CicPp.ppterm term); *) - - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let candidates = get_candidates Matching table term in - match term with - | C.Meta _ -> None - | term -> - let termty, ugraph = - if typecheck then - CicTypeChecker.type_of_aux' metasenv context term ugraph - else - C.Implicit None, ugraph - in - let res = - find_matches metasenv context ugraph lift_amount term termty candidates - in - if res <> None then - res - else - match term with - | C.Appl l -> - let res, ll = - List.fold_left - (fun (res, tl) t -> - if res <> None then - (res, tl @ [S.lift 1 t]) - else - let r = - demodulation_aux metasenv context ugraph table - lift_amount t - in - match r with - | None -> (None, tl @ [S.lift 1 t]) - | Some (rel, _, _, _, _) -> (r, tl @ [rel])) - (None, []) l - in ( - match res with - | None -> None - | Some (_, subst, menv, ug, eq_found) -> - Some (C.Appl ll, subst, menv, ug, eq_found) - ) - | C.Prod (nn, s, t) -> - let r1 = - demodulation_aux metasenv context ugraph table lift_amount s in ( - match r1 with - | None -> - let r2 = - demodulation_aux metasenv - ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t - in ( - match r2 with - | None -> None - | Some (t', subst, menv, ug, eq_found) -> - Some (C.Prod (nn, (S.lift 1 s), t'), - subst, menv, ug, eq_found) - ) - | Some (s', subst, menv, ug, eq_found) -> - Some (C.Prod (nn, s', (S.lift 1 t)), - subst, menv, ug, eq_found) - ) - | C.Lambda (nn, s, t) -> - let r1 = - demodulation_aux metasenv context ugraph table lift_amount s in ( - match r1 with - | None -> - let r2 = - demodulation_aux metasenv - ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t - in ( - match r2 with - | None -> None - | Some (t', subst, menv, ug, eq_found) -> - Some (C.Lambda (nn, (S.lift 1 s), t'), - subst, menv, ug, eq_found) - ) - | Some (s', subst, menv, ug, eq_found) -> - Some (C.Lambda (nn, s', (S.lift 1 t)), - subst, menv, ug, eq_found) - ) - | t -> - None -;; - - -let build_newtarget_time = ref 0.;; - - -let demod_counter = ref 1;; - -(** demodulation, when target is an equality *) -let rec demodulation_equality newmeta env table sign target = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let module U = Utils in - let metasenv, context, ugraph = env in - let w, proof, (eq_ty, left, right, order), metas, args = target in - (* first, we simplify *) - let right = U.guarded_simpl context right in - let left = U.guarded_simpl context left in - let w = Utils.compute_equality_weight eq_ty left right in - let order = !Utils.compare_terms left right in - let target = w, proof, (eq_ty, left, right, order), metas, args in - - let metasenv' = metasenv @ metas in - - let maxmeta = ref newmeta in - - let build_newtarget is_left (t, subst, menv, ug, (eq_found, eq_URI)) = - let time1 = Unix.gettimeofday () in - - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let ty = - try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) - with CicUtil.Meta_not_found _ -> ty - in - let what, other = if pos = Utils.Left then what, other else other, what in - let newterm, newproof = - let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in - let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in - incr demod_counter; - let bo' = - let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); - S.lift 1 eq_ty; l; r] - in - if sign = Utils.Positive then - (bo, - Inference.ProofBlock ( - subst, eq_URI, (name, ty), bo'(* t' *), eq_found, proof)) - else - let metaproof = - incr maxmeta; - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in -(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) -(* print_newline (); *) - C.Meta (!maxmeta, irl) - in - let eq_found = - let proof' = - let termlist = - if pos = Utils.Left then [ty; what; other] - else [ty; other; what] - in - Inference.ProofSymBlock (termlist, proof') - in - let what, other = - if pos = Utils.Left then what, other else other, what - in - pos, (0, proof', (ty, other, what, Utils.Incomparable), - menv', args') - in - let target_proof = - let pb = - Inference.ProofBlock (subst, eq_URI, (name, ty), bo', - eq_found, Inference.BasicProof metaproof) - in - match proof with - | Inference.BasicProof _ -> - print_endline "replacing a BasicProof"; - pb - | Inference.ProofGoalBlock (_, parent_proof) -> - print_endline "replacing another ProofGoalBlock"; - Inference.ProofGoalBlock (pb, parent_proof) - | _ -> assert false - in - let refl = - C.Appl [C.MutConstruct (* reflexivity *) - (LibraryObjects.eq_URI (), 0, 1, []); - eq_ty; if is_left then right else left] - in - (bo, - Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) - in - let left, right = if is_left then newterm, right else left, newterm in - let m = - (Inference.metas_of_term left) - @ (Inference.metas_of_term right) - @ (Inference.metas_of_term eq_ty) in - (* let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') *) - let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metasenv' @ menv') - and newargs = args - in - let ordering = !Utils.compare_terms left right in - - let time2 = Unix.gettimeofday () in - build_newtarget_time := !build_newtarget_time +. (time2 -. time1); - - let res = - let w = Utils.compute_equality_weight eq_ty left right in - (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs) - in - !maxmeta, res - in - let _ = - try - CicTypeChecker.type_of_aux' metasenv' context left ugraph; - CicTypeChecker.type_of_aux' metasenv' context right ugraph; - with - CicUtil.Meta_not_found _ as exn -> - begin - prerr_endline "siamo in demodulation_equality 1"; - prerr_endline (CicPp.ppterm left); - prerr_endline (CicPp.ppterm right); - raise exn - end - in - let res = demodulation_aux metasenv' context ugraph table 0 left in - let newmeta, newtarget = - match res with - | Some t -> - let newmeta, newtarget = build_newtarget true t in - if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) || - (Inference.meta_convertibility_eq target newtarget) then - newmeta, newtarget - else - demodulation_equality newmeta env table sign newtarget - | None -> - let res = demodulation_aux metasenv' context ugraph table 0 right in - match res with - | Some t -> - let newmeta, newtarget = build_newtarget false t in - if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) || - (Inference.meta_convertibility_eq target newtarget) then - newmeta, newtarget - else - demodulation_equality newmeta env table sign newtarget - | None -> - newmeta, target - in - (* newmeta, newtarget *) - newmeta,newtarget -;; - - -(** - Performs the beta expansion of the term "term" w.r.t. "table", - i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2 - in table. -*) -let rec betaexpand_term metasenv context ugraph table lift_amount term = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let candidates = get_candidates Unification table term in - let res, lifted_term = - match term with - | C.Meta (i, l) -> - let l', lifted_l = - List.fold_right - (fun arg (res, lifted_tl) -> - match arg with - | Some arg -> - let arg_res, lifted_arg = - betaexpand_term metasenv context ugraph table - lift_amount arg in - let l1 = - List.map - (fun (t, s, m, ug, eq_found) -> - (Some t)::lifted_tl, s, m, ug, eq_found) - arg_res - in - (l1 @ - (List.map - (fun (l, s, m, ug, eq_found) -> - (Some lifted_arg)::l, s, m, ug, eq_found) - res), - (Some lifted_arg)::lifted_tl) - | None -> - (List.map - (fun (r, s, m, ug, eq_found) -> - None::r, s, m, ug, eq_found) res, - None::lifted_tl) - ) l ([], []) - in - let e = - List.map - (fun (l, s, m, ug, eq_found) -> - (C.Meta (i, l), s, m, ug, eq_found)) l' - in - e, C.Meta (i, lifted_l) - - | C.Rel m -> - [], if m <= lift_amount then C.Rel m else C.Rel (m+1) - - | C.Prod (nn, s, t) -> - let l1, lifted_s = - betaexpand_term metasenv context ugraph table lift_amount s in - let l2, lifted_t = - betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t in - let l1' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1 - and l2' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in - l1' @ l2', C.Prod (nn, lifted_s, lifted_t) - - | C.Lambda (nn, s, t) -> - let l1, lifted_s = - betaexpand_term metasenv context ugraph table lift_amount s in - let l2, lifted_t = - betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t in - let l1' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1 - and l2' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in - l1' @ l2', C.Lambda (nn, lifted_s, lifted_t) - - | C.Appl l -> - let l', lifted_l = - List.fold_right - (fun arg (res, lifted_tl) -> - let arg_res, lifted_arg = - betaexpand_term metasenv context ugraph table lift_amount arg - in - let l1 = - List.map - (fun (a, s, m, ug, eq_found) -> - a::lifted_tl, s, m, ug, eq_found) - arg_res - in - (l1 @ - (List.map - (fun (r, s, m, ug, eq_found) -> - lifted_arg::r, s, m, ug, eq_found) - res), - lifted_arg::lifted_tl) - ) l ([], []) - in - (List.map - (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l', - C.Appl lifted_l) - - | t -> [], (S.lift lift_amount t) - in - match term with - | C.Meta (i, l) -> res, lifted_term - | term -> - let termty, ugraph = - C.Implicit None, ugraph -(* CicTypeChecker.type_of_aux' metasenv context term ugraph *) - in - let r = - find_all_matches - metasenv context ugraph lift_amount term termty candidates - in - r @ res, lifted_term -;; - - -let sup_l_counter = ref 1;; - -(** - superposition_left - returns a list of new clauses inferred with a left superposition step - the negative equation "target" and one of the positive equations in "table" -*) -let superposition_left newmeta (metasenv, context, ugraph) table target = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let module CR = CicReduction in - let module U = Utils in - let weight, proof, (eq_ty, left, right, ordering), menv, _ = target in - let expansions, _ = - let term = if ordering = U.Gt then left else right in - betaexpand_term metasenv context ugraph table 0 term - in - let maxmeta = ref newmeta in - let build_new (bo, s, m, ug, (eq_found, eq_URI)) = - -(* debug_print (lazy "\nSUPERPOSITION LEFT\n"); *) - - let time1 = Unix.gettimeofday () in - - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let newgoal, newproof = - let bo' = U.guarded_simpl context (apply_subst s (S.subst other bo)) in - let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in - incr sup_l_counter; - let bo'' = - let l, r = - if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); - S.lift 1 eq_ty; l; r] - in - incr maxmeta; - let metaproof = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - C.Meta (!maxmeta, irl) - in - let eq_found = - let proof' = - let termlist = - if pos = Utils.Left then [ty; what; other] - else [ty; other; what] - in - Inference.ProofSymBlock (termlist, proof') - in - let what, other = - if pos = Utils.Left then what, other else other, what - in - pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') - in - let target_proof = - let pb = - Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, - Inference.BasicProof metaproof) - in - match proof with - | Inference.BasicProof _ -> -(* debug_print (lazy "replacing a BasicProof"); *) - pb - | Inference.ProofGoalBlock (_, parent_proof) -> -(* debug_print (lazy "replacing another ProofGoalBlock"); *) - Inference.ProofGoalBlock (pb, parent_proof) - | _ -> assert false - in - let refl = - C.Appl [C.MutConstruct (* reflexivity *) - (LibraryObjects.eq_URI (), 0, 1, []); - eq_ty; if ordering = U.Gt then right else left] - in - (bo', - Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) - in - let left, right = - if ordering = U.Gt then newgoal, right else left, newgoal in - let neworder = !Utils.compare_terms left right in - - let time2 = Unix.gettimeofday () in - build_newtarget_time := !build_newtarget_time +. (time2 -. time1); - - let res = - let w = Utils.compute_equality_weight eq_ty left right in - (w, newproof, (eq_ty, left, right, neworder), menv @ menv', []) - in - res - in - !maxmeta, List.map build_new expansions -;; - - -let sup_r_counter = ref 1;; - -(** - superposition_right - returns a list of new clauses inferred with a right superposition step - between the positive equation "target" and one in the "table" "newmeta" is - the first free meta index, i.e. the first number above the highest meta - index: its updated value is also returned -*) -let superposition_right newmeta (metasenv, context, ugraph) table target = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let module CR = CicReduction in - let module U = Utils in - let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in - let metasenv' = metasenv @ newmetas in - let maxmeta = ref newmeta in - let res1, res2 = - match ordering with - | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), [] - | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right) - | _ -> - let res l r = - List.filter - (fun (_, subst, _, _, _) -> - let subst = apply_subst subst in - let o = !Utils.compare_terms (subst l) (subst r) in - o <> U.Lt && o <> U.Le) - (fst (betaexpand_term metasenv' context ugraph table 0 l)) - in - (res left right), (res right left) - in - let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) = - - let time1 = Unix.gettimeofday () in - - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let newgoal, newproof = - (* qua *) - let bo' = Utils.guarded_simpl context (apply_subst s (S.subst other bo)) in - let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in - incr sup_r_counter; - let bo'' = - let l, r = - if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); - S.lift 1 eq_ty; l; r] - in - bo', - Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, eqproof) - in - let newmeta, newequality = - let left, right = - if ordering = U.Gt then newgoal, apply_subst s right - else apply_subst s left, newgoal in - let neworder = !Utils.compare_terms left right - and newmenv = newmetas @ menv' - and newargs = args @ args' in - let eq' = - let w = Utils.compute_equality_weight eq_ty left right in - (w, newproof, (eq_ty, left, right, neworder), newmenv, newargs) in - let newm, eq' = Inference.fix_metas !maxmeta eq' in - newm, eq' - in - maxmeta := newmeta; - - let time2 = Unix.gettimeofday () in - build_newtarget_time := !build_newtarget_time +. (time2 -. time1); - - newequality - in - let new1 = List.map (build_new U.Gt) res1 - and new2 = List.map (build_new U.Lt) res2 in -(* - let ok e = not (Inference.is_identity (metasenv, context, ugraph) e) in -*) - let ok e = not (Inference.is_identity (metasenv', context, ugraph) e) in - (!maxmeta, - (List.filter ok (new1 @ new2))) -;; - - -(** demodulation, when the target is a goal *) -let rec demodulation_goal newmeta env table goal = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let metasenv, context, ugraph = env in - let maxmeta = ref newmeta in - let proof, metas, term = goal in - let term = Utils.guarded_simpl (~debug:true) context term in - let goal = proof, metas, term in - let metasenv' = metasenv @ metas in - - let build_newgoal (t, subst, menv, ug, (eq_found, eq_URI)) = - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let ty = - try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) - with CicUtil.Meta_not_found _ -> ty - in - let newterm, newproof = - (* qua *) - let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in - let bo' = apply_subst subst t in - let name = C.Name ("x_DemodGoal_" ^ (string_of_int !demod_counter)) in - incr demod_counter; - let metaproof = - incr maxmeta; - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in -(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) - C.Meta (!maxmeta, irl) - in - let eq_found = - let proof' = - let termlist = - if pos = Utils.Left then [ty; what; other] - else [ty; other; what] - in - Inference.ProofSymBlock (termlist, proof') - in - let what, other = - if pos = Utils.Left then what, other else other, what - in - pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') - in - let goal_proof = - let pb = - Inference.ProofBlock (subst, eq_URI, (name, ty), bo', - eq_found, Inference.BasicProof metaproof) - in - let rec repl = function - | Inference.NoProof -> -(* debug_print (lazy "replacing a NoProof"); *) - pb - | Inference.BasicProof _ -> -(* debug_print (lazy "replacing a BasicProof"); *) - pb - | Inference.ProofGoalBlock (_, parent_proof) -> -(* debug_print (lazy "replacing another ProofGoalBlock"); *) - Inference.ProofGoalBlock (pb, parent_proof) - | Inference.SubProof (term, meta_index, p) -> - Inference.SubProof (term, meta_index, repl p) - | _ -> assert false - in repl proof - in - bo, Inference.ProofGoalBlock (Inference.NoProof, goal_proof) - in - let m = Inference.metas_of_term newterm in - (* QUA *) - let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (menv @ menv')in - !maxmeta, (newproof, newmetasenv, newterm) - in - let res = - demodulation_aux ~typecheck:true metasenv' context ugraph table 0 term - in - match res with - | Some t -> - let newmeta, newgoal = build_newgoal t in - let _, _, newg = newgoal in - if Inference.meta_convertibility term newg then - newmeta, newgoal - else - demodulation_goal newmeta env table newgoal - | None -> - newmeta, goal -;; - - -(** demodulation, when the target is a theorem *) -let rec demodulation_theorem newmeta env table theorem = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let metasenv, context, ugraph = env in - let maxmeta = ref newmeta in - let term, termty, metas = theorem in - let metasenv' = metasenv @ metas in - - let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) = - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let newterm, newty = - (* qua *) - let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in - let bo' = apply_subst subst t in - let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in - incr demod_counter; - let newproof = - Inference.ProofBlock (subst, eq_URI, (name, ty), bo', eq_found, - Inference.BasicProof term) - in - (Inference.build_proof_term newproof, bo) - in - - let m = Inference.metas_of_term newterm in - let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') in - !maxmeta, (newterm, newty, newmetasenv) - in - let res = - demodulation_aux ~typecheck:true metasenv' context ugraph table 0 termty - in - match res with - | Some t -> - let newmeta, newthm = build_newtheorem t in - let newt, newty, _ = newthm in - if Inference.meta_convertibility termty newty then - newmeta, newthm - else - demodulation_theorem newmeta env table newthm - | None -> - newmeta, theorem -;; - diff --git a/helm/ocaml/tactics/paramodulation/indexing.mli b/helm/ocaml/tactics/paramodulation/indexing.mli deleted file mode 100644 index 8a6f9c2b6..000000000 --- a/helm/ocaml/tactics/paramodulation/indexing.mli +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -module Index : - sig - module PosEqSet : Set.S - with type elt = Utils.pos * Inference.equality - and type t = Equality_indexing.DT.PosEqSet.t - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t - type key = Cic.term - end - -val index : Index.t -> Inference.equality -> Index.t -val remove_index : Index.t -> Inference.equality -> Index.t -val in_index : Index.t -> Inference.equality -> bool -val empty : Index.t -val match_unif_time_ok : float ref -val match_unif_time_no : float ref -val indexing_retrieval_time : float ref -val init_index : unit -> unit -val build_newtarget_time : float ref -val subsumption : - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - 'a * 'b * ('c * Index.key * Index.key * 'd) * Cic.metasenv * 'e -> - bool * Cic.substitution -val superposition_left : - int -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - 'a * Inference.proof * - (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv * 'c -> - int * - (int * Inference.proof * - (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv * - 'e list) - list -val superposition_right : - int -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - 'a * Inference.proof * - (Cic.term * Index.key * Index.key * Utils.comparison) * - Cic.metasenv * Cic.term list -> int * Inference.equality list -val demodulation_equality : - int -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Utils.equality_sign -> Inference.equality -> int * Inference.equality -val demodulation_goal : - int -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Inference.proof * Cic.metasenv * Index.key -> - int * (Inference.proof * Cic.metasenv * Index.key) -val demodulation_theorem : - 'a -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Cic.term * Index.key * Cic.metasenv -> - 'a * (Cic.term * Index.key * Cic.metasenv) - diff --git a/helm/ocaml/tactics/paramodulation/inference.ml b/helm/ocaml/tactics/paramodulation/inference.ml deleted file mode 100644 index dfb67583e..000000000 --- a/helm/ocaml/tactics/paramodulation/inference.ml +++ /dev/null @@ -1,1005 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -open Utils;; - - -type equality = - int * (* weight *) - proof * - (Cic.term * (* type *) - Cic.term * (* left side *) - Cic.term * (* right side *) - Utils.comparison) * (* ordering *) - Cic.metasenv * (* environment for metas *) - Cic.term list (* arguments *) - -and proof = - | NoProof (* term is the goal missing a proof *) - | BasicProof of Cic.term - | ProofBlock of - Cic.substitution * UriManager.uri * - (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof - | ProofGoalBlock of proof * proof - | ProofSymBlock of Cic.term list * proof - | SubProof of Cic.term * int * proof -;; - - -let string_of_equality ?env = - match env with - | None -> ( - function - | w, _, (ty, left, right, o), _, _ -> - Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty) - (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right) - ) - | Some (_, context, _) -> ( - let names = names_of_context context in - function - | w, _, (ty, left, right, o), _, _ -> - Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names) - (CicPp.pp left names) (string_of_comparison o) - (CicPp.pp right names) - ) -;; - - -let rec string_of_proof = function - | NoProof -> "NoProof " - | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t) - | SubProof (t, i, p) -> - Printf.sprintf "SubProof(%s, %s, %s)" - (CicPp.ppterm t) (string_of_int i) (string_of_proof p) - | ProofSymBlock _ -> "ProofSymBlock" - | ProofBlock _ -> "ProofBlock" - | ProofGoalBlock (p1, p2) -> - Printf.sprintf "ProofGoalBlock(%s, %s)" - (string_of_proof p1) (string_of_proof p2) -;; - - -(* returns an explicit named subst and a list of arguments for sym_eq_URI *) -let build_ens_for_sym_eq sym_eq_URI termlist = - let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in - match obj with - | Cic.Constant (_, _, _, uris, _) -> - assert (List.length uris <= List.length termlist); - let rec aux = function - | [], tl -> [], tl - | (uri::uris), (term::tl) -> - let ens, args = aux (uris, tl) in - (uri, term)::ens, args - | _, _ -> assert false - in - aux (uris, termlist) - | _ -> assert false -;; - - -let build_proof_term ?(noproof=Cic.Implicit None) proof = - let rec do_build_proof proof = - match proof with - | NoProof -> - Printf.fprintf stderr "WARNING: no proof!\n"; - noproof - | BasicProof term -> term - | ProofGoalBlock (proofbit, proof) -> - print_endline "found ProofGoalBlock, going up..."; - do_build_goal_proof proofbit proof - | ProofSymBlock (termlist, proof) -> - let proof = do_build_proof proof in - let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in - Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof]) - | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) -> - let t' = Cic.Lambda (name, ty, bo) in - let proof' = - let _, proof', _, _, _ = eq in - do_build_proof proof' - in - let eqproof = do_build_proof eqproof in - let _, _, (ty, what, other, _), menv', args' = eq in - let what, other = - if pos = Utils.Left then what, other else other, what - in - CicMetaSubst.apply_subst subst - (Cic.Appl [Cic.Const (eq_URI, []); ty; - what; t'; eqproof; other; proof']) - | SubProof (term, meta_index, proof) -> - let proof = do_build_proof proof in - let eq i = function - | Cic.Meta (j, _) -> i = j - | _ -> false - in - ProofEngineReduction.replace - ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term - - and do_build_goal_proof proofbit proof = - match proof with - | ProofGoalBlock (pb, p) -> - do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p)) - | _ -> do_build_proof (replace_proof proofbit proof) - - and replace_proof newproof = function - | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) -> - let eqproof' = replace_proof newproof eqproof in - ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof') - | ProofGoalBlock (pb, p) -> - let pb' = replace_proof newproof pb in - ProofGoalBlock (pb', p) - | BasicProof _ -> newproof - | SubProof (term, meta_index, p) -> - SubProof (term, meta_index, replace_proof newproof p) - | p -> p - in - do_build_proof proof -;; - - -let rec metas_of_term = function - | Cic.Meta (i, c) -> [i] - | Cic.Var (_, ens) - | Cic.Const (_, ens) - | Cic.MutInd (_, _, ens) - | Cic.MutConstruct (_, _, _, ens) -> - List.flatten (List.map (fun (u, t) -> metas_of_term t) ens) - | Cic.Cast (s, t) - | Cic.Prod (_, s, t) - | Cic.Lambda (_, s, t) - | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t) - | Cic.Appl l -> List.flatten (List.map metas_of_term l) - | Cic.MutCase (uri, i, s, t, l) -> - (metas_of_term s) @ (metas_of_term t) @ - (List.flatten (List.map metas_of_term l)) - | Cic.Fix (i, il) -> - List.flatten - (List.map (fun (s, i, t1, t2) -> - (metas_of_term t1) @ (metas_of_term t2)) il) - | Cic.CoFix (i, il) -> - List.flatten - (List.map (fun (s, t1, t2) -> - (metas_of_term t1) @ (metas_of_term t2)) il) - | _ -> [] -;; - - -exception NotMetaConvertible;; - -let meta_convertibility_aux table t1 t2 = - let module C = Cic in - let rec aux ((table_l, table_r) as table) t1 t2 = - match t1, t2 with - | C.Meta (m1, tl1), C.Meta (m2, tl2) -> - let m1_binding, table_l = - try List.assoc m1 table_l, table_l - with Not_found -> m2, (m1, m2)::table_l - and m2_binding, table_r = - try List.assoc m2 table_r, table_r - with Not_found -> m1, (m2, m1)::table_r - in - if (m1_binding <> m2) || (m2_binding <> m1) then - raise NotMetaConvertible - else ( - try - List.fold_left2 - (fun res t1 t2 -> - match t1, t2 with - | None, Some _ | Some _, None -> raise NotMetaConvertible - | None, None -> res - | Some t1, Some t2 -> (aux res t1 t2)) - (table_l, table_r) tl1 tl2 - with Invalid_argument _ -> - raise NotMetaConvertible - ) - | C.Var (u1, ens1), C.Var (u2, ens2) - | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) -> - aux_ens table ens1 ens2 - | C.Cast (s1, t1), C.Cast (s2, t2) - | C.Prod (_, s1, t1), C.Prod (_, s2, t2) - | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2) - | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) -> - let table = aux table s1 s2 in - aux table t1 t2 - | C.Appl l1, C.Appl l2 -> ( - try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2) - when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2 - | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2) - when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 -> - aux_ens table ens1 ens2 - | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2) - when (UriManager.eq u1 u2) && i1 = i2 -> - let table = aux table s1 s2 in - let table = aux table t1 t2 in ( - try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> ( - try - List.fold_left2 - (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) -> - if i1 <> i2 then raise NotMetaConvertible - else - let res = (aux res s1 s2) in aux res t1 t2) - table il1 il2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> ( - try - List.fold_left2 - (fun res (n1, s1, t1) (n2, s2, t2) -> - let res = aux res s1 s2 in aux res t1 t2) - table il1 il2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | t1, t2 when t1 = t2 -> table - | _, _ -> raise NotMetaConvertible - - and aux_ens table ens1 ens2 = - let cmp (u1, t1) (u2, t2) = - compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) - in - let ens1 = List.sort cmp ens1 - and ens2 = List.sort cmp ens2 in - try - List.fold_left2 - (fun res (u1, t1) (u2, t2) -> - if not (UriManager.eq u1 u2) then raise NotMetaConvertible - else aux res t1 t2) - table ens1 ens2 - with Invalid_argument _ -> raise NotMetaConvertible - in - aux table t1 t2 -;; - - -let meta_convertibility_eq eq1 eq2 = - let _, _, (ty, left, right, _), _, _ = eq1 - and _, _, (ty', left', right', _), _, _ = eq2 in - if ty <> ty' then - false - else if (left = left') && (right = right') then - true - else if (left = right') && (right = left') then - true - else - try - let table = meta_convertibility_aux ([], []) left left' in - let _ = meta_convertibility_aux table right right' in - true - with NotMetaConvertible -> - try - let table = meta_convertibility_aux ([], []) left right' in - let _ = meta_convertibility_aux table right left' in - true - with NotMetaConvertible -> - false -;; - - -let meta_convertibility t1 t2 = - if t1 = t2 then - true - else - try - ignore(meta_convertibility_aux ([], []) t1 t2); - true - with NotMetaConvertible -> - false -;; - - -let rec check_irl start = function - | [] -> true - | None::tl -> check_irl (start+1) tl - | (Some (Cic.Rel x))::tl -> - if x = start then check_irl (start+1) tl else false - | _ -> false -;; - - -let rec is_simple_term = function - | Cic.Appl ((Cic.Meta _)::_) -> false - | Cic.Appl l -> List.for_all is_simple_term l - | Cic.Meta (i, l) -> check_irl 1 l - | Cic.Rel _ -> true - | Cic.Const _ -> true - | Cic.MutInd (_, _, []) -> true - | Cic.MutConstruct (_, _, _, []) -> true - | _ -> false -;; - - -let lookup_subst meta subst = - match meta with - | Cic.Meta (i, _) -> ( - try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t - with Not_found -> meta - ) - | _ -> assert false -;; - - -let unification_simple metasenv context t1 t2 ugraph = - let module C = Cic in - let module M = CicMetaSubst in - let module U = CicUnification in - let lookup = lookup_subst in - let rec occurs_check subst what where = - match where with - | t when what = t -> true - | C.Appl l -> List.exists (occurs_check subst what) l - | C.Meta _ -> - let t = lookup where subst in - if t <> where then occurs_check subst what t else false - | _ -> false - in - let rec unif subst menv s t = - let s = match s with C.Meta _ -> lookup s subst | _ -> s - and t = match t with C.Meta _ -> lookup t subst | _ -> t - in - match s, t with - | s, t when s = t -> subst, menv - | C.Meta (i, _), C.Meta (j, _) when i > j -> - unif subst menv t s - | C.Meta _, t when occurs_check subst s t -> - raise - (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Meta (i, l), t -> ( - try - let _, _, ty = CicUtil.lookup_meta i menv in - let subst = - if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst - else subst - in - let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *) - subst, menv - with CicUtil.Meta_not_found m -> - let names = names_of_context context in - debug_print - (lazy - (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m - (CicPp.pp t1 names) (CicPp.pp t2 names) - (print_metasenv menv) (print_metasenv metasenv))); - assert false - ) - | _, C.Meta _ -> unif subst menv t s - | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt -> - raise (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Appl (hds::tls), C.Appl (hdt::tlt) -> ( - try - List.fold_left2 - (fun (subst', menv) s t -> unif subst' menv s t) - (subst, menv) tls tlt - with Invalid_argument _ -> - raise (U.UnificationFailure (lazy "Inference.unification.unif")) - ) - | _, _ -> - raise (U.UnificationFailure (lazy "Inference.unification.unif")) - in - let subst, menv = unif [] metasenv t1 t2 in - let menv = - List.filter - (fun (m, _, _) -> - try let _ = List.find (fun (i, _) -> m = i) subst in false - with Not_found -> true) - menv - in - List.rev subst, menv, ugraph -;; - - -let unification metasenv context t1 t2 ugraph = - let subst, menv, ug = - if not (is_simple_term t1) || not (is_simple_term t2) then ( - debug_print - (lazy - (Printf.sprintf "NOT SIMPLE TERMS: %s %s" - (CicPp.ppterm t1) (CicPp.ppterm t2))); - CicUnification.fo_unif metasenv context t1 t2 ugraph - ) else - unification_simple metasenv context t1 t2 ugraph - in - let rec fix_term = function - | (Cic.Meta (i, l) as t) -> - let t' = lookup_subst t subst in - if t <> t' then fix_term t' else t - | Cic.Appl l -> Cic.Appl (List.map fix_term l) - | t -> t - in - let rec fix_subst = function - | [] -> [] - | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl) - in - fix_subst subst, menv, ug -;; - - -let unification = CicUnification.fo_unif;; - -exception MatchingFailure;; - - -(* -let matching_simple metasenv context t1 t2 ugraph = - let module C = Cic in - let module M = CicMetaSubst in - let module U = CicUnification in - let lookup meta subst = - match meta with - | C.Meta (i, _) -> ( - try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t - with Not_found -> meta - ) - | _ -> assert false - in - let rec do_match subst menv s t = - match s, t with - | s, t when s = t -> subst, menv - | s, C.Meta (i, l) -> - let filter_menv i menv = - List.filter (fun (m, _, _) -> i <> m) menv - in - let subst, menv = - let value = lookup t subst in - match value with - | value when value = t -> - let _, _, ty = CicUtil.lookup_meta i menv in - (i, (context, s, ty))::subst, filter_menv i menv - | value when value <> s -> - raise MatchingFailure - | value -> do_match subst menv s value - in - subst, menv - | C.Appl ls, C.Appl lt -> ( - try - List.fold_left2 - (fun (subst, menv) s t -> do_match subst menv s t) - (subst, menv) ls lt - with Invalid_argument _ -> - raise MatchingFailure - ) - | _, _ -> - raise MatchingFailure - in - let subst, menv = do_match [] metasenv t1 t2 in - subst, menv, ugraph -;; -*) - - -let matching metasenv context t1 t2 ugraph = - try - let subst, metasenv, ugraph = -try - unification metasenv context t1 t2 ugraph -with CicUtil.Meta_not_found _ as exn -> - Printf.eprintf "t1 == %s\nt2 = %s\nmetasenv == %s\n%!" - (CicPp.ppterm t1) (CicPp.ppterm t2) (CicMetaSubst.ppmetasenv [] metasenv); - raise exn - in - let t' = CicMetaSubst.apply_subst subst t1 in - if not (meta_convertibility t1 t') then - raise MatchingFailure - else - let metas = metas_of_term t1 in - let fix_subst = function - | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas -> - (j, (c, Cic.Meta (i, lc), ty)) - | s -> s - in - let subst = List.map fix_subst subst in - subst, metasenv, ugraph - with - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - raise MatchingFailure -;; - - -let find_equalities context proof = - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let eq_uri = LibraryObjects.eq_URI () in - let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in - let ok_types ty menv = - List.for_all (fun (_, _, mt) -> mt = ty) menv - in - let rec aux index newmeta = function - | [] -> [], newmeta - | (Some (_, C.Decl (term)))::tl -> - let do_find context term = - match term with - | C.Prod (name, s, t) -> - let (head, newmetas, args, newmeta) = - ProofEngineHelpers.saturate_term newmeta [] - context (S.lift index term) 0 - in - let p = - if List.length args = 0 then - C.Rel index - else - C.Appl ((C.Rel index)::args) - in ( - match head with - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) -> - debug_print - (lazy - (Printf.sprintf "OK: %s" (CicPp.ppterm term))); - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let proof = BasicProof p in - let e = (w, proof, (ty, t1, t2, o), newmetas, args) in - Some e, (newmeta+1) - | _ -> None, newmeta - ) - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when UriManager.eq uri eq_uri -> - let t1 = S.lift index t1 - and t2 = S.lift index t2 in - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in - Some e, (newmeta+1) - | _ -> None, newmeta - in ( - match do_find context term with - | Some p, newmeta -> - let tl, newmeta' = (aux (index+1) newmeta tl) in - if newmeta' < newmeta then - prerr_endline "big trouble"; - (index, p)::tl, newmeta' (* max???? *) - | None, _ -> - aux (index+1) newmeta tl - ) - | _::tl -> - aux (index+1) newmeta tl - in - let il, maxm = aux 1 newmeta context in - let indexes, equalities = List.split il in - indexes, equalities, maxm -;; - - -(* -let equations_blacklist = - List.fold_left - (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s) - UriManager.UriSet.empty [ - "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; - "cic:/Coq/Init/Logic/trans_eq.con"; - "cic:/Coq/Init/Logic/f_equal.con"; - "cic:/Coq/Init/Logic/f_equal2.con"; - "cic:/Coq/Init/Logic/f_equal3.con"; - "cic:/Coq/Init/Logic/f_equal4.con"; - "cic:/Coq/Init/Logic/f_equal5.con"; - "cic:/Coq/Init/Logic/sym_eq.con"; - "cic:/Coq/Init/Logic/eq_ind.con"; - "cic:/Coq/Init/Logic/eq_ind_r.con"; - "cic:/Coq/Init/Logic/eq_rec.con"; - "cic:/Coq/Init/Logic/eq_rec_r.con"; - "cic:/Coq/Init/Logic/eq_rect.con"; - "cic:/Coq/Init/Logic/eq_rect_r.con"; - "cic:/Coq/Logic/Eqdep/UIP.con"; - "cic:/Coq/Logic/Eqdep/UIP_refl.con"; - "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"; - "cic:/Coq/ZArith/Zcompare/rename.con"; - (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`... - perche' questo cacchio di teorema rompe le scatole :'( *) - "cic:/Rocq/SUBST/comparith/mult_n_2.con"; - - "cic:/matita/logic/equality/eq_f.con"; - "cic:/matita/logic/equality/eq_f2.con"; - "cic:/matita/logic/equality/eq_rec.con"; - "cic:/matita/logic/equality/eq_rect.con"; - ] -;; -*) -let equations_blacklist = UriManager.UriSet.empty;; - - -let find_library_equalities dbd context status maxmeta = - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let blacklist = - List.fold_left - (fun s u -> UriManager.UriSet.add u s) - equations_blacklist - [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); - eq_ind_r_URI ()] - in - let candidates = - List.fold_left - (fun l uri -> - if UriManager.UriSet.mem uri blacklist then - l - else - let t = CicUtil.term_of_uri uri in - let ty, _ = - CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph - in - (uri, t, ty)::l) - [] - (let t1 = Unix.gettimeofday () in - let eqs = (MetadataQuery.equations_for_goal ~dbd status) in - let t2 = Unix.gettimeofday () in - (debug_print - (lazy - (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n" - (t2 -. t1)))); - eqs) - in - let eq_uri1 = eq_XURI () - and eq_uri2 = LibraryObjects.eq_URI () in - let iseq uri = - (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2) - in - let ok_types ty menv = - List.for_all (fun (_, _, mt) -> mt = ty) menv - in - let rec has_vars = function - | C.Meta _ | C.Rel _ | C.Const _ -> false - | C.Var _ -> true - | C.Appl l -> List.exists has_vars l - | C.Prod (_, s, t) | C.Lambda (_, s, t) - | C.LetIn (_, s, t) | C.Cast (s, t) -> - (has_vars s) || (has_vars t) - | _ -> false - in - let rec aux newmeta = function - | [] -> [], newmeta - | (uri, term, termty)::tl -> - debug_print - (lazy - (Printf.sprintf "Examining: %s (%s)" - (CicPp.ppterm term) (CicPp.ppterm termty))); - let res, newmeta = - match termty with - | C.Prod (name, s, t) when not (has_vars termty) -> - let head, newmetas, args, newmeta = - ProofEngineHelpers.saturate_term newmeta [] context termty 0 - in - let p = - if List.length args = 0 then - term - else - C.Appl (term::args) - in ( - match head with - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when (iseq uri) && (ok_types ty newmetas) -> - debug_print - (lazy - (Printf.sprintf "OK: %s" (CicPp.ppterm term))); - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let proof = BasicProof p in - let e = (w, proof, (ty, t1, t2, o), newmetas, args) in - Some e, (newmeta+1) - | _ -> None, newmeta - ) - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when iseq uri && not (has_vars termty) -> - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in - Some e, (newmeta+1) - | _ -> None, newmeta - in - match res with - | Some e -> - let tl, newmeta' = aux newmeta tl in - if newmeta' < newmeta then - prerr_endline "big trouble"; - (uri, e)::tl, newmeta' (* max???? *) - | None -> - aux newmeta tl - in - let found, maxm = aux maxmeta candidates in - let uriset, eqlist = - (List.fold_left - (fun (s, l) (u, e) -> - if List.exists (meta_convertibility_eq e) (List.map snd l) then ( - debug_print - (lazy - (Printf.sprintf "NO!! %s already there!" - (string_of_equality e))); - (UriManager.UriSet.add u s, l) - ) else (UriManager.UriSet.add u s, (u, e)::l)) - (UriManager.UriSet.empty, []) found) - in - uriset, eqlist, maxm -;; - - -let find_library_theorems dbd env status equalities_uris = - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let blacklist = - let refl_equal = - UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in - let s = - UriManager.UriSet.remove refl_equal - (UriManager.UriSet.union equalities_uris equations_blacklist) - in - List.fold_left - (fun s u -> UriManager.UriSet.add u s) - s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); - eq_ind_r_URI ()] - in - let metasenv, context, ugraph = env in - let candidates = - List.fold_left - (fun l uri -> - if UriManager.UriSet.mem uri blacklist then l - else - let t = CicUtil.term_of_uri uri in - let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in - (t, ty, [])::l) - [] (MetadataQuery.signature_of_goal ~dbd status) - in - let refl_equal = - let u = eq_XURI () in - let t = CicUtil.term_of_uri u in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - (t, ty, []) - in - refl_equal::candidates -;; - - -let find_context_hypotheses env equalities_indexes = - let metasenv, context, ugraph = env in - let _, res = - List.fold_left - (fun (n, l) entry -> - match entry with - | None -> (n+1, l) - | Some _ -> - if List.mem n equalities_indexes then - (n+1, l) - else - let t = Cic.Rel n in - let ty, _ = - CicTypeChecker.type_of_aux' metasenv context t ugraph in - (n+1, (t, ty, [])::l)) - (1, []) context - in - res -;; - - -let fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) = - let table = Hashtbl.create (List.length args) in - - let newargs, newmeta = - List.fold_right - (fun t (newargs, index) -> - match t with - | Cic.Meta (i, l) -> - if Hashtbl.mem table i then - let idx = Hashtbl.find table i in - ((Cic.Meta (idx, l))::newargs, index+1) - else - let _ = Hashtbl.add table i index in - ((Cic.Meta (index, l))::newargs, index+1) - | _ -> assert false) - args ([], newmeta+1) - in - - let repl where = - ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs - ~where - in - let menv' = - List.fold_right - (fun (i, context, term) menv -> - try - let index = Hashtbl.find table i in - (index, context, term)::menv - with Not_found -> - (i, context, term)::menv) - menv [] - in - let ty = repl ty - and left = repl left - and right = repl right in - let metas = (metas_of_term left) @ (metas_of_term right) @ (metas_of_term ty) in - let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in - let newargs = - List.filter - (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs - in - let _ = - if List.length metas > 0 then - let first = List.hd metas in - (* this new equality might have less variables than its parents: here - we fill the gap with a dummy arg. Example: - with (f X Y) = X we can simplify - (g X) = (f X Y) in - (g X) = X. - So the new equation has only one variable, but it still has type like - \lambda X,Y:..., so we need to pass a dummy arg for Y - (I hope this makes some sense...) - *) - Hashtbl.iter - (fun k v -> - if not (List.exists - (function Cic.Meta (i, _) -> i = v | _ -> assert false) - newargs) then - Hashtbl.replace table k first) - (Hashtbl.copy table) - in - let rec fix_proof = function - | NoProof -> NoProof - | BasicProof term -> BasicProof (repl term) - | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) -> - let subst' = - List.fold_left - (fun s arg -> - match arg with - | Cic.Meta (i, l) -> ( - try - let j = Hashtbl.find table i in - if List.mem_assoc i subst then - s - else - let _, context, ty = CicUtil.lookup_meta i menv in - (i, (context, Cic.Meta (j, l), ty))::s - with Not_found | CicUtil.Meta_not_found _ -> - s - ) - | _ -> assert false) - [] args - in - ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p) - | p -> assert false - in - let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in - (newmeta +1, neweq) -;; - - -let relocate newmeta menv = - let subst, metasenv, newmeta = - List.fold_right - (fun (i, context, ty) (subst, menv, maxmeta) -> - let irl=CicMkImplicit.identity_relocation_list_for_metavariable context in - let newsubst = (i, (context, (Cic.Meta (maxmeta, irl)), ty)) in - let newmeta = maxmeta, context, ty in - newsubst::subst, newmeta::menv, maxmeta+1) - menv ([], [], newmeta+1) - in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let subst = - List.map - (fun (i, (context, term, ty)) -> - let context = CicMetaSubst.apply_subst_context subst context in - let term = CicMetaSubst.apply_subst subst term in - let ty = CicMetaSubst.apply_subst subst ty in - (i, (context, term, ty))) subst in - subst, metasenv, newmeta - - -let fix_metas newmeta (w, p, (ty, left, right, o), menv, args) = - (* debug - let _ , eq = - fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) in - prerr_endline (string_of_equality eq); *) - let subst, metasenv, newmeta = relocate newmeta menv in - let ty = CicMetaSubst.apply_subst subst ty in - let left = CicMetaSubst.apply_subst subst left in - let right = CicMetaSubst.apply_subst subst right in - let args = List.map (CicMetaSubst.apply_subst subst) args in - let rec fix_proof = function - | NoProof -> NoProof - | BasicProof term -> BasicProof (CicMetaSubst.apply_subst subst term) - | ProofBlock (subst', eq_URI, namety, bo, (pos, eq), p) -> - ProofBlock (subst' @ subst, eq_URI, namety, bo, (pos, eq), p) - | p -> assert false - in - let metas = (metas_of_term left)@(metas_of_term right)@(metas_of_term ty) in - let metasenv = List.filter (fun (i, _, _) -> List.mem i metas) metasenv in - let eq = (w, fix_proof p, (ty, left, right, o), metasenv, args) in - (* debug prerr_endline (string_of_equality eq); *) - newmeta, eq - -let term_is_equality term = - let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in - match term with - | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true - | _ -> false -;; - - -exception TermIsNotAnEquality;; - -let equality_of_term proof term = - let eq_uri = LibraryObjects.eq_URI () in - let iseq uri = UriManager.eq uri eq_uri in - match term with - | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri -> - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in - e - | _ -> - raise TermIsNotAnEquality -;; - - -type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;; - -let is_weak_identity (metasenv, context, ugraph) = function - | (_, _, (ty, left, right, _), menv, _) -> - (left = right || - (meta_convertibility left right)) - (* the test below is not a good idea since it stops - demodulation too early *) - (* (fst (CicReduction.are_convertible - ~metasenv:(metasenv @ menv) context left right ugraph)))*) -;; - -let is_identity (metasenv, context, ugraph) = function - | (_, _, (ty, left, right, _), menv, _) -> - (left = right || - (* (meta_convertibility left right)) *) - (fst (CicReduction.are_convertible - ~metasenv:(metasenv @ menv) context left right ugraph))) -;; - - -let term_of_equality equality = - let _, _, (ty, left, right, _), menv, args = equality in - let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in - let argsno = List.length args in - let t = - CicSubstitution.lift argsno - (Cic.Appl [Cic.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right]) - in - snd ( - List.fold_right - (fun a (n, t) -> - match a with - | Cic.Meta (i, _) -> - let name = Cic.Name ("X" ^ (string_of_int n)) in - let _, _, ty = CicUtil.lookup_meta i menv in - let t = - ProofEngineReduction.replace - ~equality:eq ~what:[i] - ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t - in - (n-1, Cic.Prod (name, ty, t)) - | _ -> assert false) - args (argsno, t)) -;; diff --git a/helm/ocaml/tactics/paramodulation/inference.mli b/helm/ocaml/tactics/paramodulation/inference.mli deleted file mode 100644 index b31d8bacf..000000000 --- a/helm/ocaml/tactics/paramodulation/inference.mli +++ /dev/null @@ -1,134 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -type equality = - int * (* weight *) - proof * (* proof *) - (Cic.term * (* type *) - Cic.term * (* left side *) - Cic.term * (* right side *) - Utils.comparison) * (* ordering *) - Cic.metasenv * (* environment for metas *) - Cic.term list (* arguments *) - -and proof = - | NoProof (* no proof *) - | BasicProof of Cic.term (* already a proof of a goal *) - | ProofBlock of (* proof of a rewrite step *) - Cic.substitution * UriManager.uri * (* eq_ind or eq_ind_r *) - (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof - | ProofGoalBlock of proof * proof - (* proof of the new meta, proof of the goal from which this comes *) - | ProofSymBlock of Cic.term list * proof (* expl.named subst, proof *) - | SubProof of Cic.term * int * proof - (* parent proof, subgoal, proof of the subgoal *) - -type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph - -(** builds the Cic.term encoded by proof *) -val build_proof_term: ?noproof:Cic.term -> proof -> Cic.term - -val string_of_proof: proof -> string - -exception MatchingFailure - -(** matching between two terms. Can raise MatchingFailure *) -val matching: - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> - CicUniv.universe_graph -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph - -(** - special unification that checks if the two terms are "simple", and in - such case should be significantly faster than CicUnification.fo_unif -*) -val unification: - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> - CicUniv.universe_graph -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph - - -(** - scans the context to find all Declarations "left = right"; returns a - list of tuples (proof, (type, left, right), newmetas). Uses - PrimitiveTactics.new_metasenv_for_apply to replace bound variables with - fresh metas... -*) -val find_equalities: - Cic.context -> ProofEngineTypes.proof -> int list * equality list * int - -(** - searches the library for equalities that can be applied to the current goal -*) -val find_library_equalities: - HMysql.dbd -> Cic.context -> ProofEngineTypes.status -> int -> - UriManager.UriSet.t * (UriManager.uri * equality) list * int - -(** - searches the library for theorems that are not equalities (returned by the - function above) -*) -val find_library_theorems: - HMysql.dbd -> environment -> ProofEngineTypes.status -> UriManager.UriSet.t -> - (Cic.term * Cic.term * Cic.metasenv) list - -(** - searches the context for hypotheses that are not equalities -*) -val find_context_hypotheses: - environment -> int list -> (Cic.term * Cic.term * Cic.metasenv) list - - -exception TermIsNotAnEquality;; - -(** - raises TermIsNotAnEquality if term is not an equation. - The first Cic.term is a proof of the equation -*) -val equality_of_term: Cic.term -> Cic.term -> equality - -(** - Re-builds the term corresponding to this equality -*) -val term_of_equality: equality -> Cic.term - -val term_is_equality: Cic.term -> bool - -(** tests a sort of alpha-convertibility between the two terms, but on the - metavariables *) -val meta_convertibility: Cic.term -> Cic.term -> bool - -(** meta convertibility between two equations *) -val meta_convertibility_eq: equality -> equality -> bool - -val is_weak_identity: environment -> equality -> bool -val is_identity: environment -> equality -> bool - -val string_of_equality: ?env:environment -> equality -> string - -val metas_of_term: Cic.term -> int list - -(** ensures that metavariables in equality are unique *) -val fix_metas: int -> equality -> int * equality diff --git a/helm/ocaml/tactics/paramodulation/saturate_main.ml b/helm/ocaml/tactics/paramodulation/saturate_main.ml deleted file mode 100644 index efcfca4ed..000000000 --- a/helm/ocaml/tactics/paramodulation/saturate_main.ml +++ /dev/null @@ -1,166 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -module Trivial_disambiguate: -sig - exception Ambiguous_term of string Lazy.t - (** disambiguate an _unanmbiguous_ term using dummy callbacks which fail if a - * choice from the user is needed to disambiguate the term - * @raise Ambiguous_term for ambiguous term *) - val disambiguate_string: - dbd:HMysql.dbd -> - ?context:Cic.context -> - ?metasenv:Cic.metasenv -> - ?initial_ugraph:CicUniv.universe_graph -> - ?aliases:DisambiguateTypes.environment ->(* previous interpretation status*) - string -> - ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * - Cic.metasenv * (* new metasenv *) - Cic.term * - CicUniv.universe_graph) list (* disambiguated term *) -end -= -struct - exception Ambiguous_term of string Lazy.t - exception Exit - module Callbacks = - struct - let non p x = not (p x) - let interactive_user_uri_choice ~selection_mode ?ok - ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = - List.filter (non UriManager.uri_is_var) uris - let interactive_interpretation_choice interp = raise Exit - let input_or_locate_uri ~(title:string) ?id = raise Exit - end - module Disambiguator = Disambiguate.Make (Callbacks) - let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph - ?(aliases = DisambiguateTypes.Environment.empty) term - = - let ast = - CicNotationParser.parse_level2_ast (Ulexing.from_utf8_string term) - in - try - fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast - ?initial_ugraph ~aliases ~universe:None) - with Exit -> raise (Ambiguous_term (lazy term)) -end - -let configuration_file = ref "../../../matita/matita.conf.xml";; - -let core_notation_script = "../../../matita/core_notation.moo";; - -let get_from_user ~(dbd:HMysql.dbd) = - let rec get () = - match read_line () with - | "" -> [] - | t -> t::(get ()) - in - let term_string = String.concat "\n" (get ()) in - let env, metasenv, term, ugraph = - List.nth (Trivial_disambiguate.disambiguate_string dbd term_string) 0 - in - term, metasenv, ugraph -;; - -let full = ref false;; - -let retrieve_only = ref false;; - -let demod_equalities = ref false;; - -let main () = - let module S = Saturation in - let set_ratio v = S.weight_age_ratio := v; S.weight_age_counter := v - and set_sel v = S.symbols_ratio := v; S.symbols_counter := v; - and set_conf f = configuration_file := f - and set_ordering o = - match o with - | "lpo" -> Utils.compare_terms := Utils.lpo - | "kbo" -> Utils.compare_terms := Utils.kbo - | "nr-kbo" -> Utils.compare_terms := Utils.nonrec_kbo - | "ao" -> Utils.compare_terms := Utils.ao - | o -> raise (Arg.Bad ("Unknown term ordering: " ^ o)) - and set_fullred b = S.use_fullred := b - and set_time_limit v = S.time_limit := float_of_int v - and set_width w = S.maxwidth := w - and set_depth d = S.maxdepth := d - and set_full () = full := true - and set_retrieve () = retrieve_only := true - and set_demod_equalities () = demod_equalities := true - in - Arg.parse [ - "-full", Arg.Unit set_full, "Enable full mode"; - "-f", Arg.Bool set_fullred, - "Enable/disable full-reduction strategy (default: enabled)"; - - "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 4)"; - - "-s", Arg.Int set_sel, - "symbols-based selection ratio (relative to the weight ratio, default: 0)"; - - "-c", Arg.String set_conf, "Configuration file (for the db connection)"; - - "-o", Arg.String set_ordering, - "Term ordering. Possible values are:\n" ^ - "\tkbo: Knuth-Bendix ordering\n" ^ - "\tnr-kbo: Non-recursive variant of kbo (default)\n" ^ - "\tlpo: Lexicographic path ordering"; - - "-l", Arg.Int set_time_limit, "Time limit in seconds (default: no limit)"; - - "-w", Arg.Int set_width, - Printf.sprintf "Maximal width (default: %d)" !Saturation.maxwidth; - - "-d", Arg.Int set_depth, - Printf.sprintf "Maximal depth (default: %d)" !Saturation.maxdepth; - - "-retrieve", Arg.Unit set_retrieve, "retrieve only"; - "-demod-equalities", Arg.Unit set_demod_equalities, "demod equalities"; - ] (fun a -> ()) "Usage:"; - Helm_registry.load_from !configuration_file; - ignore (CicNotation2.load_notation [] core_notation_script); - ignore (CicNotation2.load_notation [] "../../../matita/library/legacy/coq.ma"); - let dbd = HMysql.quick_connect - ~host:(Helm_registry.get "db.host") - ~user:(Helm_registry.get "db.user") - ~database:(Helm_registry.get "db.database") - () - in - let term, metasenv, ugraph = get_from_user ~dbd in - if !retrieve_only then - Saturation.retrieve_and_print dbd term metasenv ugraph - else if !demod_equalities then - Saturation.main_demod_equalities dbd term metasenv ugraph - else - Saturation.main dbd !full term metasenv ugraph -;; - -let _ = - (*try*) - main () - (*with exn -> prerr_endline (Printexc.to_string exn)*) - diff --git a/helm/ocaml/tactics/paramodulation/saturation.ml b/helm/ocaml/tactics/paramodulation/saturation.ml deleted file mode 100644 index 6a700d868..000000000 --- a/helm/ocaml/tactics/paramodulation/saturation.ml +++ /dev/null @@ -1,2366 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -open Inference;; -open Utils;; - -(* -for debugging -let check_equation env equation msg = - let w, proof, (eq_ty, left, right, order), metas, args = equation in - let metasenv, context, ugraph = env in - let metasenv' = metasenv @ metas in - try - CicTypeChecker.type_of_aux' metasenv' context left ugraph; - CicTypeChecker.type_of_aux' metasenv' context right ugraph; - () - with - CicUtil.Meta_not_found _ as exn -> - begin - prerr_endline msg; - prerr_endline (CicPp.ppterm left); - prerr_endline (CicPp.ppterm right); - raise exn - end -*) - -(* set to false to disable paramodulation inside auto_tac *) -let connect_to_auto = true;; - - -(* profiling statistics... *) -let infer_time = ref 0.;; -let forward_simpl_time = ref 0.;; -let forward_simpl_new_time = ref 0.;; -let backward_simpl_time = ref 0.;; -let passive_maintainance_time = ref 0.;; - -(* limited-resource-strategy related globals *) -let processed_clauses = ref 0;; (* number of equalities selected so far... *) -let time_limit = ref 0.;; (* in seconds, settable by the user... *) -let start_time = ref 0.;; (* time at which the execution started *) -let elapsed_time = ref 0.;; -(* let maximal_weight = ref None;; *) -let maximal_retained_equality = ref None;; - -(* equality-selection related globals *) -let use_fullred = ref true;; -let weight_age_ratio = ref (* 5 *) 4;; (* settable by the user *) -let weight_age_counter = ref !weight_age_ratio;; -let symbols_ratio = ref (* 0 *) 3;; -let symbols_counter = ref 0;; - -(* non-recursive Knuth-Bendix term ordering by default *) -(* Utils.compare_terms := Utils.rpo;; *) -(* Utils.compare_terms := Utils.nonrec_kbo;; *) -(* Utils.compare_terms := Utils.ao;; *) - -(* statistics... *) -let derived_clauses = ref 0;; -let kept_clauses = ref 0;; - -(* index of the greatest Cic.Meta created - TODO: find a better way! *) -let maxmeta = ref 0;; - -(* varbiables controlling the search-space *) -let maxdepth = ref 3;; -let maxwidth = ref 3;; - - -type result = - | ParamodulationFailure - | ParamodulationSuccess of Inference.proof option * environment -;; - -type goal = proof * Cic.metasenv * Cic.term;; - -type theorem = Cic.term * Cic.term * Cic.metasenv;; - -let symbols_of_equality (_, _, (_, left, right, _), _, _) = - let m1 = symbols_of_term left in - let m = - TermMap.fold - (fun k v res -> - try - let c = TermMap.find k res in - TermMap.add k (c+v) res - with Not_found -> - TermMap.add k v res) - (symbols_of_term right) m1 - in - m -;; - -module OrderedEquality = struct - type t = Inference.equality - - let compare eq1 eq2 = - match meta_convertibility_eq eq1 eq2 with - | true -> 0 - | false -> - let w1, _, (ty, left, right, _), _, a = eq1 - and w2, _, (ty', left', right', _), _, a' = eq2 in - match Pervasives.compare w1 w2 with - | 0 -> - let res = (List.length a) - (List.length a') in - if res <> 0 then res else ( - try - let res = Pervasives.compare (List.hd a) (List.hd a') in - if res <> 0 then res else Pervasives.compare eq1 eq2 - with Failure "hd" -> Pervasives.compare eq1 eq2 - ) - | res -> res -end - -module EqualitySet = Set.Make(OrderedEquality);; - - -(** - selects one equality from passive. The selection strategy is a combination - of weight, age and goal-similarity -*) -let select env goals passive (active, _) = - processed_clauses := !processed_clauses + 1; - let goal = - match (List.rev goals) with (_, goal::_)::_ -> goal | _ -> assert false - in - let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in - let remove eq l = - List.filter (fun e -> e <> eq) l - in - if !weight_age_ratio > 0 then - weight_age_counter := !weight_age_counter - 1; - match !weight_age_counter with - | 0 -> ( - weight_age_counter := !weight_age_ratio; - match neg_list, pos_list with - | hd::tl, pos -> - (* Negatives aren't indexed, no need to remove them... *) - (Negative, hd), - ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table) - | [], (hd:EqualitySet.elt)::tl -> - let passive_table = - Indexing.remove_index passive_table hd - in - (Positive, hd), - (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table) - | _, _ -> assert false - ) - | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> ( - symbols_counter := !symbols_counter - 1; - let cardinality map = - TermMap.fold (fun k v res -> res + v) map 0 - in - let symbols = - let _, _, term = goal in - symbols_of_term term - in - let card = cardinality symbols in - let foldfun k v (r1, r2) = - if TermMap.mem k symbols then - let c = TermMap.find k symbols in - let c1 = abs (c - v) in - let c2 = v - c1 in - r1 + c2, r2 + c1 - else - r1, r2 + v - in - let f equality (i, e) = - let common, others = - TermMap.fold foldfun (symbols_of_equality equality) (0, 0) - in - let c = others + (abs (common - card)) in - if c < i then (c, equality) - else (i, e) - in - let e1 = EqualitySet.min_elt pos_set in - let initial = - let common, others = - TermMap.fold foldfun (symbols_of_equality e1) (0, 0) - in - (others + (abs (common - card))), e1 - in - let _, current = EqualitySet.fold f pos_set initial in - let passive_table = - Indexing.remove_index passive_table current - in - (Positive, current), - (([], neg_set), - (remove current pos_list, EqualitySet.remove current pos_set), - passive_table) - ) - | _ -> - symbols_counter := !symbols_ratio; - let set_selection set = EqualitySet.min_elt set in - if EqualitySet.is_empty neg_set then - let current = set_selection pos_set in - let passive = - (neg_list, neg_set), - (remove current pos_list, EqualitySet.remove current pos_set), - Indexing.remove_index passive_table current - in - (Positive, current), passive - else - let current = set_selection neg_set in - let passive = - (remove current neg_list, EqualitySet.remove current neg_set), - (pos_list, pos_set), - passive_table - in - (Negative, current), passive -;; - - -(* initializes the passive set of equalities *) -let make_passive neg pos = - let set_of equalities = - List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities - in - let table = - List.fold_left (fun tbl e -> Indexing.index tbl e) Indexing.empty pos - in - (neg, set_of neg), - (pos, set_of pos), - table -;; - - -let make_active () = - [], Indexing.empty -;; - - -(* adds to passive a list of equalities: new_neg is a list of negative - equalities, new_pos a list of positive equalities *) -let add_to_passive passive (new_neg, new_pos) = - let (neg_list, neg_set), (pos_list, pos_set), table = passive in - let ok set equality = not (EqualitySet.mem equality set) in - let neg = List.filter (ok neg_set) new_neg - and pos = List.filter (ok pos_set) new_pos in - let table = - List.fold_left (fun tbl e -> Indexing.index tbl e) table pos - in - let add set equalities = - List.fold_left (fun s e -> EqualitySet.add e s) set equalities - in - (neg @ neg_list, add neg_set neg), - (pos_list @ pos, add pos_set pos), - table -;; - - -let passive_is_empty = function - | ([], _), ([], _), _ -> true - | _ -> false -;; - - -let size_of_passive ((_, ns), (_, ps), _) = - (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps) -;; - - -let size_of_active (active_list, _) = - List.length active_list -;; - - -(* removes from passive equalities that are estimated impossible to activate - within the current time limit *) -let prune_passive howmany (active, _) passive = - let (nl, ns), (pl, ps), tbl = passive in - let howmany = float_of_int howmany - and ratio = float_of_int !weight_age_ratio in - let round v = - let t = ceil v in - int_of_float (if t -. v < 0.5 then t else v) - in - let in_weight = round (howmany *. ratio /. (ratio +. 1.)) - and in_age = round (howmany /. (ratio +. 1.)) in - debug_print - (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age)); - let symbols, card = - match active with - | (Negative, e)::_ -> - let symbols = symbols_of_equality e in - let card = TermMap.fold (fun k v res -> res + v) symbols 0 in - Some symbols, card - | _ -> None, 0 - in - let counter = ref !symbols_ratio in - let rec pickw w ns ps = - if w > 0 then - if not (EqualitySet.is_empty ns) then - let e = EqualitySet.min_elt ns in - let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in - EqualitySet.add e ns', ps - else if !counter > 0 then - let _ = - counter := !counter - 1; - if !counter = 0 then counter := !symbols_ratio - in - match symbols with - | None -> - let e = EqualitySet.min_elt ps in - let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in - ns, EqualitySet.add e ps' - | Some symbols -> - let foldfun k v (r1, r2) = - if TermMap.mem k symbols then - let c = TermMap.find k symbols in - let c1 = abs (c - v) in - let c2 = v - c1 in - r1 + c2, r2 + c1 - else - r1, r2 + v - in - let f equality (i, e) = - let common, others = - TermMap.fold foldfun (symbols_of_equality equality) (0, 0) - in - let c = others + (abs (common - card)) in - if c < i then (c, equality) - else (i, e) - in - let e1 = EqualitySet.min_elt ps in - let initial = - let common, others = - TermMap.fold foldfun (symbols_of_equality e1) (0, 0) - in - (others + (abs (common - card))), e1 - in - let _, e = EqualitySet.fold f ps initial in - let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in - ns, EqualitySet.add e ps' - else - let e = EqualitySet.min_elt ps in - let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in - ns, EqualitySet.add e ps' - else - EqualitySet.empty, EqualitySet.empty - in - let ns, ps = pickw in_weight ns ps in - let rec picka w s l = - if w > 0 then - match l with - | [] -> w, s, [] - | hd::tl when not (EqualitySet.mem hd s) -> - let w, s, l = picka (w-1) s tl in - w, EqualitySet.add hd s, hd::l - | hd::tl -> - let w, s, l = picka w s tl in - w, s, hd::l - else - 0, s, l - in - let in_age, ns, nl = picka in_age ns nl in - let _, ps, pl = picka in_age ps pl in - if not (EqualitySet.is_empty ps) then - maximal_retained_equality := Some (EqualitySet.max_elt ps); - let tbl = - EqualitySet.fold - (fun e tbl -> Indexing.index tbl e) ps Indexing.empty - in - (nl, ns), (pl, ps), tbl -;; - - -(** inference of new equalities between current and some in active *) -let infer env sign current (active_list, active_table) = - let new_neg, new_pos = - match sign with - | Negative -> - let maxm, res = - Indexing.superposition_left !maxmeta env active_table current in - maxmeta := maxm; - res, [] - | Positive -> - let maxm, res = - Indexing.superposition_right !maxmeta env active_table current in - maxmeta := maxm; - let rec infer_positive table = function - | [] -> [], [] - | (Negative, equality)::tl -> - let maxm, res = - Indexing.superposition_left !maxmeta env table equality in - maxmeta := maxm; - let neg, pos = infer_positive table tl in - res @ neg, pos - | (Positive, equality)::tl -> - let maxm, res = - Indexing.superposition_right !maxmeta env table equality in - maxmeta := maxm; - let neg, pos = infer_positive table tl in - neg, res @ pos - in - let curr_table = Indexing.index Indexing.empty current in - let neg, pos = infer_positive curr_table active_list in - neg, res @ pos - in - derived_clauses := !derived_clauses + (List.length new_neg) + - (List.length new_pos); - match !maximal_retained_equality with - | None -> new_neg, new_pos - | Some eq -> - (* if we have a maximal_retained_equality, we can discard all equalities - "greater" than it, as they will never be reached... An equality is - greater than maximal_retained_equality if it is bigger - wrt. OrderedEquality.compare and it is less similar than - maximal_retained_equality to the current goal *) - let symbols, card = - match active_list with - | (Negative, e)::_ -> - let symbols = symbols_of_equality e in - let card = TermMap.fold (fun k v res -> res + v) symbols 0 in - Some symbols, card - | _ -> None, 0 - in - let new_pos = - match symbols with - | None -> - List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos - | Some symbols -> - let filterfun e = - if OrderedEquality.compare e eq <= 0 then - true - else - let foldfun k v (r1, r2) = - if TermMap.mem k symbols then - let c = TermMap.find k symbols in - let c1 = abs (c - v) in - let c2 = v - c1 in - r1 + c2, r2 + c1 - else - r1, r2 + v - in - let initial = - let common, others = - TermMap.fold foldfun (symbols_of_equality eq) (0, 0) in - others + (abs (common - card)) - in - let common, others = - TermMap.fold foldfun (symbols_of_equality e) (0, 0) in - let c = others + (abs (common - card)) in - if c < initial then true else false - in - List.filter filterfun new_pos - in - new_neg, new_pos -;; - - -let contains_empty env (negative, positive) = - let metasenv, context, ugraph = env in - try - let found = - List.find - (fun (w, proof, (ty, left, right, ordering), m, a) -> - fst (CicReduction.are_convertible context left right ugraph)) - negative - in - true, Some found - with Not_found -> - false, None -;; - - -(** simplifies current using active and passive *) -let forward_simplify env (sign, current) ?passive (active_list, active_table) = - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - let all = if pl = [] then active_list else active_list @ pl in - - let demodulate table current = - let newmeta, newcurrent = - Indexing.demodulation_equality !maxmeta env table sign current in - maxmeta := newmeta; - if is_identity env newcurrent then - if sign = Negative then Some (sign, newcurrent) - else ( -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "\ncurrent was: %s\nnewcurrent is: %s\n" *) -(* (string_of_equality current) *) -(* (string_of_equality newcurrent))); *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "active is: %s" *) -(* (String.concat "\n" *) -(* (List.map (fun (_, e) -> (string_of_equality e)) active_list)))); *) - None - ) - else - Some (sign, newcurrent) - in - let res = - let res = demodulate active_table current in - match res with - | None -> None - | Some (sign, newcurrent) -> - match passive_table with - | None -> res - | Some passive_table -> demodulate passive_table newcurrent - in - match res with - | None -> None - | Some (Negative, c) -> - let ok = not ( - List.exists - (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c) - all) - in - if ok then res else None - | Some (Positive, c) -> - if Indexing.in_index active_table c then - None - else - match passive_table with - | None -> - if fst (Indexing.subsumption env active_table c) then - None - else - res - | Some passive_table -> - if Indexing.in_index passive_table c then None - else - let r1, _ = Indexing.subsumption env active_table c in - if r1 then None else - let r2, _ = Indexing.subsumption env passive_table c in - if r2 then None else res -;; - -type fs_time_info_t = { - mutable build_all: float; - mutable demodulate: float; - mutable subsumption: float; -};; - -let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };; - - -(** simplifies new using active and passive *) -let forward_simplify_new env (new_neg, new_pos) ?passive active = - let t1 = Unix.gettimeofday () in - - let active_list, active_table = active in - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - - let t2 = Unix.gettimeofday () in - fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1); - - let demodulate sign table target = - let newmeta, newtarget = - Indexing.demodulation_equality !maxmeta env table sign target in - maxmeta := newmeta; - newtarget - in - let t1 = Unix.gettimeofday () in - - let new_neg, new_pos = - let new_neg = List.map (demodulate Negative active_table) new_neg - and new_pos = List.map (demodulate Positive active_table) new_pos in - new_neg,new_pos - -(* PROVA - match passive_table with - | None -> new_neg, new_pos - | Some passive_table -> - List.map (demodulate Negative passive_table) new_neg, - List.map (demodulate Positive passive_table) new_pos *) - in - - let t2 = Unix.gettimeofday () in - fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1); - - let new_pos_set = - List.fold_left - (fun s e -> - if not (Inference.is_identity env e) then - if EqualitySet.mem e s then s - else EqualitySet.add e s - else s) - EqualitySet.empty new_pos - in - let new_pos = EqualitySet.elements new_pos_set in - - let subs = - match passive_table with - | None -> - (fun e -> not (fst (Indexing.subsumption env active_table e))) - | Some passive_table -> - (fun e -> not ((fst (Indexing.subsumption env active_table e)) || - (fst (Indexing.subsumption env passive_table e)))) - in -(* let t1 = Unix.gettimeofday () in *) -(* let t2 = Unix.gettimeofday () in *) -(* fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); *) - let is_duplicate = - match passive_table with - | None -> - (fun e -> not (Indexing.in_index active_table e)) - | Some passive_table -> - (fun e -> - not ((Indexing.in_index active_table e) || - (Indexing.in_index passive_table e))) - in - new_neg, List.filter subs (List.filter is_duplicate new_pos) -;; - - -(** simplifies active usign new *) -let backward_simplify_active env new_pos new_table min_weight active = - let active_list, active_table = active in - let active_list, newa = - List.fold_right - (fun (s, equality) (res, newn) -> - let ew, _, _, _, _ = equality in - if ew < min_weight then - (s, equality)::res, newn - else - match forward_simplify env (s, equality) (new_pos, new_table) with - | None -> res, newn - | Some (s, e) -> - if equality = e then - (s, e)::res, newn - else - res, (s, e)::newn) - active_list ([], []) - in - let find eq1 where = - List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where - in - let active, newa = - List.fold_right - (fun (s, eq) (res, tbl) -> - if List.mem (s, eq) res then - res, tbl - else if (is_identity env eq) || (find eq res) then ( - res, tbl - ) - else - (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq) - active_list ([], Indexing.empty), - List.fold_right - (fun (s, eq) (n, p) -> - if (s <> Negative) && (is_identity env eq) then ( - (n, p) - ) else - if s = Negative then eq::n, p - else n, eq::p) - newa ([], []) - in - match newa with - | [], [] -> active, None - | _ -> active, Some newa -;; - - -(** simplifies passive using new *) -let backward_simplify_passive env new_pos new_table min_weight passive = - let (nl, ns), (pl, ps), passive_table = passive in - let f sign equality (resl, ress, newn) = - let ew, _, _, _, _ = equality in - if ew < min_weight then - equality::resl, ress, newn - else - match forward_simplify env (sign, equality) (new_pos, new_table) with - | None -> resl, EqualitySet.remove equality ress, newn - | Some (s, e) -> - if equality = e then - equality::resl, ress, newn - else - let ress = EqualitySet.remove equality ress in - resl, ress, e::newn - in - let nl, ns, newn = List.fold_right (f Negative) nl ([], ns, []) - and pl, ps, newp = List.fold_right (f Positive) pl ([], ps, []) in - let passive_table = - List.fold_left - (fun tbl e -> Indexing.index tbl e) Indexing.empty pl - in - match newn, newp with - | [], [] -> ((nl, ns), (pl, ps), passive_table), None - | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp) -;; - - -let backward_simplify env new' ?passive active = - let new_pos, new_table, min_weight = - List.fold_left - (fun (l, t, w) e -> - let ew, _, _, _, _ = e in - (Positive, e)::l, Indexing.index t e, min ew w) - ([], Indexing.empty, 1000000) (snd new') - in - let active, newa = - backward_simplify_active env new_pos new_table min_weight active in - match passive with - | None -> - active, (make_passive [] []), newa, None - | Some passive -> - let passive, newp = - backward_simplify_passive env new_pos new_table min_weight passive in - active, passive, newa, newp -;; - - -(* returns an estimation of how many equalities in passive can be activated - within the current time limit *) -let get_selection_estimate () = - elapsed_time := (Unix.gettimeofday ()) -. !start_time; - (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *) - int_of_float ( - ceil ((float_of_int !processed_clauses) *. - ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.))) -;; - - -(** initializes the set of goals *) -let make_goals goal = - let active = [] - and passive = [0, [goal]] in - active, passive -;; - - -(** initializes the set of theorems *) -let make_theorems theorems = - theorems, [] -;; - - -let activate_goal (active, passive) = - match passive with - | goal_conj::tl -> true, (goal_conj::active, tl) - | [] -> false, (active, passive) -;; - - -let activate_theorem (active, passive) = - match passive with - | theorem::tl -> true, (theorem::active, tl) - | [] -> false, (active, passive) -;; - - -(** simplifies a goal with equalities in active and passive *) -let simplify_goal env goal ?passive (active_list, active_table) = - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - - let demodulate table goal = - let newmeta, newgoal = - Indexing.demodulation_goal !maxmeta env table goal in - maxmeta := newmeta; - goal != newgoal, newgoal - in - let changed, goal = - match passive_table with - | None -> demodulate active_table goal - | Some passive_table -> - let changed, goal = demodulate active_table goal in - let changed', goal = demodulate passive_table goal in - (changed || changed'), goal - in - changed, goal -;; - - -let simplify_goals env goals ?passive active = - let a_goals, p_goals = goals in - let p_goals = - List.map - (fun (d, gl) -> - let gl = - List.map (fun g -> snd (simplify_goal env g ?passive active)) gl in - d, gl) - p_goals - in - let goals = - List.fold_left - (fun (a, p) (d, gl) -> - let changed = ref false in - let gl = - List.map - (fun g -> - let c, g = simplify_goal env g ?passive active in - changed := !changed || c; g) gl in - if !changed then (a, (d, gl)::p) else ((d, gl)::a, p)) - ([], p_goals) a_goals - in - goals -;; - - -let simplify_theorems env theorems ?passive (active_list, active_table) = - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - let a_theorems, p_theorems = theorems in - let demodulate table theorem = - let newmeta, newthm = - Indexing.demodulation_theorem !maxmeta env table theorem in - maxmeta := newmeta; - theorem != newthm, newthm - in - let foldfun table (a, p) theorem = - let changed, theorem = demodulate table theorem in - if changed then (a, theorem::p) else (theorem::a, p) - in - let mapfun table theorem = snd (demodulate table theorem) in - match passive_table with - | None -> - let p_theorems = List.map (mapfun active_table) p_theorems in - List.fold_left (foldfun active_table) ([], p_theorems) a_theorems - | Some passive_table -> - let p_theorems = List.map (mapfun active_table) p_theorems in - let p_theorems, a_theorems = - List.fold_left (foldfun active_table) ([], p_theorems) a_theorems in - let p_theorems = List.map (mapfun passive_table) p_theorems in - List.fold_left (foldfun passive_table) ([], p_theorems) a_theorems -;; - - -let rec simpl env e others others_simpl = - let active = others @ others_simpl in - let tbl = - List.fold_left - (fun t (_, e) -> Indexing.index t e) - Indexing.empty active - in - let res = forward_simplify env e (active, tbl) in - match others with - | hd::tl -> ( - match res with - | None -> simpl env hd tl others_simpl - | Some e -> simpl env hd tl (e::others_simpl) - ) - | [] -> ( - match res with - | None -> others_simpl - | Some e -> e::others_simpl - ) -;; - -let simplify_equalities env equalities = - debug_print - (lazy - (Printf.sprintf "equalities:\n%s\n" - (String.concat "\n" - (List.map string_of_equality equalities)))); - debug_print (lazy "SIMPLYFYING EQUALITIES..."); - match equalities with - | [] -> [] - | hd::tl -> - let others = List.map (fun e -> (Positive, e)) tl in - let res = - List.rev (List.map snd (simpl env (Positive, hd) others [])) - in - debug_print - (lazy - (Printf.sprintf "equalities AFTER:\n%s\n" - (String.concat "\n" - (List.map string_of_equality res)))); - res -;; - -(* applies equality to goal to see if the goal can be closed *) -let apply_equality_to_goal env equality goal = - let module C = Cic in - let module HL = HelmLibraryObjects in - let module I = Inference in - let metasenv, context, ugraph = env in - let _, proof, (ty, left, right, _), metas, args = equality in - let eqterm = - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right] in - let gproof, gmetas, gterm = goal in -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "APPLY EQUALITY TO GOAL: %s, %s" *) -(* (string_of_equality equality) (CicPp.ppterm gterm))); *) - try - let subst, metasenv', _ = - let menv = metasenv @ metas @ gmetas in - Inference.unification menv context eqterm gterm ugraph - in - let newproof = - match proof with - | I.BasicProof t -> I.BasicProof (CicMetaSubst.apply_subst subst t) - | I.ProofBlock (s, uri, nt, t, pe, p) -> - I.ProofBlock (subst @ s, uri, nt, t, pe, p) - | _ -> assert false - in - let newgproof = - let rec repl = function - | I.ProofGoalBlock (_, gp) -> I.ProofGoalBlock (newproof, gp) - | I.NoProof -> newproof - | I.BasicProof p -> newproof - | I.SubProof (t, i, p) -> I.SubProof (t, i, repl p) - | _ -> assert false - in - repl gproof - in - true, subst, newgproof - with CicUnification.UnificationFailure _ -> - false, [], I.NoProof -;; - - - -let new_meta metasenv = - let m = CicMkImplicit.new_meta metasenv [] in - incr maxmeta; - while !maxmeta <= m do incr maxmeta done; - !maxmeta -;; - - -(* applies a theorem or an equality to goal, returning a list of subgoals or - an indication of failure *) -let apply_to_goal env theorems ?passive active goal = - let metasenv, context, ugraph = env in - let proof, metas, term = goal in - (* debug_print *) - (* (lazy *) - (* (Printf.sprintf "apply_to_goal with goal: %s" *) - (* (\* (string_of_proof proof) *\)(CicPp.ppterm term))); *) - let status = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - let proof', newmeta = - let rec get_meta = function - | SubProof (t, i, p) -> - let t', i' = get_meta p in - if i' = -1 then t, i else t', i' - | ProofGoalBlock (_, p) -> get_meta p - | _ -> Cic.Implicit None, -1 - in - let p, m = get_meta proof in - if m = -1 then - let n = new_meta (metasenv @ metas) in - Cic.Meta (n, irl), n - else - p, m - in - let metasenv = (newmeta, context, term)::metasenv @ metas in - let bit = new_meta metasenv, context, term in - let metasenv' = bit::metasenv in - ((None, metasenv', Cic.Meta (newmeta, irl), term), newmeta) - in - let rec aux = function - | [] -> `No - | (theorem, thmty, _)::tl -> - try - let subst, (newproof, newgoals) = - PrimitiveTactics.apply_tac_verbose_with_subst ~term:theorem status - in - if newgoals = [] then - let _, _, p, _ = newproof in - let newp = - let rec repl = function - | Inference.ProofGoalBlock (_, gp) -> - Inference.ProofGoalBlock (Inference.BasicProof p, gp) - | Inference.NoProof -> Inference.BasicProof p - | Inference.BasicProof _ -> Inference.BasicProof p - | Inference.SubProof (t, i, p2) -> - Inference.SubProof (t, i, repl p2) - | _ -> assert false - in - repl proof - in - let _, m = status in - let subst = List.filter (fun (i, _) -> i = m) subst in - `Ok (subst, [newp, metas, term]) - else - let _, menv, p, _ = newproof in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - let goals = - List.map - (fun i -> - let _, _, ty = CicUtil.lookup_meta i menv in - let p' = - let rec gp = function - | SubProof (t, i, p) -> - SubProof (t, i, gp p) - | ProofGoalBlock (sp1, sp2) -> - ProofGoalBlock (sp1, gp sp2) - | BasicProof _ - | NoProof -> - SubProof (p, i, BasicProof (Cic.Meta (i, irl))) - | ProofSymBlock (s, sp) -> - ProofSymBlock (s, gp sp) - | ProofBlock (s, u, nt, t, pe, sp) -> - ProofBlock (s, u, nt, t, pe, gp sp) - in gp proof - in - (p', menv, ty)) - newgoals - in - let goals = - let weight t = - let w, m = weight_of_term t in - w + 2 * (List.length m) - in - List.sort - (fun (_, _, t1) (_, _, t2) -> - Pervasives.compare (weight t1) (weight t2)) - goals - in - let best = aux tl in - match best with - | `Ok (_, _) -> best - | `No -> `GoOn ([subst, goals]) - | `GoOn sl -> `GoOn ((subst, goals)::sl) - with ProofEngineTypes.Fail msg -> - aux tl - in - let r, s, l = - if Inference.term_is_equality term then - let rec appleq_a = function - | [] -> false, [], [] - | (Positive, equality)::tl -> - let ok, s, newproof = apply_equality_to_goal env equality goal in - if ok then true, s, [newproof, metas, term] else appleq_a tl - | _::tl -> appleq_a tl - in - let rec appleq_p = function - | [] -> false, [], [] - | equality::tl -> - let ok, s, newproof = apply_equality_to_goal env equality goal in - if ok then true, s, [newproof, metas, term] else appleq_p tl - in - let al, _ = active in - match passive with - | None -> appleq_a al - | Some (_, (pl, _), _) -> - let r, s, l = appleq_a al in if r then r, s, l else appleq_p pl - else - false, [], [] - in - if r = true then `Ok (s, l) else aux theorems -;; - - -(* sorts a conjunction of goals in order to detect earlier if it is - unsatisfiable. Non-predicate goals are placed at the end of the list *) -let sort_goal_conj (metasenv, context, ugraph) (depth, gl) = - let gl = - List.stable_sort - (fun (_, e1, g1) (_, e2, g2) -> - let ty1, _ = - CicTypeChecker.type_of_aux' (e1 @ metasenv) context g1 ugraph - and ty2, _ = - CicTypeChecker.type_of_aux' (e2 @ metasenv) context g2 ugraph - in - let prop1 = - let b, _ = - CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty1 ugraph - in - if b then 0 else 1 - and prop2 = - let b, _ = - CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty2 ugraph - in - if b then 0 else 1 - in - if prop1 = 0 && prop2 = 0 then - let e1 = if Inference.term_is_equality g1 then 0 else 1 - and e2 = if Inference.term_is_equality g2 then 0 else 1 in - e1 - e2 - else - prop1 - prop2) - gl - in - (depth, gl) -;; - - -let is_meta_closed goals = - List.for_all (fun (_, _, g) -> CicUtil.is_meta_closed g) goals -;; - - -(* applies a series of theorems/equalities to a conjunction of goals *) -let rec apply_to_goal_conj env theorems ?passive active (depth, goals) = - let aux (goal, r) tl = - let propagate_subst subst (proof, metas, term) = - let rec repl = function - | NoProof -> NoProof - | BasicProof t -> - BasicProof (CicMetaSubst.apply_subst subst t) - | ProofGoalBlock (p, pb) -> - let pb' = repl pb in - ProofGoalBlock (p, pb') - | SubProof (t, i, p) -> - let t' = CicMetaSubst.apply_subst subst t in - let p = repl p in - SubProof (t', i, p) - | ProofSymBlock (ens, p) -> ProofSymBlock (ens, repl p) - | ProofBlock (s, u, nty, t, pe, p) -> - ProofBlock (subst @ s, u, nty, t, pe, p) - in (repl proof, metas, term) - in - (* let r = apply_to_goal env theorems ?passive active goal in *) ( - match r with - | `No -> `No (depth, goals) - | `GoOn sl -> - let l = - List.map - (fun (s, gl) -> - let tl = List.map (propagate_subst s) tl in - sort_goal_conj env (depth+1, gl @ tl)) sl - in - `GoOn l - | `Ok (subst, gl) -> - if tl = [] then - `Ok (depth, gl) - else - let p, _, _ = List.hd gl in - let subproof = - let rec repl = function - | SubProof (_, _, p) -> repl p - | ProofGoalBlock (p1, p2) -> - ProofGoalBlock (repl p1, repl p2) - | p -> p - in - build_proof_term (repl p) - in - let i = - let rec get_meta = function - | SubProof (_, i, p) -> - let i' = get_meta p in - if i' = -1 then i else i' -(* max i (get_meta p) *) - | ProofGoalBlock (_, p) -> get_meta p - | _ -> -1 - in - get_meta p - in - let subst = - let _, (context, _, _) = List.hd subst in - [i, (context, subproof, Cic.Implicit None)] - in - let tl = List.map (propagate_subst subst) tl in - let conj = sort_goal_conj env (depth(* +1 *), tl) in - `GoOn ([conj]) - ) - in - if depth > !maxdepth || (List.length goals) > !maxwidth then - `No (depth, goals) - else - let rec search_best res = function - | [] -> res - | goal::tl -> - let r = apply_to_goal env theorems ?passive active goal in - match r with - | `Ok _ -> (goal, r) - | `No -> search_best res tl - | `GoOn l -> - let newres = - match res with - | _, `Ok _ -> assert false - | _, `No -> goal, r - | _, `GoOn l2 -> - if (List.length l) < (List.length l2) then goal, r else res - in - search_best newres tl - in - let hd = List.hd goals in - let res = hd, (apply_to_goal env theorems ?passive active hd) in - let best = - match res with - | _, `Ok _ -> res - | _, _ -> search_best res (List.tl goals) - in - let res = aux best (List.filter (fun g -> g != (fst best)) goals) in - match res with - | `GoOn ([conj]) when is_meta_closed (snd conj) && - (List.length (snd conj)) < (List.length goals)-> - apply_to_goal_conj env theorems ?passive active conj - | _ -> res -;; - - -(* -module OrderedGoals = struct - type t = int * (Inference.proof * Cic.metasenv * Cic.term) list - - let compare g1 g2 = - let d1, l1 = g1 - and d2, l2 = g2 in - let r = d2 - d1 in - if r <> 0 then r - else let r = (List.length l1) - (List.length l2) in - if r <> 0 then r - else - let res = ref 0 in - let _ = - List.exists2 - (fun (_, _, t1) (_, _, t2) -> - let r = Pervasives.compare t1 t2 in - if r <> 0 then ( - res := r; - true - ) else - false) l1 l2 - in !res -end - -module GoalsSet = Set.Make(OrderedGoals);; - - -exception SearchSpaceOver;; -*) - - -(* -let apply_to_goals env is_passive_empty theorems active goals = - debug_print (lazy "\n\n\tapply_to_goals\n\n"); - let add_to set goals = - List.fold_left (fun s g -> GoalsSet.add g s) set goals - in - let rec aux set = function - | [] -> - debug_print (lazy "HERE!!!"); - if is_passive_empty then raise SearchSpaceOver else false, set - | goals::tl -> - let res = apply_to_goal_conj env theorems active goals in - match res with - | `Ok newgoals -> - let _ = - let d, p, t = - match newgoals with - | (d, (p, _, t)::_) -> d, p, t - | _ -> assert false - in - debug_print - (lazy - (Printf.sprintf "\nOK!!!!\ndepth: %d\nProof: %s\ngoal: %s\n" - d (string_of_proof p) (CicPp.ppterm t))) - in - true, GoalsSet.singleton newgoals - | `GoOn newgoals -> - let set' = add_to set (goals::tl) in - let set' = add_to set' newgoals in - false, set' - | `No newgoals -> - aux set tl - in - let n = List.length goals in - let res, goals = aux (add_to GoalsSet.empty goals) goals in - let goals = GoalsSet.elements goals in - debug_print (lazy "\n\tapply_to_goals end\n"); - let m = List.length goals in - if m = n && is_passive_empty then - raise SearchSpaceOver - else - res, goals -;; -*) - - -(* sorts the list of passive goals to minimize the search for a proof (doesn't - work that well yet...) *) -let sort_passive_goals goals = - List.stable_sort - (fun (d1, l1) (d2, l2) -> - let r1 = d2 - d1 - and r2 = (List.length l1) - (List.length l2) in - let foldfun ht (_, _, t) = - let _ = List.map (fun i -> Hashtbl.replace ht i 1) (metas_of_term t) - in ht - in - let m1 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l1) - and m2 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l2) - in let r3 = m1 - m2 in - if r3 <> 0 then r3 - else if r2 <> 0 then r2 - else r1) - (* let _, _, g1 = List.hd l1 *) -(* and _, _, g2 = List.hd l2 in *) -(* let e1 = if Inference.term_is_equality g1 then 0 else 1 *) -(* and e2 = if Inference.term_is_equality g2 then 0 else 1 *) -(* in let r4 = e1 - e2 in *) -(* if r4 <> 0 then r3 else r1) *) - goals -;; - - -let print_goals goals = - (String.concat "\n" - (List.map - (fun (d, gl) -> - let gl' = - List.map - (fun (p, _, t) -> - (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl - in - Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals)) -;; - - -(* tries to prove the first conjunction in goals with applications of - theorems/equalities, returning new sub-goals or an indication of success *) -let apply_goal_to_theorems dbd env theorems ?passive active goals = - let theorems, _ = theorems in - let a_goals, p_goals = goals in - let goal = List.hd a_goals in - let not_in_active gl = - not - (List.exists - (fun (_, gl') -> - if (List.length gl) = (List.length gl') then - List.for_all2 (fun (_, _, g1) (_, _, g2) -> g1 = g2) gl gl' - else - false) - a_goals) - in - let aux theorems = - let res = apply_to_goal_conj env theorems ?passive active goal in - match res with - | `Ok newgoals -> - true, ([newgoals], []) - | `No _ -> - false, (a_goals, p_goals) - | `GoOn newgoals -> - let newgoals = - List.filter - (fun (d, gl) -> - (d <= !maxdepth) && (List.length gl) <= !maxwidth && - not_in_active gl) - newgoals in - let p_goals = newgoals @ p_goals in - let p_goals = sort_passive_goals p_goals in - false, (a_goals, p_goals) - in - aux theorems -;; - - -let apply_theorem_to_goals env theorems active goals = - let a_goals, p_goals = goals in - let theorem = List.hd (fst theorems) in - let theorems = [theorem] in - let rec aux p = function - | [] -> false, ([], p) - | goal::tl -> - let res = apply_to_goal_conj env theorems active goal in - match res with - | `Ok newgoals -> true, ([newgoals], []) - | `No _ -> aux p tl - | `GoOn newgoals -> aux (newgoals @ p) tl - in - let ok, (a, p) = aux p_goals a_goals in - if ok then - ok, (a, p) - else - let p_goals = - List.stable_sort - (fun (d1, l1) (d2, l2) -> - let r = d2 - d1 in - if r <> 0 then r - else let r = (List.length l1) - (List.length l2) in - if r <> 0 then r - else - let res = ref 0 in - let _ = - List.exists2 - (fun (_, _, t1) (_, _, t2) -> - let r = Pervasives.compare t1 t2 in - if r <> 0 then (res := r; true) else false) l1 l2 - in !res) - p - in - ok, (a_goals, p_goals) -;; - - -(* given-clause algorithm with lazy reduction strategy *) -let rec given_clause dbd env goals theorems passive active = - let goals = simplify_goals env goals active in - let ok, goals = activate_goal goals in - (* let theorems = simplify_theorems env theorems active in *) - if ok then - let ok, goals = apply_goal_to_theorems dbd env theorems active goals in - if ok then - let proof = - match (fst goals) with - | (_, [proof, _, _])::_ -> Some proof - | _ -> assert false - in - ParamodulationSuccess (proof, env) - else - given_clause_aux dbd env goals theorems passive active - else -(* let ok', theorems = activate_theorem theorems in *) - let ok', theorems = false, theorems in - if ok' then - let ok, goals = apply_theorem_to_goals env theorems active goals in - if ok then - let proof = - match (fst goals) with - | (_, [proof, _, _])::_ -> Some proof - | _ -> assert false - in - ParamodulationSuccess (proof, env) - else - given_clause_aux dbd env goals theorems passive active - else - if (passive_is_empty passive) then ParamodulationFailure - else given_clause_aux dbd env goals theorems passive active - -and given_clause_aux dbd env goals theorems passive active = - let time1 = Unix.gettimeofday () in - - let selection_estimate = get_selection_estimate () in - let kept = size_of_passive passive in - let passive = - if !time_limit = 0. || !processed_clauses = 0 then - passive - else if !elapsed_time > !time_limit then ( - debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" - !time_limit !elapsed_time)); - make_passive [] [] - ) else if kept > selection_estimate then ( - debug_print - (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ - "(kept: %d, selection_estimate: %d)\n") - kept selection_estimate)); - prune_passive selection_estimate active passive - ) else - passive - in - - let time2 = Unix.gettimeofday () in - passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); - - kept_clauses := (size_of_passive passive) + (size_of_active active); - match passive_is_empty passive with - | true -> (* ParamodulationFailure *) - given_clause dbd env goals theorems passive active - | false -> - let (sign, current), passive = select env (fst goals) passive active in - let time1 = Unix.gettimeofday () in - let res = forward_simplify env (sign, current) ~passive active in - let time2 = Unix.gettimeofday () in - forward_simpl_time := !forward_simpl_time +. (time2 -. time1); - match res with - | None -> - given_clause dbd env goals theorems passive active - | Some (sign, current) -> - if (sign = Negative) && (is_identity env current) then ( - debug_print - (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) - (string_of_equality ~env current))); - let _, proof, _, _, _ = current in - ParamodulationSuccess (Some proof, env) - ) else ( - debug_print - (lazy "\n================================================"); - debug_print (lazy (Printf.sprintf "selected: %s %s" - (string_of_sign sign) - (string_of_equality ~env current))); - - let t1 = Unix.gettimeofday () in - let new' = infer env sign current active in - let t2 = Unix.gettimeofday () in - infer_time := !infer_time +. (t2 -. t1); - - let res, goal' = contains_empty env new' in - if res then - let proof = - match goal' with - | Some goal -> let _, proof, _, _, _ = goal in Some proof - | None -> None - in - ParamodulationSuccess (proof, env) - else - let t1 = Unix.gettimeofday () in - let new' = forward_simplify_new env new' active in - let t2 = Unix.gettimeofday () in - let _ = - forward_simpl_new_time := - !forward_simpl_new_time +. (t2 -. t1) - in - let active = - match sign with - | Negative -> active - | Positive -> - let t1 = Unix.gettimeofday () in - let active, _, newa, _ = - backward_simplify env ([], [current]) active - in - let t2 = Unix.gettimeofday () in - backward_simpl_time := - !backward_simpl_time +. (t2 -. t1); - match newa with - | None -> active - | Some (n, p) -> - let al, tbl = active in - let nn = List.map (fun e -> Negative, e) n in - let pp, tbl = - List.fold_right - (fun e (l, t) -> - (Positive, e)::l, - Indexing.index tbl e) - p ([], tbl) - in - nn @ al @ pp, tbl - in - match contains_empty env new' with - | false, _ -> - let active = - let al, tbl = active in - match sign with - | Negative -> (sign, current)::al, tbl - | Positive -> - al @ [(sign, current)], Indexing.index tbl current - in - let passive = add_to_passive passive new' in - given_clause dbd env goals theorems passive active - | true, goal -> - let proof = - match goal with - | Some goal -> - let _, proof, _, _, _ = goal in Some proof - | None -> None - in - ParamodulationSuccess (proof, env) - ) -;; - - -(** given-clause algorithm with full reduction strategy *) -let rec given_clause_fullred dbd env goals theorems passive active = - let goals = simplify_goals env goals ~passive active in - let ok, goals = activate_goal goals in -(* let theorems = simplify_theorems env theorems ~passive active in *) - if ok then -(* let _ = *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "\ngoals = \nactive\n%s\npassive\n%s\n" *) -(* (print_goals (fst goals)) (print_goals (snd goals)))); *) -(* let current = List.hd (fst goals) in *) -(* let p, _, t = List.hd (snd current) in *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "goal activated:\n%s\n%s\n" *) -(* (CicPp.ppterm t) (string_of_proof p))); *) -(* in *) - let ok, goals = - apply_goal_to_theorems dbd env theorems ~passive active goals - in - if ok then - let proof = - match (fst goals) with - | (_, [proof, _, _])::_ -> Some proof - | _ -> assert false - in - ParamodulationSuccess (proof, env) - else - given_clause_fullred_aux dbd env goals theorems passive active - else -(* let ok', theorems = activate_theorem theorems in *) -(* if ok' then *) -(* let ok, goals = apply_theorem_to_goals env theorems active goals in *) -(* if ok then *) -(* let proof = *) -(* match (fst goals) with *) -(* | (_, [proof, _, _])::_ -> Some proof *) -(* | _ -> assert false *) -(* in *) -(* ParamodulationSuccess (proof, env) *) -(* else *) -(* given_clause_fullred_aux env goals theorems passive active *) -(* else *) - if (passive_is_empty passive) then ParamodulationFailure - else given_clause_fullred_aux dbd env goals theorems passive active - -and given_clause_fullred_aux dbd env goals theorems passive active = - let time1 = Unix.gettimeofday () in - - let selection_estimate = get_selection_estimate () in - let kept = size_of_passive passive in - let passive = - if !time_limit = 0. || !processed_clauses = 0 then - passive - else if !elapsed_time > !time_limit then ( - debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" - !time_limit !elapsed_time)); - make_passive [] [] - ) else if kept > selection_estimate then ( - debug_print - (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ - "(kept: %d, selection_estimate: %d)\n") - kept selection_estimate)); - prune_passive selection_estimate active passive - ) else - passive - in - - let time2 = Unix.gettimeofday () in - passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); - - kept_clauses := (size_of_passive passive) + (size_of_active active); - match passive_is_empty passive with - | true -> (* ParamodulationFailure *) - given_clause_fullred dbd env goals theorems passive active - | false -> - let (sign, current), passive = select env (fst goals) passive active in - let time1 = Unix.gettimeofday () in - let res = forward_simplify env (sign, current) ~passive active in - let time2 = Unix.gettimeofday () in - forward_simpl_time := !forward_simpl_time +. (time2 -. time1); - match res with - | None -> - given_clause_fullred dbd env goals theorems passive active - | Some (sign, current) -> - if (sign = Negative) && (is_identity env current) then ( - debug_print - (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) - (string_of_equality ~env current))); - let _, proof, _, _, _ = current in - ParamodulationSuccess (Some proof, env) - ) else ( - debug_print - (lazy "\n================================================"); - debug_print (lazy (Printf.sprintf "selected: %s %s" - (string_of_sign sign) - (string_of_equality ~env current))); - - let t1 = Unix.gettimeofday () in - let new' = infer env sign current active in - let t2 = Unix.gettimeofday () in - infer_time := !infer_time +. (t2 -. t1); - - let active = - if is_identity env current then active - else - let al, tbl = active in - match sign with - | Negative -> (sign, current)::al, tbl - | Positive -> - al @ [(sign, current)], Indexing.index tbl current - in - let rec simplify new' active passive = - let t1 = Unix.gettimeofday () in - let new' = forward_simplify_new env new' ~passive active in - let t2 = Unix.gettimeofday () in - forward_simpl_new_time := - !forward_simpl_new_time +. (t2 -. t1); - let t1 = Unix.gettimeofday () in - let active, passive, newa, retained = - backward_simplify env new' ~passive active in - let t2 = Unix.gettimeofday () in - backward_simpl_time := !backward_simpl_time +. (t2 -. t1); - match newa, retained with - | None, None -> active, passive, new' - | Some (n, p), None - | None, Some (n, p) -> - let nn, np = new' in - simplify (nn @ n, np @ p) active passive - | Some (n, p), Some (rn, rp) -> - let nn, np = new' in - simplify (nn @ n @ rn, np @ p @ rp) active passive - in - let active, passive, new' = simplify new' active passive in - - let k = size_of_passive passive in - if k < (kept - 1) then - processed_clauses := !processed_clauses + (kept - 1 - k); - - let _ = - debug_print - (lazy - (Printf.sprintf "active:\n%s\n" - (String.concat "\n" - ((List.map - (fun (s, e) -> (string_of_sign s) ^ " " ^ - (string_of_equality ~env e)) - (fst active)))))) - in - let _ = - match new' with - | neg, pos -> - debug_print - (lazy - (Printf.sprintf "new':\n%s\n" - (String.concat "\n" - ((List.map - (fun e -> "Negative " ^ - (string_of_equality ~env e)) neg) @ - (List.map - (fun e -> "Positive " ^ - (string_of_equality ~env e)) pos))))) - in - match contains_empty env new' with - | false, _ -> - let passive = add_to_passive passive new' in - given_clause_fullred dbd env goals theorems passive active - | true, goal -> - let proof = - match goal with - | Some goal -> let _, proof, _, _, _ = goal in Some proof - | None -> None - in - ParamodulationSuccess (proof, env) - ) -;; - - -let rec saturate_equations env goal accept_fun passive active = - elapsed_time := Unix.gettimeofday () -. !start_time; - if !elapsed_time > !time_limit then - (active, passive) - else - let (sign, current), passive = select env [1, [goal]] passive active in - let res = forward_simplify env (sign, current) ~passive active in - match res with - | None -> - saturate_equations env goal accept_fun passive active - | Some (sign, current) -> - assert (sign = Positive); - debug_print - (lazy "\n================================================"); - debug_print (lazy (Printf.sprintf "selected: %s %s" - (string_of_sign sign) - (string_of_equality ~env current))); - let new' = infer env sign current active in - let active = - if is_identity env current then active - else - let al, tbl = active in - al @ [(sign, current)], Indexing.index tbl current - in - let rec simplify new' active passive = - let new' = forward_simplify_new env new' ~passive active in - let active, passive, newa, retained = - backward_simplify env new' ~passive active in - match newa, retained with - | None, None -> active, passive, new' - | Some (n, p), None - | None, Some (n, p) -> - let nn, np = new' in - simplify (nn @ n, np @ p) active passive - | Some (n, p), Some (rn, rp) -> - let nn, np = new' in - simplify (nn @ n @ rn, np @ p @ rp) active passive - in - let active, passive, new' = simplify new' active passive in - let _ = - debug_print - (lazy - (Printf.sprintf "active:\n%s\n" - (String.concat "\n" - ((List.map - (fun (s, e) -> (string_of_sign s) ^ " " ^ - (string_of_equality ~env e)) - (fst active)))))) - in - let _ = - match new' with - | neg, pos -> - debug_print - (lazy - (Printf.sprintf "new':\n%s\n" - (String.concat "\n" - ((List.map - (fun e -> "Negative " ^ - (string_of_equality ~env e)) neg) @ - (List.map - (fun e -> "Positive " ^ - (string_of_equality ~env e)) pos))))) - in - let new' = match new' with _, pos -> [], List.filter accept_fun pos in - let passive = add_to_passive passive new' in - saturate_equations env goal accept_fun passive active -;; - - - - -let main dbd full term metasenv ugraph = - let module C = Cic in - let module T = CicTypeChecker in - let module PET = ProofEngineTypes in - let module PP = CicPp in - let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in - let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in - let proof, goals = status in - let goal' = List.nth goals 0 in - let _, metasenv, meta_proof, _ = proof in - let _, context, goal = CicUtil.lookup_meta goal' metasenv in - let eq_indexes, equalities, maxm = find_equalities context proof in - let lib_eq_uris, library_equalities, maxm = - - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let library_equalities = List.map snd library_equalities in - maxmeta := maxm+2; (* TODO ugly!! *) - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in - let new_meta_goal, metasenv, type_of_goal = - let _, context, ty = CicUtil.lookup_meta goal' metasenv in - debug_print - (lazy - (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n\n" (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let env = (metasenv, context, ugraph) in - let t1 = Unix.gettimeofday () in - let theorems = - if full then - let theorems = find_library_theorems dbd env (proof, goal') lib_eq_uris in - let context_hyp = find_context_hypotheses env eq_indexes in - context_hyp @ theorems, [] - else - let refl_equal = - let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") - in - let t = CicUtil.term_of_uri refl_equal in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - [(t, ty, [])], [] - in - let t2 = Unix.gettimeofday () in - debug_print - (lazy - (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); - let _ = - debug_print - (lazy - (Printf.sprintf - "Theorems:\n-------------------------------------\n%s\n" - (String.concat "\n" - (List.map - (fun (t, ty, _) -> - Printf.sprintf - "Term: %s, type: %s" (CicPp.ppterm t) (CicPp.ppterm ty)) - (fst theorems))))) - in - (*try*) - let goal = Inference.BasicProof new_meta_goal, [], goal in - let equalities = simplify_equalities env (equalities@library_equalities) in - let active = make_active () in - let passive = make_passive [] equalities in - Printf.printf "\ncurrent goal: %s\n" - (let _, _, g = goal in CicPp.ppterm g); - Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); - Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); - Printf.printf "\nequalities:\n%s\n" - (String.concat "\n" - (List.map - (string_of_equality ~env) equalities)); -(* (equalities @ library_equalities))); *) - print_endline "--------------------------------------------------"; - let start = Unix.gettimeofday () in - print_endline "GO!"; - start_time := Unix.gettimeofday (); - let res = - let goals = make_goals goal in - (if !use_fullred then given_clause_fullred else given_clause) - dbd env goals theorems passive active - in - let finish = Unix.gettimeofday () in - let _ = - match res with - | ParamodulationFailure -> - Printf.printf "NO proof found! :-(\n\n" - | ParamodulationSuccess (Some proof, env) -> - let proof = Inference.build_proof_term proof in - Printf.printf "OK, found a proof!\n"; - (* REMEMBER: we have to instantiate meta_proof, we should use - apply the "apply" tactic to proof and status - *) - let names = names_of_context context in - print_endline (PP.pp proof names); - let newmetasenv = - List.fold_left - (fun m (_, _, _, menv, _) -> m @ menv) metasenv equalities - in - let _ = - (*try*) - let ty, ug = - CicTypeChecker.type_of_aux' newmetasenv context proof ugraph - in - print_endline (string_of_float (finish -. start)); - Printf.printf - "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n\n" - (CicPp.pp type_of_goal names) (CicPp.pp ty names) - (string_of_bool - (fst (CicReduction.are_convertible - context type_of_goal ty ug))); - (*with e -> - Printf.printf "\nEXCEPTION!!! %s\n" (Printexc.to_string e); - Printf.printf "MAXMETA USED: %d\n" !maxmeta; - print_endline (string_of_float (finish -. start));*) - in - () - - | ParamodulationSuccess (None, env) -> - Printf.printf "Success, but no proof?!?\n\n" - in - Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^ - "forward_simpl_new_time: %.9f\n" ^^ - "backward_simpl_time: %.9f\n") - !infer_time !forward_simpl_time !forward_simpl_new_time - !backward_simpl_time; - Printf.printf "passive_maintainance_time: %.9f\n" - !passive_maintainance_time; - Printf.printf " successful unification/matching time: %.9f\n" - !Indexing.match_unif_time_ok; - Printf.printf " failed unification/matching time: %.9f\n" - !Indexing.match_unif_time_no; - Printf.printf " indexing retrieval time: %.9f\n" - !Indexing.indexing_retrieval_time; - Printf.printf " demodulate_term.build_newtarget_time: %.9f\n" - !Indexing.build_newtarget_time; - Printf.printf "derived %d clauses, kept %d clauses.\n" - !derived_clauses !kept_clauses; -(* - with exc -> - print_endline ("EXCEPTION: " ^ (Printexc.to_string exc)); - raise exc -*) -;; - - -let default_depth = !maxdepth -and default_width = !maxwidth;; - -let reset_refs () = - maxmeta := 0; - symbols_counter := 0; - weight_age_counter := !weight_age_ratio; - processed_clauses := 0; - start_time := 0.; - elapsed_time := 0.; - maximal_retained_equality := None; - infer_time := 0.; - forward_simpl_time := 0.; - forward_simpl_new_time := 0.; - backward_simpl_time := 0.; - passive_maintainance_time := 0.; - derived_clauses := 0; - kept_clauses := 0; -;; - -let saturate - dbd ?(full=false) ?(depth=default_depth) ?(width=default_width) status = - let module C = Cic in - reset_refs (); - Indexing.init_index (); - maxdepth := depth; - maxwidth := width; - let proof, goal = status in - let goal' = goal in - let uri, metasenv, meta_proof, term_to_prove = proof in - let _, context, goal = CicUtil.lookup_meta goal' metasenv in - let eq_indexes, equalities, maxm = find_equalities context proof in - let new_meta_goal, metasenv, type_of_goal = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - let _, context, ty = CicUtil.lookup_meta goal' metasenv in - debug_print - (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let ugraph = CicUniv.empty_ugraph in - let env = (metasenv, context, ugraph) in - let goal = Inference.BasicProof new_meta_goal, [], goal in - let res, time = - let t1 = Unix.gettimeofday () in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let library_equalities = List.map snd library_equalities in - let t2 = Unix.gettimeofday () in - maxmeta := maxm+2; - let equalities = simplify_equalities env (equalities@library_equalities) in - debug_print - (lazy - (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))); - let t1 = Unix.gettimeofday () in - let theorems = - if full then - let thms = find_library_theorems dbd env (proof, goal') lib_eq_uris in - let context_hyp = find_context_hypotheses env eq_indexes in - context_hyp @ thms, [] - else - let refl_equal = - let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") - in - let t = CicUtil.term_of_uri refl_equal in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - [(t, ty, [])], [] - in - let t2 = Unix.gettimeofday () in - let _ = - debug_print - (lazy - (Printf.sprintf - "Theorems:\n-------------------------------------\n%s\n" - (String.concat "\n" - (List.map - (fun (t, ty, _) -> - Printf.sprintf - "Term: %s, type: %s" - (CicPp.ppterm t) (CicPp.ppterm ty)) - (fst theorems))))); - debug_print - (lazy - (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); - in - let active = make_active () in - let passive = make_passive [] equalities in - let start = Unix.gettimeofday () in - let res = - let goals = make_goals goal in - given_clause_fullred dbd env goals theorems passive active - in - let finish = Unix.gettimeofday () in - (res, finish -. start) - in - match res with - | ParamodulationSuccess (Some proof, env) -> - debug_print (lazy "OK, found a proof!"); - let proof = Inference.build_proof_term proof in - let names = names_of_context context in - let newmetasenv = - let i1 = - match new_meta_goal with - | C.Meta (i, _) -> i | _ -> assert false - in - List.filter (fun (i, _, _) -> i <> i1 && i <> goal') metasenv - in - let newstatus = - try - let ty, ug = - CicTypeChecker.type_of_aux' newmetasenv context proof ugraph - in - debug_print (lazy (CicPp.pp proof [](* names *))); - debug_print - (lazy - (Printf.sprintf - "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n" - (CicPp.pp type_of_goal names) (CicPp.pp ty names) - (string_of_bool - (fst (CicReduction.are_convertible - context type_of_goal ty ug))))); - let equality_for_replace i t1 = - match t1 with - | C.Meta (n, _) -> n = i - | _ -> false - in - let real_proof = - ProofEngineReduction.replace - ~equality:equality_for_replace - ~what:[goal'] ~with_what:[proof] - ~where:meta_proof - in - debug_print - (lazy - (Printf.sprintf "status:\n%s\n%s\n%s\n%s\n" - (match uri with Some uri -> UriManager.string_of_uri uri - | None -> "") - (print_metasenv newmetasenv) - (CicPp.pp real_proof [](* names *)) - (CicPp.pp term_to_prove names))); - ((uri, newmetasenv, real_proof, term_to_prove), []) - with CicTypeChecker.TypeCheckerFailure _ -> - debug_print (lazy "THE PROOF DOESN'T TYPECHECK!!!"); - debug_print (lazy (CicPp.pp proof names)); - raise (ProofEngineTypes.Fail - (lazy "Found a proof, but it doesn't typecheck")) - in - let tall = fs_time_info.build_all in - let tdemodulate = fs_time_info.demodulate in - let tsubsumption = fs_time_info.subsumption in - debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time)); - debug_print (lazy (Printf.sprintf "\ntall: %.9f" tall)); - debug_print (lazy (Printf.sprintf "\ntdemod: %.9f" tdemodulate)); - debug_print (lazy (Printf.sprintf "\ntsubsumption: %.9f" tsubsumption)); - debug_print (lazy (Printf.sprintf "\ninfer_time: %.9f" !infer_time)); - debug_print (lazy (Printf.sprintf "\nforward_simpl_times: %.9f" !forward_simpl_time)); - debug_print (lazy (Printf.sprintf "\nforward_simpl_new_times: %.9f" !forward_simpl_new_time)); - debug_print (lazy (Printf.sprintf "\nbackward_simpl_times: %.9f" !backward_simpl_time)); - debug_print (lazy (Printf.sprintf "\npassive_maintainance_time: %.9f" !passive_maintainance_time)); - newstatus - | _ -> - raise (ProofEngineTypes.Fail (lazy "NO proof found")) -;; - -(* dummy function called within matita to trigger linkage *) -let init () = ();; - - -let retrieve_and_print dbd term metasenv ugraph = - let module C = Cic in - let module T = CicTypeChecker in - let module PET = ProofEngineTypes in - let module PP = CicPp in - let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in - let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in - let proof, goals = status in - let goal' = List.nth goals 0 in - let uri, metasenv, meta_proof, term_to_prove = proof in - let _, context, goal = CicUtil.lookup_meta goal' metasenv in - let eq_indexes, equalities, maxm = find_equalities context proof in - let new_meta_goal, metasenv, type_of_goal = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - let _, context, ty = CicUtil.lookup_meta goal' metasenv in - debug_print - (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let ugraph = CicUniv.empty_ugraph in - let env = (metasenv, context, ugraph) in - let t1 = Unix.gettimeofday () in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) in - let t2 = Unix.gettimeofday () in - maxmeta := maxm+2; - let equalities = (* equalities @ *) library_equalities in - debug_print - (lazy - (Printf.sprintf "\n\nequalities:\n%s\n" - (String.concat "\n" - (List.map - (fun (u, e) -> -(* Printf.sprintf "%s: %s" *) - (UriManager.string_of_uri u) -(* (string_of_equality e) *) - ) - equalities)))); - debug_print (lazy "SIMPLYFYING EQUALITIES..."); - let rec simpl e others others_simpl = - let (u, e) = e in - let active = List.map (fun (u, e) -> (Positive, e)) - (others @ others_simpl) in - let tbl = - List.fold_left - (fun t (_, e) -> Indexing.index t e) - Indexing.empty active - in - let res = forward_simplify env (Positive, e) (active, tbl) in - match others with - | hd::tl -> ( - match res with - | None -> simpl hd tl others_simpl - | Some e -> simpl hd tl ((u, (snd e))::others_simpl) - ) - | [] -> ( - match res with - | None -> others_simpl - | Some e -> (u, (snd e))::others_simpl - ) - in - let _equalities = - match equalities with - | [] -> [] - | hd::tl -> - let others = tl in (* List.map (fun e -> (Positive, e)) tl in *) - let res = - List.rev (simpl (*(Positive,*) hd others []) - in - debug_print - (lazy - (Printf.sprintf "\nequalities AFTER:\n%s\n" - (String.concat "\n" - (List.map - (fun (u, e) -> - Printf.sprintf "%s: %s" - (UriManager.string_of_uri u) - (string_of_equality e) - ) - res)))); - res in - debug_print - (lazy - (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))) -;; - - -let main_demod_equalities dbd term metasenv ugraph = - let module C = Cic in - let module T = CicTypeChecker in - let module PET = ProofEngineTypes in - let module PP = CicPp in - let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in - let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in - let proof, goals = status in - let goal' = List.nth goals 0 in - let _, metasenv, meta_proof, _ = proof in - let _, context, goal = CicUtil.lookup_meta goal' metasenv in - let eq_indexes, equalities, maxm = find_equalities context proof in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let library_equalities = List.map snd library_equalities in - maxmeta := maxm+2; (* TODO ugly!! *) - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in - let new_meta_goal, metasenv, type_of_goal = - let _, context, ty = CicUtil.lookup_meta goal' metasenv in - debug_print - (lazy - (Printf.sprintf "\n\nTRYING TO INFER EQUALITIES MATCHING: %s\n\n" - (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let env = (metasenv, context, ugraph) in - (*try*) - let goal = Inference.BasicProof new_meta_goal, [], goal in - let equalities = simplify_equalities env (equalities@library_equalities) in - let active = make_active () in - let passive = make_passive [] equalities in - Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); - Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); - Printf.printf "\nequalities:\n%s\n" - (String.concat "\n" - (List.map - (string_of_equality ~env) equalities)); - print_endline "--------------------------------------------------"; - print_endline "GO!"; - start_time := Unix.gettimeofday (); - if !time_limit < 1. then time_limit := 60.; - let ra, rp = - saturate_equations env goal (fun e -> true) passive active - in - - let initial = - List.fold_left (fun s e -> EqualitySet.add e s) - EqualitySet.empty equalities - in - let addfun s e = - if not (EqualitySet.mem e initial) then EqualitySet.add e s else s - in - - let passive = - match rp with - | (n, _), (p, _), _ -> - EqualitySet.elements (List.fold_left addfun EqualitySet.empty p) - in - let active = - let l = List.map snd (fst ra) in - EqualitySet.elements (List.fold_left addfun EqualitySet.empty l) - in - Printf.printf "\n\nRESULTS:\nActive:\n%s\n\nPassive:\n%s\n" - (String.concat "\n" (List.map (string_of_equality ~env) active)) - (* (String.concat "\n" - (List.map (fun e -> CicPp.ppterm (term_of_equality e)) active)) *) -(* (String.concat "\n" (List.map (string_of_equality ~env) passive)); *) - (String.concat "\n" - (List.map (fun e -> CicPp.ppterm (term_of_equality e)) passive)); - print_newline (); -(* - with e -> - debug_print (lazy ("EXCEPTION: " ^ (Printexc.to_string e))) -*) -;; - -let demodulate_tac ~dbd ~pattern ((proof,goal) as initialstatus) = - let module I = Inference in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let eq_indexes, equalities, maxm = I.find_equalities context proof in - let lib_eq_uris, library_equalities, maxm = - I.find_library_equalities dbd context (proof, goal) (maxm+2) in - if library_equalities = [] then prerr_endline "VUOTA!!!"; - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in - let library_equalities = List.map snd library_equalities in - let goalterm = Cic.Meta (metano,irl) in - let initgoal = Inference.BasicProof goalterm, [], ty in - let env = (metasenv, context, CicUniv.empty_ugraph) in - let equalities = simplify_equalities env (equalities@library_equalities) in - let table = - List.fold_left - (fun tbl eq -> Indexing.index tbl eq) - Indexing.empty equalities - in - let newmeta,(newproof,newmetasenv, newty) = Indexing.demodulation_goal - maxm (metasenv,context,CicUniv.empty_ugraph) table initgoal - in - if newmeta != maxm then - begin - let opengoal = Cic.Meta(maxm,irl) in - let proofterm = - Inference.build_proof_term ~noproof:opengoal newproof in - let extended_metasenv = (maxm,context,newty)::metasenv in - let extended_status = - (curi,extended_metasenv,pbo,pty),goal in - let (status,newgoals) = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac ~term:proofterm) - extended_status in - (status,maxm::newgoals) - end - else if newty = ty then - raise (ProofEngineTypes.Fail (lazy "no progress")) - else ProofEngineTypes.apply_tactic - (ReductionTactics.simpl_tac ~pattern) - initialstatus -;; - -let demodulate_tac ~dbd ~pattern = - ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~pattern) -;; diff --git a/helm/ocaml/tactics/paramodulation/saturation.mli b/helm/ocaml/tactics/paramodulation/saturation.mli deleted file mode 100644 index 34159810d..000000000 --- a/helm/ocaml/tactics/paramodulation/saturation.mli +++ /dev/null @@ -1,52 +0,0 @@ -(* Copyright (C) 2006, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -val saturate : - HMysql.dbd -> - ?full:bool -> - ?depth:int -> - ?width:int -> - ProofEngineTypes.proof * ProofEngineTypes.goal -> - (UriManager.uri option * Cic.conjecture list * Cic.term * Cic.term) * - 'a list - -val weight_age_ratio : int ref -val weight_age_counter: int ref -val symbols_ratio: int ref -val symbols_counter: int ref -val use_fullred: bool ref -val time_limit: float ref -val maxwidth: int ref -val maxdepth: int ref -val retrieve_and_print: HMysql.dbd -> Cic.term -> Cic.conjecture list -> 'a -> unit -val main_demod_equalities: HMysql.dbd -> - Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit -val main: HMysql.dbd -> - bool -> Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit -val demodulate_tac: - dbd:HMysql.dbd -> - pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/paramodulation/test_indexing.ml b/helm/ocaml/tactics/paramodulation/test_indexing.ml deleted file mode 100644 index ba6b2ebe0..000000000 --- a/helm/ocaml/tactics/paramodulation/test_indexing.ml +++ /dev/null @@ -1,253 +0,0 @@ -(* $Id$ *) - -open Path_indexing - -(* -let build_equality term = - let module C = Cic in - C.Implicit None, (C.Implicit None, term, C.Rel 1, Utils.Gt), [], [] -;; - - -(* - f = Rel 1 - g = Rel 2 - a = Rel 3 - b = Rel 4 - c = Rel 5 -*) -let path_indexing_test () = - let module C = Cic in - let terms = [ - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; - C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])] - ] in - let path_strings = List.map (path_strings_of_term 0) terms in - let table = - List.fold_left index PSTrie.empty (List.map build_equality terms) in - let query = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in - let matches = retrieve_generalizations table query in - let unifications = retrieve_unifiables table query in - let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) - and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in - let res1 = in_index table eq1 - and res2 = in_index table eq2 in - let print_results res = - String.concat "\n" - (PosEqSet.fold - (fun (p, e) l -> - let s = - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")" - in - s::l) - res []) - in - Printf.printf "path_strings:\n%s\n\n" - (String.concat "\n" - (List.map - (fun l -> - "{" ^ (String.concat "; " (List.map string_of_path_string l)) ^ "}" - ) path_strings)); - Printf.printf "table:\n%s\n\n" (string_of_pstrie table); - Printf.printf "matches:\n%s\n\n" (print_results matches); - Printf.printf "unifications:\n%s\n\n" (print_results unifications); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq1) (string_of_bool res1); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq2) (string_of_bool res2); -;; - - -let differing () = - let module C = Cic in - let t1 = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5] - and t2 = - C.Appl [C.Rel 1; C.Appl [C.Rel 5; C.Rel 4; C.Meta (1, [])]; C.Rel 5] - in - let res = Inference.extract_differing_subterms t1 t2 in - match res with - | None -> print_endline "NO DIFFERING SUBTERMS???" - | Some (t1, t2) -> - Printf.printf "OK: %s, %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); -;; - - -let next_after () = - let module C = Cic in - let t = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5] - in - let pos1 = Discrimination_tree.next_t [1] t in - let pos2 = Discrimination_tree.after_t [1] t in - Printf.printf "next_t 1: %s\nafter_t 1: %s\n" - (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos1 t)) - (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos2 t)); -;; - - -let discrimination_tree_test () = - let module C = Cic in - let terms = [ - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; - C.Appl [C.Rel 10; C.Meta (5, []); C.Rel 11] - ] in - let path_strings = - List.map Discrimination_tree.path_string_of_term terms in - let table = - List.fold_left - Discrimination_tree.index - Discrimination_tree.DiscriminationTree.empty - (List.map build_equality terms) - in -(* let query = *) -(* C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in *) - let query = C.Appl [C.Rel 10; C.Meta (14, []); C.Meta (13, [])] in - let matches = Discrimination_tree.retrieve_generalizations table query in - let unifications = Discrimination_tree.retrieve_unifiables table query in - let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) - and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in - let res1 = Discrimination_tree.in_index table eq1 - and res2 = Discrimination_tree.in_index table eq2 in - let print_results res = - String.concat "\n" - (Discrimination_tree.PosEqSet.fold - (fun (p, e) l -> - let s = - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")" - in - s::l) - res []) - in - Printf.printf "path_strings:\n%s\n\n" - (String.concat "\n" - (List.map Discrimination_tree.string_of_path_string path_strings)); - Printf.printf "table:\n%s\n\n" - (Discrimination_tree.string_of_discrimination_tree table); - Printf.printf "matches:\n%s\n\n" (print_results matches); - Printf.printf "unifications:\n%s\n\n" (print_results unifications); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq1) (string_of_bool res1); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq2) (string_of_bool res2); -;; - - -let test_subst () = - let module C = Cic in - let module M = CicMetaSubst in - let term = C.Appl [ - C.Rel 1; - C.Appl [C.Rel 11; - C.Meta (43, []); - C.Appl [C.Rel 15; C.Rel 12; C.Meta (41, [])]]; - C.Appl [C.Rel 11; - C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])]; - C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (12, [])]] - ] in - let subst1 = [ - (43, ([], C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])], C.Rel 16)); - (10, ([], C.Rel 12, C.Rel 16)); - (12, ([], C.Meta (41, []), C.Rel 16)) - ] - and subst2 = [ - (43, ([], C.Appl [C.Rel 15; C.Rel 12; C.Meta (11, [])], C.Rel 16)); - (10, ([], C.Rel 12, C.Rel 16)); - (12, ([], C.Meta (41, []), C.Rel 16)) - ] in - let t1 = M.apply_subst subst1 term - and t2 = M.apply_subst subst2 term in - Printf.printf "t1 = %s\nt2 = %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); -;; -*) - - -let test_refl () = - let module C = Cic in - let context = [ - Some (C.Name "H", C.Decl ( - C.Prod (C.Name "z", C.Rel 3, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 4; C.Rel 3; C.Rel 1]))); - Some (C.Name "x", C.Decl (C.Rel 2)); - Some (C.Name "y", C.Decl (C.Rel 1)); - Some (C.Name "A", C.Decl (C.Sort C.Set)) - ] - in - let term = C.Appl [ - C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); C.Rel 4; - C.Rel 2; - C.Lambda (C.Name "z", C.Rel 4, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 5; C.Rel 1; C.Rel 3 - ]); - C.Appl [C.MutConstruct - (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); (* reflexivity *) - C.Rel 4; C.Rel 2]; - C.Rel 3; -(* C.Appl [C.Const (HelmLibraryObjects.Logic.sym_eq_URI, []); (\* symmetry *\) *) -(* C.Rel 4; C.Appl [C.Rel 1; C.Rel 2]] *) - C.Appl [ - C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); - C.Rel 4; C.Rel 3; - C.Lambda (C.Name "z", C.Rel 4, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 5; C.Rel 1; C.Rel 4 - ]); - C.Appl [C.MutConstruct (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); - C.Rel 4; C.Rel 3]; - C.Rel 2; C.Appl [C.Rel 1; C.Rel 2] - ] - ] in - let ens = [ - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var", - C.Rel 4); - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var", - C.Rel 3); - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var", - C.Rel 2); - ] in - let term2 = C.Appl [ - C.Const (HelmLibraryObjects.Logic.sym_eq_URI, ens); - C.Appl [C.Rel 1; C.Rel 2] - ] in - let ty, ug = - CicTypeChecker.type_of_aux' [] context term CicUniv.empty_ugraph - in - Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term) (CicPp.ppterm ty); - let ty, ug = - CicTypeChecker.type_of_aux' [] context term2 CicUniv.empty_ugraph - in - Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term2) (CicPp.ppterm ty); -;; - - -let test_lib () = - let uri = Sys.argv.(1) in - let t = CicUtil.term_of_uri (UriManager.uri_of_string uri) in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - Printf.printf "Term of %s: %s\n" uri (CicPp.ppterm t); - Printf.printf "type: %s\n" (CicPp.ppterm ty); -;; - - -(* differing ();; *) -(* next_after ();; *) -(* discrimination_tree_test ();; *) -(* path_indexing_test ();; *) -(* test_subst ();; *) -Helm_registry.load_from "../../matita/matita.conf.xml"; -(* test_refl ();; *) -test_lib ();; diff --git a/helm/ocaml/tactics/paramodulation/utils.ml b/helm/ocaml/tactics/paramodulation/utils.ml deleted file mode 100644 index b212d0fab..000000000 --- a/helm/ocaml/tactics/paramodulation/utils.ml +++ /dev/null @@ -1,707 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* $Id$ *) - -let debug = true;; - -let debug_print s = if debug then prerr_endline (Lazy.force s);; - -let print_metasenv metasenv = - String.concat "\n--------------------------\n" - (List.map (fun (i, context, term) -> - (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^ - "\n] " ^ (CicPp.ppterm term)) - metasenv) -;; - - - - -let print_subst ?(prefix="\n") subst = - String.concat prefix - (List.map - (fun (i, (c, t, ty)) -> - Printf.sprintf "?%d -> %s : %s" i - (CicPp.ppterm t) (CicPp.ppterm ty)) - subst) -;; - -type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; - -let string_of_comparison = function - | Lt -> "<" - | Le -> "<=" - | Gt -> ">" - | Ge -> ">=" - | Eq -> "=" - | Incomparable -> "I" - -module OrderedTerm = -struct - type t = Cic.term - - let compare = Pervasives.compare -end - -module TermSet = Set.Make(OrderedTerm);; -module TermMap = Map.Make(OrderedTerm);; - -let symbols_of_term term = - let module C = Cic in - let rec aux map = function - | C.Meta _ -> map - | C.Appl l -> - List.fold_left (fun res t -> (aux res t)) map l - | t -> - let map = - try - let c = TermMap.find t map in - TermMap.add t (c+1) map - with Not_found -> - TermMap.add t 1 map - in - map - in - aux TermMap.empty term -;; - - -let metas_of_term term = - let module C = Cic in - let rec aux = function - | C.Meta _ as t -> TermSet.singleton t - | C.Appl l -> - List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l - | t -> TermSet.empty (* TODO: maybe add other cases? *) - in - aux term -;; - - -(************************* rpo ********************************) -let number = [ - UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)",3; - UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)",6; - UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)",9; - HelmLibraryObjects.Peano.pred_URI, 12; - HelmLibraryObjects.Peano.plus_URI, 15; - HelmLibraryObjects.Peano.minus_URI, 18; - HelmLibraryObjects.Peano.mult_URI, 21; - UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1)",103; - UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/1)",106; - UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/2)",109; - UriManager.uri_of_string "cic:/matita/nat/nat/pred.con",112; - UriManager.uri_of_string "cic:/matita/nat/plus/plus.con",115; - UriManager.uri_of_string "cic:/matita/nat/minus/minus.con",118; - UriManager.uri_of_string "cic:/matita/nat/times/times.con",121; - ] -;; - -let atomic t = - match t with - Cic.Const _ - | Cic.MutInd _ - | Cic.MutConstruct _ - | Cic.Rel _ -> true - | _ -> false - -let sig_order_const t1 t2 = - try - let u1 = CicUtil.uri_of_term t1 in - let u2 = CicUtil.uri_of_term t2 in - let n1 = List.assoc u1 number in - let n2 = List.assoc u2 number in - if n1 < n2 then Lt - else if n1 > n2 then Gt - else - begin - prerr_endline ("t1 = "^(CicPp.ppterm t1)); - prerr_endline ("t2 = "^(CicPp.ppterm t2)); - assert false - end - with - Invalid_argument _ - | Not_found -> Incomparable - -let sig_order t1 t2 = - match t1, t2 with - Cic.Rel n, Cic.Rel m when n < m -> Gt (* inverted order *) - | Cic.Rel n, Cic.Rel m when n = m -> Incomparable - | Cic.Rel n, Cic.Rel m when n > m -> Lt - | Cic.Rel _, _ -> Gt - | _, Cic.Rel _ -> Lt - | _,_ -> sig_order_const t1 t2 - -let rec rpo_lt t1 t2 = - let module C = Cic in - let first_trie = - match t1,t2 with - C.Meta (_, _), C.Meta (_,_) -> false - | C.Meta (_,_) , t2 -> TermSet.mem t1 (metas_of_term t2) - | t1, C.Meta (_,_) -> false - | C.Appl [h1;a1],C.Appl [h2;a2] when h1=h2 -> - rpo_lt a1 a2 - | C.Appl (h1::arg1),C.Appl (h2::arg2) when h1=h2 -> - if lex_lt arg1 arg2 then - check_lt arg1 t2 - else false - | C.Appl (h1::arg1),C.Appl (h2::arg2) -> - (match sig_order h1 h2 with - | Lt -> check_lt arg1 t2 - | _ -> false) - | C.Appl (h1::arg1), t2 when atomic t2 -> - (match sig_order h1 t2 with - | Lt -> check_lt arg1 t2 - | _ -> false) - | t1 , C.Appl (h2::arg2) when atomic t1 -> - (match sig_order t1 h2 with - | Lt -> true - | _ -> false ) - | C.Appl [] , _ -> assert false - | _ , C.Appl [] -> assert false - | t1, t2 when (atomic t1 && atomic t2 && t1<>t2) -> - (match sig_order t1 t2 with - | Lt -> true - | _ -> false) - | _,_ -> false - in - if first_trie then true else - match t2 with - C.Appl (_::args) -> - List.exists (fun a -> t1 = a || rpo_lt t1 a) args - | _ -> false - -and lex_lt l1 l2 = - match l1,l2 with - [],[] -> false - | [],_ -> assert false - | _, [] -> assert false - | a1::l1, a2::l2 when a1 = a2 -> lex_lt l1 l2 - | a1::_, a2::_ -> rpo_lt a1 a2 - -and check_lt l t = - List.fold_left - (fun b a -> b && (rpo_lt a t)) - true l -;; - -let rpo t1 t2 = - if rpo_lt t2 t1 then Gt - else if rpo_lt t1 t2 then Lt - else Incomparable - - -(*********************** fine rpo *****************************) - -(* (weight of constants, [(meta, weight_of_meta)]) *) -type weight = int * (int * int) list;; - -let string_of_weight (cw, mw) = - let s = - String.concat ", " - (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw) - in - Printf.sprintf "[%d; %s]" cw s - - -let weight_of_term ?(consider_metas=true) term = - let module C = Cic in - let vars_dict = Hashtbl.create 5 in - let rec aux = function - | C.Meta (metano, _) when consider_metas -> - (try - let oldw = Hashtbl.find vars_dict metano in - Hashtbl.replace vars_dict metano (oldw+1) - with Not_found -> - Hashtbl.add vars_dict metano 1); - 0 - | C.Meta _ -> 0 (* "variables" are lighter than constants and functions...*) - - | C.Var (_, ens) - | C.Const (_, ens) - | C.MutInd (_, _, ens) - | C.MutConstruct (_, _, _, ens) -> - List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens - - | C.Cast (t1, t2) - | C.Lambda (_, t1, t2) - | C.Prod (_, t1, t2) - | C.LetIn (_, t1, t2) -> - let w1 = aux t1 in - let w2 = aux t2 in - w1 + w2 + 1 - - | C.Appl l -> List.fold_left (+) 0 (List.map aux l) - - | C.MutCase (_, _, outt, t, pl) -> - let w1 = aux outt in - let w2 = aux t in - let w3 = List.fold_left (+) 0 (List.map aux pl) in - w1 + w2 + w3 + 1 - - | C.Fix (_, fl) -> - List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl - - | C.CoFix (_, fl) -> - List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl - - | _ -> 1 - in - let w = aux term in - let l = - Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in - let compare w1 w2 = - match w1, w2 with - | (m1, _), (m2, _) -> m2 - m1 - in - (w, List.sort compare l) (* from the biggest meta to the smallest (0) *) -;; - - -module OrderedInt = struct - type t = int - - let compare = Pervasives.compare -end - -module IntSet = Set.Make(OrderedInt) - -let compute_equality_weight ty left right = - let metasw = ref 0 in - let weight_of t = - let w, m = (weight_of_term ~consider_metas:true t) in - metasw := !metasw + (2 * (List.length m)); - w - in - (* Warning: the following let cannot be expanded since it forces the - right evaluation order!!!! *) - let w = (weight_of ty) + (weight_of left) + (weight_of right) in - w + !metasw -;; - - -(* returns a "normalized" version of the polynomial weight wl (with type - * weight list), i.e. a list sorted ascending by meta number, - * from 0 to maxmeta. wl must be sorted descending by meta number. Example: - * normalize_weight 5 (3, [(3, 2); (1, 1)]) -> - * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *) -let normalize_weight maxmeta (cw, wl) = - let rec aux = function - | 0 -> [] - | m -> (m, 0)::(aux (m-1)) - in - let tmpl = aux maxmeta in - let wl = - List.sort - (fun (m, _) (n, _) -> Pervasives.compare m n) - (List.fold_left - (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl) - in - (cw, wl) -;; - - -let normalize_weights (cw1, wl1) (cw2, wl2) = - let rec aux wl1 wl2 = - match wl1, wl2 with - | [], [] -> [], [] - | (m, w)::tl1, (n, w')::tl2 when m = n -> - let res1, res2 = aux tl1 tl2 in - (m, w)::res1, (n, w')::res2 - | (m, w)::tl1, ((n, w')::_ as wl2) when m < n -> - let res1, res2 = aux tl1 wl2 in - (m, w)::res1, (m, 0)::res2 - | ((m, w)::_ as wl1), (n, w')::tl2 when m > n -> - let res1, res2 = aux wl1 tl2 in - (n, 0)::res1, (n, w')::res2 - | [], (n, w)::tl2 -> - let res1, res2 = aux [] tl2 in - (n, 0)::res1, (n, w)::res2 - | (m, w)::tl1, [] -> - let res1, res2 = aux tl1 [] in - (m, w)::res1, (m, 0)::res2 - | _, _ -> assert false - in - let cmp (m, _) (n, _) = compare m n in - let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in - (cw1, wl1), (cw2, wl2) -;; - - -let compare_weights ?(normalize=false) - ((h1, w1) as weight1) ((h2, w2) as weight2)= - let (h1, w1), (h2, w2) = - if normalize then - normalize_weights weight1 weight2 - else - (h1, w1), (h2, w2) - in - let res, diffs = - try - List.fold_left2 - (fun ((lt, eq, gt), diffs) w1 w2 -> - match w1, w2 with - | (meta1, w1), (meta2, w2) when meta1 = meta2 -> - let diffs = (w1 - w2) + diffs in - let r = compare w1 w2 in - if r < 0 then (lt+1, eq, gt), diffs - else if r = 0 then (lt, eq+1, gt), diffs - else (lt, eq, gt+1), diffs - | (meta1, w1), (meta2, w2) -> - debug_print - (lazy - (Printf.sprintf "HMMM!!!! %s, %s\n" - (string_of_weight weight1) (string_of_weight weight2))); - assert false) - ((0, 0, 0), 0) w1 w2 - with Invalid_argument _ -> - debug_print - (lazy - (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n" - (string_of_weight (h1, w1)) (string_of_weight weight1) - (string_of_weight (h2, w2)) (string_of_weight weight2) - (string_of_bool normalize))); - assert false - in - let hdiff = h1 - h2 in - match res with - | (0, _, 0) -> - if hdiff < 0 then Lt - else if hdiff > 0 then Gt - else Eq (* Incomparable *) - | (m, _, 0) -> - if hdiff <= 0 then Lt - else if (- diffs) >= hdiff then Le else Incomparable - | (0, _, m) -> - if hdiff >= 0 then Gt - else if diffs >= (- hdiff) then Ge else Incomparable - | (m, _, n) when m > 0 && n > 0 -> - Incomparable - | _ -> assert false - -;; - - -let rec aux_ordering ?(recursion=true) t1 t2 = - let module C = Cic in - let compare_uris u1 u2 = - let res = - compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in - if res < 0 then Lt - else if res = 0 then Eq - else Gt - in - match t1, t2 with - | C.Meta _, _ - | _, C.Meta _ -> Incomparable - - | t1, t2 when t1 = t2 -> Eq - - | C.Rel n, C.Rel m -> if n > m then Lt else Gt - | C.Rel _, _ -> Lt - | _, C.Rel _ -> Gt - - | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2 - | C.Const _, _ -> Lt - | _, C.Const _ -> Gt - - | C.MutInd (u1, _, _), C.MutInd (u2, _, _) -> compare_uris u1 u2 - | C.MutInd _, _ -> Lt - | _, C.MutInd _ -> Gt - - | C.MutConstruct (u1, _, _, _), C.MutConstruct (u2, _, _, _) -> - compare_uris u1 u2 - | C.MutConstruct _, _ -> Lt - | _, C.MutConstruct _ -> Gt - - | C.Appl l1, C.Appl l2 when recursion -> - let rec cmp t1 t2 = - match t1, t2 with - | [], [] -> Eq - | _, [] -> Gt - | [], _ -> Lt - | hd1::tl1, hd2::tl2 -> - let o = aux_ordering hd1 hd2 in - if o = Eq then cmp tl1 tl2 - else o - in - cmp l1 l2 - | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion -> - aux_ordering h1 h2 - - | t1, t2 -> - debug_print - (lazy - (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n" - (CicPp.ppterm t1) (CicPp.ppterm t2))); - Incomparable -;; - - -(* w1, w2 are the weights, they should already be normalized... *) -let nonrec_kbo_w (t1, w1) (t2, w2) = - match compare_weights w1 w2 with - | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable - | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable - | Eq -> aux_ordering t1 t2 - | res -> res -;; - - -let nonrec_kbo t1 t2 = - let w1 = weight_of_term t1 in - let w2 = weight_of_term t2 in - (* - prerr_endline ("weight1 :"^(string_of_weight w1)); - prerr_endline ("weight2 :"^(string_of_weight w2)); - *) - match compare_weights ~normalize:true w1 w2 with - | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable - | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable - | Eq -> aux_ordering t1 t2 - | res -> res -;; - - -let rec kbo t1 t2 = - let aux = aux_ordering ~recursion:false in - let w1 = weight_of_term t1 - and w2 = weight_of_term t2 in - let rec cmp t1 t2 = - match t1, t2 with - | [], [] -> Eq - | _, [] -> Gt - | [], _ -> Lt - | hd1::tl1, hd2::tl2 -> - let o = - kbo hd1 hd2 - in - if o = Eq then cmp tl1 tl2 - else o - in - let comparison = compare_weights ~normalize:true w1 w2 in - match comparison with - | Le -> - let r = aux t1 t2 in - if r = Lt then Lt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Lt then Lt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Ge -> - let r = aux t1 t2 in - if r = Gt then Gt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Gt then Gt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Eq -> - let r = aux t1 t2 in - if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - cmp tl1 tl2 - | _, _ -> Incomparable - ) else r - | res -> res -;; - -let rec ao t1 t2 = - let get_hd t = - match t with - Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno) - | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) -> - Some(uri,tyno,cno) - | _ -> None in - let aux = aux_ordering ~recursion:false in - let w1 = weight_of_term t1 - and w2 = weight_of_term t2 in - let rec cmp t1 t2 = - match t1, t2 with - | [], [] -> Eq - | _, [] -> Gt - | [], _ -> Lt - | hd1::tl1, hd2::tl2 -> - let o = - ao hd1 hd2 - in - if o = Eq then cmp tl1 tl2 - else o - in - match get_hd t1, get_hd t2 with - Some(_),None -> Lt - | None,Some(_) -> Gt - | _ -> - let comparison = compare_weights ~normalize:true w1 w2 in - match comparison with - | Le -> - let r = aux t1 t2 in - if r = Lt then Lt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Lt then Lt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Ge -> - let r = aux t1 t2 in - if r = Gt then Gt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Gt then Gt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Eq -> - let r = aux t1 t2 in - if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - cmp tl1 tl2 - | _, _ -> Incomparable - ) else r - | res -> res -;; - -let names_of_context context = - List.map - (function - | None -> None - | Some (n, e) -> Some n) - context -;; - - -let rec lpo t1 t2 = - let module C = Cic in - match t1, t2 with - | t1, t2 when t1 = t2 -> Eq - | t1, (C.Meta _ as m) -> - if TermSet.mem m (metas_of_term t1) then Gt else Incomparable - | (C.Meta _ as m), t2 -> - if TermSet.mem m (metas_of_term t2) then Lt else Incomparable - | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> ( - let res = - let f o r t = - if r then true else - match lpo t o with - | Gt | Eq -> true - | _ -> false - in - let res1 = List.fold_left (f t2) false tl1 in - if res1 then Gt - else let res2 = List.fold_left (f t1) false tl2 in - if res2 then Lt - else Incomparable - in - if res <> Incomparable then - res - else - let f o r t = - if not r then false else - match lpo o t with - | Gt -> true - | _ -> false - in - match aux_ordering hd1 hd2 with - | Gt -> - let res = List.fold_left (f t1) false tl2 in - if res then Gt - else Incomparable - | Lt -> - let res = List.fold_left (f t2) false tl1 in - if res then Lt - else Incomparable - | Eq -> ( - let lex_res = - try - List.fold_left2 - (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2) - Eq tl1 tl2 - with Invalid_argument _ -> - Incomparable - in - match lex_res with - | Gt -> - if List.fold_left (f t1) false tl2 then Gt - else Incomparable - | Lt -> - if List.fold_left (f t2) false tl1 then Lt - else Incomparable - | _ -> Incomparable - ) - | _ -> Incomparable - ) - | t1, t2 -> aux_ordering t1 t2 -;; - - -(* settable by the user... *) -let compare_terms = ref nonrec_kbo;; -(* let compare_terms = ref ao;; *) -(* let compare_terms = ref rpo;; *) - -let guarded_simpl ?(debug=false) context t = - if !compare_terms == nonrec_kbo then t - else - let t' = ProofEngineReduction.simpl context t in - if t = t' then t else - begin - let simpl_order = !compare_terms t t' in - if debug then - prerr_endline ("comparing "^(CicPp.ppterm t)^(CicPp.ppterm t')); - if simpl_order = Gt then (if debug then prerr_endline "GT";t') - else (if debug then prerr_endline "NO_GT";t) - end -;; - -type equality_sign = Negative | Positive;; - -let string_of_sign = function - | Negative -> "Negative" - | Positive -> "Positive" -;; - - -type pos = Left | Right - -let string_of_pos = function - | Left -> "Left" - | Right -> "Right" -;; - - -let eq_ind_URI () = LibraryObjects.eq_ind_URI ~eq:(LibraryObjects.eq_URI ()) -let eq_ind_r_URI () = LibraryObjects.eq_ind_r_URI ~eq:(LibraryObjects.eq_URI ()) -let sym_eq_URI () = LibraryObjects.sym_eq_URI ~eq:(LibraryObjects.eq_URI ()) -let eq_XURI () = - let s = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (s ^ "#xpointer(1/1/1)") -let trans_eq_URI () = LibraryObjects.trans_eq_URI ~eq:(LibraryObjects.eq_URI ()) diff --git a/helm/ocaml/tactics/paramodulation/utils.mli b/helm/ocaml/tactics/paramodulation/utils.mli deleted file mode 100644 index ce14d480f..000000000 --- a/helm/ocaml/tactics/paramodulation/utils.mli +++ /dev/null @@ -1,84 +0,0 @@ -(* Copyright (C) 2005, 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/. - *) - -(* (weight of constants, [(meta, weight_of_meta)]) *) -type weight = int * (int * int) list;; - -type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; - -val print_metasenv: Cic.metasenv -> string - -val print_subst: ?prefix:string -> Cic.substitution -> string - -val string_of_weight: weight -> string - -val weight_of_term: ?consider_metas:bool -> Cic.term -> weight - -val normalize_weight: int -> weight -> weight - -val string_of_comparison: comparison -> string - -val compare_weights: ?normalize:bool -> weight -> weight -> comparison - -val nonrec_kbo: Cic.term -> Cic.term -> comparison - -val rpo: Cic.term -> Cic.term -> comparison - -val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison - -val names_of_context: Cic.context -> (Cic.name option) list - -module TermMap: Map.S with type key = Cic.term - -val symbols_of_term: Cic.term -> int TermMap.t - -val lpo: Cic.term -> Cic.term -> comparison - -val kbo: Cic.term -> Cic.term -> comparison - -val ao: Cic.term -> Cic.term -> comparison - -(** term-ordering function settable by the user *) -val compare_terms: (Cic.term -> Cic.term -> comparison) ref - -val guarded_simpl: ?debug:bool -> Cic.context -> Cic.term -> Cic.term - -type equality_sign = Negative | Positive - -val string_of_sign: equality_sign -> string - -type pos = Left | Right - -val string_of_pos: pos -> string - -val compute_equality_weight: Cic.term -> Cic.term -> Cic.term -> int - -val debug_print: string Lazy.t -> unit - -val eq_ind_URI: unit -> UriManager.uri -val eq_ind_r_URI: unit -> UriManager.uri -val sym_eq_URI: unit -> UriManager.uri -val eq_XURI: unit -> UriManager.uri -val trans_eq_URI: unit -> UriManager.uri diff --git a/helm/ocaml/tactics/primitiveTactics.ml b/helm/ocaml/tactics/primitiveTactics.ml deleted file mode 100644 index 7a732a572..000000000 --- a/helm/ocaml/tactics/primitiveTactics.ml +++ /dev/null @@ -1,567 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open ProofEngineHelpers -open ProofEngineTypes - -exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple -exception NotAnInductiveTypeToEliminate -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. *) -(* howmany = -1 means Intros, howmany > 0 means Intros n *) -let lambda_abstract ?(howmany=(-1)) metasenv context newmeta ty mk_fresh_name = - let module C = Cic in - let rec collect_context context howmany ty = - match howmany with - | 0 -> - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - context, ty, (C.Meta (newmeta,irl)) - | _ -> - match ty with - C.Cast (te,_) -> collect_context context howmany te - | C.Prod (n,s,t) -> - let n' = mk_fresh_name metasenv context n ~typ:s in - let (context',ty,bo) = - collect_context ((Some (n',(C.Decl s)))::context) (howmany - 1) 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,None))))::context) (howmany - 1) t - in - (context',ty,C.LetIn(n,s,bo)) - | _ as t -> - if howmany <= 0 then - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - context, t, (C.Meta (newmeta,irl)) - else - raise (Fail (lazy "intro(s): not enough products or let-ins")) - in - collect_context context howmany 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 (i,l) -> - let l' = - List.map (function None -> None | Some t -> Some (aux n t)) l - in - C.Meta (i, l') - | 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 CicUniv.empty_ugraph (* TASSI: FIXME *) - in - let fresh_name = - FreshNamesGenerator.mk_fresh_name ~subst:[] - metasenv 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,None)) -> - Some (n,Cic.Def ((subst_in canonical_context' s),None)) - | None -> None - | Some (n,Cic.Def (bo,Some ty)) -> - Some - (n, - Cic.Def - (subst_in canonical_context' bo, - Some (subst_in canonical_context' ty))) - 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 ([],[]) - -(* 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 = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - CicUtil.params_of_obj o - 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 = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.Variable (_,_,ty,_,_) -> - CicSubstitution.subst_vars !exp_named_subst_diff ty - | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri)) - in -(* CSC: patch to generate ?1 : ?2 : Type in place of ?1 : Type to simulate ?1 :< Type - (match ty with - C.Sort (C.Type _) as s -> (* TASSI: ?? *) - let fresh_meta = !next_fresh_meta in - let fresh_meta' = fresh_meta + 1 in - next_fresh_meta := !next_fresh_meta + 2 ; - let subst_item = uri,C.Meta (fresh_meta',[]) in - newmetasenvfragment := - (fresh_meta,[],C.Sort (C.Type (CicUniv.fresh()))) :: - (* TASSI: ?? *) - (fresh_meta',[],C.Meta (fresh_meta,[])) :: !newmetasenvfragment ; - exp_named_subst_diff := !exp_named_subst_diff @ [subst_item] ; - subst_item::(aux (tl,[])) - | _ -> -*) - let irl = - CicMkImplicit.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 - new_fresh_meta,newmetasenvfragment,exp_named_subst',exp_named_subst_diff -;; - -let new_metasenv_and_unify_and_t newmeta' metasenv' context term' ty termty goal_arity = - let (consthead,newmetasenv,arguments,_) = - saturate_term newmeta' metasenv' context termty goal_arity in - let subst,newmetasenv',_ = - CicUnification.fo_unif newmetasenv context consthead ty CicUniv.empty_ugraph - in - let t = - if List.length arguments = 0 then term' else Cic.Appl (term'::arguments) - in - subst,newmetasenv',t - -let rec count_prods context ty = - match CicReduction.whd context ty with - Cic.Prod (n,s,t) -> 1 + count_prods (Some (n,Cic.Decl s)::context) t - | _ -> 0 - -let apply_tac_verbose_with_subst ~term (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 = CicUtil.lookup_meta goal metasenv in - let newmeta = new_meta_of_proof ~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 - let termty,_ = - CicTypeChecker.type_of_aux' metasenv' context term' CicUniv.empty_ugraph - in - let termty = - CicSubstitution.subst_vars exp_named_subst_diff termty in - let goal_arity = count_prods context ty in - let subst,newmetasenv',t = - let rec add_one_argument n = - try - new_metasenv_and_unify_and_t newmeta' metasenv' context term' ty - termty n - with CicUnification.UnificationFailure _ when n > 0 -> - add_one_argument (n - 1) - in - add_one_argument goal_arity - in - let in_subst_domain i = List.exists (function (j,_) -> i=j) subst in - let apply_subst = CicMetaSubst.apply_subst subst in - let old_uninstantiatedmetas,new_uninstantiatedmetas = - (* subst_in doesn't need the context. Hence the underscore. *) - let subst_in _ = CicMetaSubst.apply_subst subst in - classify_metas newmeta in_subst_domain subst_in newmetasenv' - in - let bo' = apply_subst t in - let newmetasenv'' = new_uninstantiatedmetas@old_uninstantiatedmetas in - let subst_in = - (* if we just apply the subtitution, the type is irrelevant: - we may use Implicit, since it will be dropped *) - CicMetaSubst.apply_subst ((metano,(context,bo',Cic.Implicit None))::subst) - in - let (newproof, newmetasenv''') = - subst_meta_and_metasenv_in_proof proof metano subst_in newmetasenv'' - in - (((metano,(context,bo',Cic.Implicit None))::subst)(* subst_in *), (* ALB *) - (newproof, - List.map (function (i,_,_) -> i) new_uninstantiatedmetas)) - - -(* ALB *) -let apply_tac_verbose_with_subst ~term status = - try -(* apply_tac_verbose ~term status *) - apply_tac_verbose_with_subst ~term status - (* TODO cacciare anche altre eccezioni? *) - with - | CicUnification.UnificationFailure msg - | CicTypeChecker.TypeCheckerFailure msg -> - raise (Fail msg) - -(* ALB *) -let apply_tac_verbose ~term status = - let subst, status = apply_tac_verbose_with_subst ~term status in - (CicMetaSubst.apply_subst subst), status - -let apply_tac ~term status = snd (apply_tac_verbose ~term status) - - (* TODO per implementare i tatticali e' necessario che tutte le tattiche - sollevino _solamente_ Fail *) -let apply_tac ~term = - let apply_tac ~term status = - try - apply_tac ~term status - (* TODO cacciare anche altre eccezioni? *) - with - | CicUnification.UnificationFailure msg - | CicTypeChecker.TypeCheckerFailure msg -> - raise (Fail msg) - in - mk_tactic (apply_tac ~term) - -let intros_tac ?howmany ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) ()= - let intros_tac - ?(mk_fresh_name_callback = (FreshNamesGenerator.mk_fresh_name ~subst:[])) () - (proof, goal) - = - let module C = Cic in - let module R = CicReduction in - let (_,metasenv,_,_) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let newmeta = new_meta_of_proof ~proof in - let (context',ty',bo') = - lambda_abstract ?howmany metasenv context newmeta ty mk_fresh_name_callback - in - let (newproof, _) = - subst_meta_in_proof proof metano bo' [newmeta,context',ty'] - in - (newproof, [newmeta]) - in - mk_tactic (intros_tac ~mk_fresh_name_callback ()) - -let cut_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) term = - let cut_tac - ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - term (proof, goal) - = - let module C = Cic in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let newmeta1 = new_meta_of_proof ~proof in - let newmeta2 = newmeta1 + 1 in - let fresh_name = - mk_fresh_name_callback metasenv context (Cic.Name "Hcut") ~typ:term in - let context_for_newmeta1 = - (Some (fresh_name,C.Decl term))::context in - let irl1 = - CicMkImplicit.identity_relocation_list_for_metavariable - context_for_newmeta1 - in - let irl2 = - CicMkImplicit.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]) - in - mk_tactic (cut_tac ~mk_fresh_name_callback term) - -let letin_tac ?(mk_fresh_name_callback=FreshNamesGenerator.mk_fresh_name ~subst:[]) term = - let letin_tac - ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - term (proof, goal) - = - let module C = Cic in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let _,_ = (* TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in - let newmeta = new_meta_of_proof ~proof in - let fresh_name = - mk_fresh_name_callback metasenv context (Cic.Name "Hletin") ~typ:term in - let context_for_newmeta = - (Some (fresh_name,C.Def (term,None)))::context in - let irl = - CicMkImplicit.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]) - in - mk_tactic (letin_tac ~mk_fresh_name_callback term) - - (** functional part of the "exact" tactic *) -let exact_tac ~term = - let exact_tac ~term (proof, goal) = - (* Assumption: the term bo must be closed in the current context *) - let (_,metasenv,_,_) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let module T = CicTypeChecker in - let module R = CicReduction in - let ty_term,u = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in - let b,_ = R.are_convertible context ty_term ty u in (* TASSI: FIXME *) - if b then - begin - let (newproof, metasenv') = - subst_meta_in_proof proof metano term [] in - (newproof, []) - end - else - raise (Fail (lazy "The type of the provided term is not the one expected.")) - in - mk_tactic (exact_tac ~term) - -(* not really "primitive" tactics .... *) -let elim_tac ~term = - let elim_tac ~term (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,proofbo,proofty) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in - let (termty,metasenv',arguments,fresh_meta) = - ProofEngineHelpers.saturate_term - (ProofEngineHelpers.new_meta_of_proof proof) metasenv context termty 0 in - let term = if arguments = [] then term else Cic.Appl (term::arguments) 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 = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tys,_,_,_) -> - let (name,_,_,_) = List.nth tys typeno in - name - | _ -> assert false - in - let ty_ty,_ = T.type_of_aux' metasenv' context ty CicUniv.empty_ugraph in - let ext = - match ty_ty with - C.Sort C.Prop -> "_ind" - | C.Sort C.Set -> "_rec" - | C.Sort C.CProp -> "_rec" - | C.Sort (C.Type _)-> "_rect" - | C.Meta (_,_) -> raise TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple - | _ -> 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 CicUniv.empty_ugraph in - let rec find_args_no = - function - C.Prod (_,_,t) -> 1 + find_args_no t - | C.Cast (s,_) -> find_args_no s - | C.LetIn (_,_,t) -> 0 + find_args_no t - | _ -> 0 - in - let args_no = find_args_no ety in - let term_to_refine = - let rec make_tl base_case = - function - 0 -> [base_case] - | n -> (C.Implicit None)::(make_tl base_case (n - 1)) - in - C.Appl (eliminator_ref :: make_tl term (args_no - 1)) - in - let refined_term,_,metasenv'',_ = - CicRefine.type_of_aux' metasenv' context term_to_refine - CicUniv.empty_ugraph - in - let new_goals = - ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:metasenv'' - in - let proof' = curi,metasenv'',proofbo,proofty in - let proof'', new_goals' = - apply_tactic (apply_tac ~term:refined_term) (proof',goal) - in - (* The apply_tactic can have closed some of the new_goals *) - let patched_new_goals = - let (_,metasenv''',_,_) = proof'' in - List.filter - (function i -> List.exists (function (j,_,_) -> j=i) metasenv''' - ) new_goals @ new_goals' - in - proof'', patched_new_goals - in - mk_tactic (elim_tac ~term) -;; - -let elim_intros_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - ?depth ?using what = - Tacticals.then_ ~start:(elim_tac ~term:what) - ~continuation:(intros_tac ~mk_fresh_name_callback ?howmany:depth ()) -;; - -(* The simplification is performed only on the conclusion *) -let elim_intros_simpl_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - ?depth ?using what = - Tacticals.then_ ~start:(elim_tac ~term:what) - ~continuation: - (Tacticals.thens - ~start:(intros_tac ~mk_fresh_name_callback ?howmany:depth ()) - ~continuations: - [ReductionTactics.simpl_tac - ~pattern:(ProofEngineTypes.conclusion_pattern None)]) -;; diff --git a/helm/ocaml/tactics/primitiveTactics.mli b/helm/ocaml/tactics/primitiveTactics.mli deleted file mode 100644 index 01d200eb7..000000000 --- a/helm/ocaml/tactics/primitiveTactics.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* 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/. - *) - -(* ALB, needed by the new paramodulation... *) -val apply_tac_verbose_with_subst: - term:Cic.term -> ProofEngineTypes.proof * int -> - Cic.substitution * (ProofEngineTypes.proof * int list) - -(* not a real tactic *) -val apply_tac_verbose : - term:Cic.term -> - ProofEngineTypes.proof * int -> - (Cic.term -> Cic.term) * (ProofEngineTypes.proof * int list) - -val apply_tac: - term: Cic.term -> ProofEngineTypes.tactic -val exact_tac: - term: Cic.term -> ProofEngineTypes.tactic -val intros_tac: - ?howmany:int -> - ?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: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic -val elim_intros_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/proofEngineHelpers.ml b/helm/ocaml/tactics/proofEngineHelpers.ml deleted file mode 100644 index cf7df2d58..000000000 --- a/helm/ocaml/tactics/proofEngineHelpers.ml +++ /dev/null @@ -1,688 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -exception Bad_pattern of string Lazy.t - -let new_meta_of_proof ~proof:(_, metasenv, _, _) = - CicMkImplicit.new_meta metasenv [] - -let subst_meta_in_proof proof meta term newmetasenv = - let uri,metasenv,bo,ty = proof in - (* empty context is ok for term since it wont be used by apply_subst *) - (* hack: since we do not know the context and the type of term, we - create a substitution with cc =[] and type = Implicit; they will be - in any case dropped by apply_subst, but it would be better to rewrite - the code. Cannot we just use apply_subst_metasenv, etc. ?? *) - let subst_in = CicMetaSubst.apply_subst [meta,([], term,Cic.Implicit None)] 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,None)) -> Some (n,Cic.Def (subst_in s,None)) - | None -> None - | Some (n,Cic.Def (bo,Some ty)) -> - Some (n,Cic.Def (subst_in bo,Some (subst_in ty))) - ) canonical_context - in - i,canonical_context',(subst_in ty) - ) metasenv' - in - let bo' = subst_in bo in - (* Metavariables can appear also in the *statement* of the theorem - * since the parser does not reject as statements terms with - * metavariable therein *) - let ty' = subst_in ty 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 - (* Metavariables can appear also in the *statement* of the theorem - * since the parser does not reject as statements terms with - * metavariable therein *) - let ty' = subst_in ty 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,None)) -> - Some (i,Cic.Def (subst_in t,None)) - | Some (i,Cic.Def (bo,Some ty)) -> - Some (i,Cic.Def (subst_in bo,Some (subst_in ty))) - ) canonical_context - in - (m,canonical_context',subst_in ty)::i - | _ -> i - ) newmetasenv [] - in - let newproof = uri,metasenv',bo',ty' in - (newproof, metasenv') - -let compare_metasenvs ~oldmetasenv ~newmetasenv = - List.map (function (i,_,_) -> i) - (List.filter - (function (i,_,_) -> - not (List.exists (fun (j,_,_) -> i=j) oldmetasenv)) newmetasenv) -;; - -(** finds the _pointers_ to subterms that are alpha-equivalent to wanted in t *) -let find_subterms ~subst ~metasenv ~ugraph ~wanted ~context t = - let rec find subst metasenv ugraph context w t = - try - let subst,metasenv,ugraph = - CicUnification.fo_unif_subst subst context metasenv w t ugraph - in - subst,metasenv,ugraph,[context,t] - with - CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - match t with - | Cic.Sort _ - | Cic.Rel _ -> subst,metasenv,ugraph,[] - | Cic.Meta (_, ctx) -> - List.fold_left ( - fun (subst,metasenv,ugraph,acc) e -> - match e with - | None -> subst,metasenv,ugraph,acc - | Some t -> - let subst,metasenv,ugraph,res = - find subst metasenv ugraph context w t - in - subst,metasenv,ugraph, res @ acc - ) (subst,metasenv,ugraph,[]) ctx - | Cic.Lambda (name, t1, t2) - | Cic.Prod (name, t1, t2) -> - let subst,metasenv,ugraph,rest1 = - find subst metasenv ugraph context w t1 in - let subst,metasenv,ugraph,rest2 = - find subst metasenv ugraph (Some (name, Cic.Decl t1)::context) - (CicSubstitution.lift 1 w) t2 - in - subst,metasenv,ugraph,rest1 @ rest2 - | Cic.LetIn (name, t1, t2) -> - let subst,metasenv,ugraph,rest1 = - find subst metasenv ugraph context w t1 in - let subst,metasenv,ugraph,rest2 = - find subst metasenv ugraph (Some (name, Cic.Def (t1,None))::context) - (CicSubstitution.lift 1 w) t2 - in - subst,metasenv,ugraph,rest1 @ rest2 - | Cic.Appl l -> - List.fold_left - (fun (subst,metasenv,ugraph,acc) t -> - let subst,metasenv,ugraph,res = - find subst metasenv ugraph context w t - in - subst,metasenv,ugraph,res @ acc) - (subst,metasenv,ugraph,[]) l - | Cic.Cast (t, ty) -> - let subst,metasenv,ugraph,rest = - find subst metasenv ugraph context w t in - let subst,metasenv,ugraph,resty = - find subst metasenv ugraph context w ty - in - subst,metasenv,ugraph,rest @ resty - | Cic.Implicit _ -> assert false - | Cic.Const (_, esubst) - | Cic.Var (_, esubst) - | Cic.MutInd (_, _, esubst) - | Cic.MutConstruct (_, _, _, esubst) -> - List.fold_left - (fun (subst,metasenv,ugraph,acc) (_, t) -> - let subst,metasenv,ugraph,res = - find subst metasenv ugraph context w t - in - subst,metasenv,ugraph,res @ acc) - (subst,metasenv,ugraph,[]) esubst - | Cic.MutCase (_, _, outty, indterm, patterns) -> - let subst,metasenv,ugraph,resoutty = - find subst metasenv ugraph context w outty in - let subst,metasenv,ugraph,resindterm = - find subst metasenv ugraph context w indterm in - let subst,metasenv,ugraph,respatterns = - List.fold_left - (fun (subst,metasenv,ugraph,acc) p -> - let subst,metaseng,ugraph,res = - find subst metasenv ugraph context w p - in - subst,metasenv,ugraph,res @ acc - ) (subst,metasenv,ugraph,[]) patterns - in - subst,metasenv,ugraph,resoutty @ resindterm @ respatterns - | Cic.Fix (_, funl) -> - let tys = - List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funl - in - List.fold_left ( - fun (subst,metasenv,ugraph,acc) (_, _, ty, bo) -> - let subst,metasenv,ugraph,resty = - find subst metasenv ugraph context w ty in - let subst,metasenv,ugraph,resbo = - find subst metasenv ugraph (tys @ context) w bo - in - subst,metasenv,ugraph, resty @ resbo @ acc - ) (subst,metasenv,ugraph,[]) funl - | Cic.CoFix (_, funl) -> - let tys = - List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funl - in - List.fold_left ( - fun (subst,metasenv,ugraph,acc) (_, ty, bo) -> - let subst,metasenv,ugraph,resty = - find subst metasenv ugraph context w ty in - let subst,metasenv,ugraph,resbo = - find subst metasenv ugraph (tys @ context) w bo - in - subst,metasenv,ugraph, resty @ resbo @ acc - ) (subst,metasenv,ugraph,[]) funl - in - find subst metasenv ugraph context wanted t - -let select_in_term ~metasenv ~context ~ugraph ~term ~pattern:(wanted,where) = - let add_ctx context name entry = (Some (name, entry)) :: context in - let map2 error_msg f l1 l2 = - try - List.map2 f l1 l2 - with - | Invalid_argument _ -> raise (Bad_pattern (lazy error_msg)) - in - let rec aux context where term = - match (where, term) with - | Cic.Implicit (Some `Hole), t -> [context,t] - | Cic.Implicit (Some `Type), t -> [] - | Cic.Implicit None,_ -> [] - | Cic.Meta (_, ctxt1), Cic.Meta (_, ctxt2) -> - List.concat - (map2 "wrong number of argument in explicit substitution" - (fun t1 t2 -> - (match (t1, t2) with - Some t1, Some t2 -> aux context t1 t2 - | _ -> [])) - ctxt1 ctxt2) - | Cic.Cast (te1, ty1), Cic.Cast (te2, ty2) -> - aux context te1 te2 @ aux context ty1 ty2 - | Cic.Prod (Cic.Anonymous, s1, t1), Cic.Prod (name, s2, t2) - | Cic.Lambda (Cic.Anonymous, s1, t1), Cic.Lambda (name, s2, t2) -> - aux context s1 s2 @ aux (add_ctx context name (Cic.Decl s2)) t1 t2 - | Cic.Prod (Cic.Name n1, s1, t1), - Cic.Prod ((Cic.Name n2) as name , s2, t2) - | Cic.Lambda (Cic.Name n1, s1, t1), - Cic.Lambda ((Cic.Name n2) as name, s2, t2) when n1 = n2-> - aux context s1 s2 @ aux (add_ctx context name (Cic.Decl s2)) t1 t2 - | Cic.Prod (name1, s1, t1), Cic.Prod (name2, s2, t2) - | Cic.Lambda (name1, s1, t1), Cic.Lambda (name2, s2, t2) -> [] - | Cic.LetIn (Cic.Anonymous, s1, t1), Cic.LetIn (name, s2, t2) -> - aux context s1 s2 @ aux (add_ctx context name (Cic.Def (s2,None))) t1 t2 - | Cic.LetIn (Cic.Name n1, s1, t1), - Cic.LetIn ((Cic.Name n2) as name, s2, t2) when n1 = n2-> - aux context s1 s2 @ aux (add_ctx context name (Cic.Def (s2,None))) t1 t2 - | Cic.LetIn (name1, s1, t1), Cic.LetIn (name2, s2, t2) -> [] - | Cic.Appl terms1, Cic.Appl terms2 -> auxs context terms1 terms2 - | Cic.Var (_, subst1), Cic.Var (_, subst2) - | Cic.Const (_, subst1), Cic.Const (_, subst2) - | Cic.MutInd (_, _, subst1), Cic.MutInd (_, _, subst2) - | Cic.MutConstruct (_, _, _, subst1), Cic.MutConstruct (_, _, _, subst2) -> - auxs context (List.map snd subst1) (List.map snd subst2) - | Cic.MutCase (_, _, out1, t1, pat1), Cic.MutCase (_ , _, out2, t2, pat2) -> - aux context out1 out2 @ aux context t1 t2 @ auxs context pat1 pat2 - | Cic.Fix (_, funs1), Cic.Fix (_, funs2) -> - let tys = - List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs2 - in - List.concat - (map2 "wrong number of mutually recursive functions" - (fun (_, _, ty1, bo1) (_, _, ty2, bo2) -> - aux context ty1 ty2 @ aux (tys @ context) bo1 bo2) - funs1 funs2) - | Cic.CoFix (_, funs1), Cic.CoFix (_, funs2) -> - let tys = - List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs2 - in - List.concat - (map2 "wrong number of mutually co-recursive functions" - (fun (_, ty1, bo1) (_, ty2, bo2) -> - aux context ty1 ty2 @ aux (tys @ context) bo1 bo2) - funs1 funs2) - | x,y -> - raise (Bad_pattern - (lazy (Printf.sprintf "Pattern %s versus term %s" - (CicPp.ppterm x) - (CicPp.ppterm y)))) - and auxs context terms1 terms2 = (* as aux for list of terms *) - List.concat (map2 "wrong number of arguments in application" - (fun t1 t2 -> aux context t1 t2) terms1 terms2) - in - let roots = - match where with - | None -> [] - | Some where -> aux context where term - in - match wanted with - None -> [],metasenv,ugraph,roots - | Some wanted -> - let rec find_in_roots = - function - [] -> [],metasenv,ugraph,[] - | (context',where)::tl -> - let subst,metasenv,ugraph,tl' = find_in_roots tl in - let subst,metasenv,ugraph,found = - let wanted, metasenv, ugraph = wanted context' metasenv ugraph in - find_subterms ~subst ~metasenv ~ugraph ~wanted ~context:context' - where - in - subst,metasenv,ugraph,found @ tl' - in - find_in_roots roots - -(** create a pattern from a term and a list of subterms. -* the pattern is granted to have a ? for every subterm that has no selected -* subterms -* @param equality equality function used while walking the term. Defaults to -* physical equality (==) *) -let pattern_of ?(equality=(==)) ~term terms = - let (===) x y = equality x y in - let not_found = false, Cic.Implicit None in - let rec aux t = - match t with - | t when List.exists (fun t' -> t === t') terms -> - true,Cic.Implicit (Some `Hole) - | Cic.Var (uri, subst) -> - let b,subst = aux_subst subst in - if b then - true,Cic.Var (uri, subst) - else - not_found - | Cic.Meta (i, ctxt) -> - let b,ctxt = - List.fold_right - (fun e (b,ctxt) -> - match e with - None -> b,None::ctxt - | Some t -> let bt,t = aux t in b||bt ,Some t::ctxt - ) ctxt (false,[]) - in - if b then - true,Cic.Meta (i, ctxt) - else - not_found - | Cic.Cast (te, ty) -> - let b1,te = aux te in - let b2,ty = aux ty in - if b1||b2 then true,Cic.Cast (te, ty) - else - not_found - | Cic.Prod (name, s, t) -> - let b1,s = aux s in - let b2,t = aux t in - if b1||b2 then - true, Cic.Prod (name, s, t) - else - not_found - | Cic.Lambda (name, s, t) -> - let b1,s = aux s in - let b2,t = aux t in - if b1||b2 then - true, Cic.Lambda (name, s, t) - else - not_found - | Cic.LetIn (name, s, t) -> - let b1,s = aux s in - let b2,t = aux t in - if b1||b2 then - true, Cic.LetIn (name, s, t) - else - not_found - | Cic.Appl terms -> - let b,terms = - List.fold_right - (fun t (b,terms) -> - let bt,t = aux t in - b||bt,t::terms - ) terms (false,[]) - in - if b then - true,Cic.Appl terms - else - not_found - | Cic.Const (uri, subst) -> - let b,subst = aux_subst subst in - if b then - true, Cic.Const (uri, subst) - else - not_found - | Cic.MutInd (uri, tyno, subst) -> - let b,subst = aux_subst subst in - if b then - true, Cic.MutInd (uri, tyno, subst) - else - not_found - | Cic.MutConstruct (uri, tyno, consno, subst) -> - let b,subst = aux_subst subst in - if b then - true, Cic.MutConstruct (uri, tyno, consno, subst) - else - not_found - | Cic.MutCase (uri, tyno, outty, t, pat) -> - let b1,outty = aux outty in - let b2,t = aux t in - let b3,pat = - List.fold_right - (fun t (b,pat) -> - let bt,t = aux t in - bt||b,t::pat - ) pat (false,[]) - in - if b1 || b2 || b3 then - true, Cic.MutCase (uri, tyno, outty, t, pat) - else - not_found - | Cic.Fix (funno, funs) -> - let b,funs = - List.fold_right - (fun (name, i, ty, bo) (b,funs) -> - let b1,ty = aux ty in - let b2,bo = aux bo in - b||b1||b2, (name, i, ty, bo)::funs) funs (false,[]) - in - if b then - true, Cic.Fix (funno, funs) - else - not_found - | Cic.CoFix (funno, funs) -> - let b,funs = - List.fold_right - (fun (name, ty, bo) (b,funs) -> - let b1,ty = aux ty in - let b2,bo = aux bo in - b||b1||b2, (name, ty, bo)::funs) funs (false,[]) - in - if b then - true, Cic.CoFix (funno, funs) - else - not_found - | Cic.Rel _ - | Cic.Sort _ - | Cic.Implicit _ -> not_found - and aux_subst subst = - List.fold_right - (fun (uri, t) (b,subst) -> - let b1,t = aux t in - b||b1,(uri, t)::subst) subst (false,[]) - in - snd (aux term) - -exception Fail of string Lazy.t - - (** select metasenv conjecture pattern - * select all subterms of [conjecture] matching [pattern]. - * It returns the set of matched terms (that can be compared using physical - * equality to the subterms of [conjecture]) together with their contexts. - * The representation of the set mimics the ProofEngineTypes.pattern type: - * a list of hypothesis (names of) together with the list of its matched - * subterms (and their contexts) + the list of matched subterms of the - * with their context conclusion. Note: in the result the list of hypothesis - * has an entry for each entry in the context and in the same order. - * Of course the list of terms (with their context) associated to the - * hypothesis name may be empty. - * - * @raise Bad_pattern - * *) - let select ~metasenv ~ugraph ~conjecture:(_,context,ty) - ~(pattern: (Cic.term, Cic.lazy_term) ProofEngineTypes.pattern) - = - let what, hyp_patterns, goal_pattern = pattern in - let find_pattern_for name = - try Some (snd (List.find (fun (n, pat) -> Cic.Name n = name) hyp_patterns)) - with Not_found -> None in - let subst,metasenv,ugraph,ty_terms = - select_in_term ~metasenv ~context ~ugraph ~term:ty - ~pattern:(what,goal_pattern) in - let subst,metasenv,ugraph,context_terms = - let subst,metasenv,ugraph,res,_ = - (List.fold_right - (fun entry (subst,metasenv,ugraph,res,context) -> - match entry with - None -> subst,metasenv,ugraph,(None::res),(None::context) - | Some (name,Cic.Decl term) -> - (match find_pattern_for name with - | None -> - subst,metasenv,ugraph,((Some (`Decl []))::res),(entry::context) - | Some pat -> - let subst,metasenv,ugraph,terms = - select_in_term ~metasenv ~context ~ugraph ~term - ~pattern:(what, Some pat) - in - subst,metasenv,ugraph,((Some (`Decl terms))::res), - (entry::context)) - | Some (name,Cic.Def (bo, ty)) -> - (match find_pattern_for name with - | None -> - let selected_ty=match ty with None -> None | Some _ -> Some [] in - subst,metasenv,ugraph,((Some (`Def ([],selected_ty)))::res), - (entry::context) - | Some pat -> - let subst,metasenv,ugraph,terms_bo = - select_in_term ~metasenv ~context ~ugraph ~term:bo - ~pattern:(what, Some pat) in - let subst,metasenv,ugraph,terms_ty = - match ty with - None -> subst,metasenv,ugraph,None - | Some ty -> - let subst,metasenv,ugraph,res = - select_in_term ~metasenv ~context ~ugraph ~term:ty - ~pattern:(what, Some pat) - in - subst,metasenv,ugraph,Some res - in - subst,metasenv,ugraph,((Some (`Def (terms_bo,terms_ty)))::res), - (entry::context)) - ) context (subst,metasenv,ugraph,[],[])) - in - subst,metasenv,ugraph,res - in - subst,metasenv,ugraph,context_terms, ty_terms - -(** locate_in_term equality what where context -* [what] must match a subterm of [where] according to [equality] -* It returns the matched terms together with their contexts in [where] -* [equality] defaults to physical equality -* [context] must be the context of [where] -*) -let locate_in_term ?(equality=(fun _ -> (==))) what ~where context = - let add_ctx context name entry = - (Some (name, entry)) :: context in - let rec aux context where = - if equality context what where then [context,where] - else - match where with - | Cic.Implicit _ - | Cic.Meta _ - | Cic.Rel _ - | Cic.Sort _ - | Cic.Var _ - | Cic.Const _ - | Cic.MutInd _ - | Cic.MutConstruct _ -> [] - | Cic.Cast (te, ty) -> aux context te @ aux context ty - | Cic.Prod (name, s, t) - | Cic.Lambda (name, s, t) -> - aux context s @ aux (add_ctx context name (Cic.Decl s)) t - | Cic.LetIn (name, s, t) -> - aux context s @ aux (add_ctx context name (Cic.Def (s,None))) t - | Cic.Appl tl -> auxs context tl - | Cic.MutCase (_, _, out, t, pat) -> - aux context out @ aux context t @ auxs context pat - | Cic.Fix (_, funs) -> - let tys = - List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs - in - List.concat - (List.map - (fun (_, _, ty, bo) -> - aux context ty @ aux (tys @ context) bo) - funs) - | Cic.CoFix (_, funs) -> - let tys = - List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs - in - List.concat - (List.map - (fun (_, ty, bo) -> - aux context ty @ aux (tys @ context) bo) - funs) - and auxs context tl = (* as aux for list of terms *) - List.concat (List.map (fun t -> aux context t) tl) - in - aux context where - -(** locate_in_conjecture equality what where context -* [what] must match a subterm of [where] according to [equality] -* It returns the matched terms together with their contexts in [where] -* [equality] defaults to physical equality -* [context] must be the context of [where] -*) -let locate_in_conjecture ?(equality=fun _ -> (==)) what (_,context,ty) = - let context,res = - List.fold_right - (fun entry (context,res) -> - match entry with - None -> entry::context, res - | Some (_, Cic.Decl ty) -> - let res = res @ locate_in_term what ~where:ty context in - let context' = entry::context in - context',res - | Some (_, Cic.Def (bo,ty)) -> - let res = res @ locate_in_term what ~where:bo context in - let res = - match ty with - None -> res - | Some ty -> - res @ locate_in_term what ~where:ty context in - let context' = entry::context in - context',res - ) context ([],[]) - in - res @ locate_in_term what ~where:ty context - -(* saturate_term newmeta metasenv context ty goal_arity *) -(* Given a type [ty] (a backbone), it returns its suffix of length *) -(* [goal_arity] head and a new metasenv in which there is new a META for each *) -(* hypothesis, a list of arguments for the new applications and the index of *) -(* the last new META introduced. The nth argument in the list of arguments is *) -(* just the nth new META. *) -let saturate_term newmeta metasenv context ty goal_arity = - let module C = Cic in - let module S = CicSubstitution in - assert (goal_arity >= 0); - let rec aux newmeta ty = - match ty with - C.Cast (he,_) -> aux newmeta he -(* CSC: patch to generate ?1 : ?2 : Type in place of ?1 : Type to simulate ?1 :< Type - (* If the expected type is a Type, then also Set is OK ==> - * we accept any term of type Type *) - (*CSC: BUG HERE: in this way it is possible for the term of - * type Type to be different from a Sort!!! *) - | C.Prod (name,(C.Sort (C.Type _) as s),t) -> - (* TASSI: ask CSC if BUG HERE refers to the C.Cast or C.Propd case *) - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - let newargument = C.Meta (newmeta+1,irl) in - let (res,newmetasenv,arguments,lastmeta) = - aux (newmeta + 2) (S.subst newargument t) - in - res, - (newmeta,[],s)::(newmeta+1,context,C.Meta (newmeta,[]))::newmetasenv, - newargument::arguments,lastmeta -*) - | C.Prod (name,s,t) -> - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - let newargument = C.Meta (newmeta,irl) in - let res,newmetasenv,arguments,lastmeta,prod_no = - aux (newmeta + 1) (S.subst newargument t) - in - if prod_no + 1 = goal_arity then - let head = CicReduction.normalize ~delta:false context ty in - head,[],[],lastmeta,goal_arity + 1 - else - (** NORMALIZE RATIONALE - * we normalize the target only NOW since we may be in this case: - * A1 -> A2 -> T where T = (\lambda x.A3 -> P) k - * and we want a mesasenv with ?1:A1 and ?2:A2 and not - * ?1, ?2, ?3 (that is the one we whould get if we start from the - * beta-normalized A1 -> A2 -> A3 -> P **) - let s' = CicReduction.normalize ~delta:false context s in - res,(newmeta,context,s')::newmetasenv,newargument::arguments, - lastmeta,prod_no + 1 - | t -> - let head = CicReduction.normalize ~delta:false context t in - match CicReduction.whd context head with - C.Prod _ as head' -> aux newmeta head' - | _ -> head,[],[],newmeta,0 - 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,metasenv @ newmetasenv,arguments,lastmeta - -let lookup_type metasenv context hyp = - let rec aux p = function - | Some (Cic.Name name, Cic.Decl t) :: _ when name = hyp -> p, t - | Some (Cic.Name name, Cic.Def (_, Some t)) :: _ when name = hyp -> p, t - | Some (Cic.Name name, Cic.Def (u, _)) :: tail when name = hyp -> - p, fst (CicTypeChecker.type_of_aux' metasenv tail u CicUniv.empty_ugraph) - | _ :: tail -> aux (succ p) tail - | [] -> raise (ProofEngineTypes.Fail (lazy "lookup_type: not premise in the current goal")) - in - aux 1 context diff --git a/helm/ocaml/tactics/proofEngineHelpers.mli b/helm/ocaml/tactics/proofEngineHelpers.mli deleted file mode 100644 index a7c0e5b54..000000000 --- a/helm/ocaml/tactics/proofEngineHelpers.mli +++ /dev/null @@ -1,118 +0,0 @@ -(* 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/. - *) - -exception Bad_pattern of string Lazy.t - -(* Returns the first meta whose number is above the *) -(* number of the higher meta. *) -val new_meta_of_proof : 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 - -(* returns the list of goals that are in newmetasenv and were not in - oldmetasenv *) -val compare_metasenvs : - oldmetasenv:Cic.metasenv -> newmetasenv:Cic.metasenv -> int list - - -(** { Patterns } - * A pattern is a Cic term in which Cic.Implicit terms annotated with `Hole - * appears *) - -(** create a pattern from a term and a list of subterms. -* the pattern is granted to have a ? for every subterm that has no selected -* subterms -* @param equality equality function used while walking the term. Defaults to -* physical equality (==) *) -val pattern_of: - ?equality:(Cic.term -> Cic.term -> bool) -> term:Cic.term -> Cic.term list -> - Cic.term - - -(** select metasenv conjecture pattern -* select all subterms of [conjecture] matching [pattern]. -* It returns the set of matched terms (that can be compared using physical -* equality to the subterms of [conjecture]) together with their contexts. -* The representation of the set mimics the conjecture type (but for the id): -* a list of (possibly removed) hypothesis (without their names) together with -* the list of its matched subterms (and their contexts) + the list of matched -* subterms of the conclusion with their context. Note: in the result the list -* of hypotheses * has an entry for each entry in the context and in the same -* order. Of course the list of terms (with their context) associated to one -* hypothesis may be empty. -* -* @raise Bad_pattern -* *) -val select: - metasenv:Cic.metasenv -> - ugraph:CicUniv.universe_graph -> - conjecture:Cic.conjecture -> - pattern:ProofEngineTypes.lazy_pattern -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph * - [ `Decl of (Cic.context * Cic.term) list - | `Def of (Cic.context * Cic.term) list * (Cic.context * Cic.term) list option - ] option list * - (Cic.context * Cic.term) list - -(** locate_in_term equality what where context -* [what] must match a subterm of [where] according to [equality] -* It returns the matched terms together with their contexts in [where] -* [equality] defaults to physical equality -* [context] must be the context of [where] -*) -val locate_in_term: - ?equality:(Cic.context -> Cic.term -> Cic.term -> bool) -> - Cic.term -> where:Cic.term -> Cic.context -> (Cic.context * Cic.term) list - -(** locate_in_conjecture equality what where context -* [what] must match a subterm of [where] according to [equality] -* It returns the matched terms together with their contexts in [where] -* [equality] defaults to physical equality -* [context] must be the context of [where] -*) -val locate_in_conjecture: - ?equality:(Cic.context -> Cic.term -> Cic.term -> bool) -> - Cic.term -> Cic.conjecture -> (Cic.context * Cic.term) list - -(* saturate_term newmeta metasenv context ty goal_arity *) -(* Given a type [ty] (a backbone), it returns its suffix of length *) -(* [goal_arity] head and a new metasenv in which there is new a META for each *) -(* hypothesis, a list of arguments for the new applications and the index of *) -(* the last new META introduced. The nth argument in the list of arguments is *) -(* just the nth new META. *) -val saturate_term: - int -> Cic.metasenv -> Cic.context -> Cic.term -> int -> - Cic.term * Cic.metasenv * Cic.term list * int - -(* returns the index and the type of a premise in a context *) -val lookup_type: Cic.metasenv -> Cic.context -> string -> int * Cic.term - diff --git a/helm/ocaml/tactics/proofEngineReduction.ml b/helm/ocaml/tactics/proofEngineReduction.ml deleted file mode 100644 index 0dc4ce4ee..000000000 --- a/helm/ocaml/tactics/proofEngineReduction.ml +++ /dev/null @@ -1,965 +0,0 @@ -(* 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 *) -(* 12/04/2002 *) -(* *) -(* *) -(******************************************************************************) - -(* $Id$ *) - -(* 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 what t 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 what t 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) -> - 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 what t 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 -> - 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) -> - 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 - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o 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 - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o 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) -> - 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) -> - 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 (_,_,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) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in - match o 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 reductaed, than it*) -(* is reduced, the delta-reduction is succesfull and the whole algorithm *) -(* is applied again to the new redex; Step 3.1) 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 performs step 3.2). *) -(* 3.1) 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. *) -(* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *) -(* reductions. If the reduction cannot be performed, it returns the *) -(* original term (not the head beta-zeta normal form of the definiendum) *) -(*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 -> - (* we never perform delta expansion automatically *) - if l = [] then t else C.Appl (t::l) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - reduceaux_exp_named_subst context l exp_named_subst - in - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o 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 [] 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 - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.Constant (_,Some body,_,_,_) -> - try_delta_expansion context 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) -> - 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 (_,_,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 (CicReduction.whd context term) with - C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1)) - | C.Appl (C.MutConstruct (_,_,j,_) :: tl) -> - let (arity, r) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in - match o 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 context 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) -> - 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) -> - 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.1 ****) - 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 -> - (**** Step 3.2 ****) - let rec aux l = - function - C.Lambda (name,s,t) -> - (match l with - [] -> raise AlreadySimplified - | he::tl -> - (* when name is Anonimous the substitution should *) - (* be superfluous *) - aux tl (S.subst he t)) - | C.LetIn (_,s,t) -> aux l (S.subst s t) - | t -> - let simplified = reduceaux context l t in - if t = simplified then - raise AlreadySimplified - else - simplified - in - (try aux l body - with - AlreadySimplified -> - if l = [] then term else C.Appl (term::l)) - | 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 [] -;; - -let unfold ?what context where = - let contextlen = List.length context in - let first_is_the_expandable_head_of_second context' t1 t2 = - match t1,t2 with - Cic.Const (uri,_), Cic.Const (uri',_) - | Cic.Var (uri,_), Cic.Var (uri',_) - | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_) - | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri' - | Cic.Const _, _ - | Cic.Var _, _ -> false - | Cic.Rel n, Cic.Rel m - | Cic.Rel n, Cic.Appl (Cic.Rel m::_) -> - n + (List.length context' - contextlen) = m - | Cic.Rel _, _ -> false - | _,_ -> - raise - (ProofEngineTypes.Fail - (lazy "The term to unfold is not a constant, a variable or a bound variable ")) - in - let appl he tl = - if tl = [] then he else Cic.Appl (he::tl) in - let cannot_delta_expand t = - raise - (ProofEngineTypes.Fail - (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in - let rec hd_delta_beta context tl = - function - Cic.Rel n as t -> - (try - match List.nth context (n-1) with - Some (_,Cic.Decl _) -> cannot_delta_expand t - | Some (_,Cic.Def (bo,_)) -> - CicReduction.head_beta_reduce - (appl (CicSubstitution.lift n bo) tl) - | None -> raise RelToHiddenHypothesis - with - Failure _ -> assert false) - | Cic.Const (uri,exp_named_subst) as t -> - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match o with - Cic.Constant (_,Some body,_,_,_) -> - CicReduction.head_beta_reduce - (appl (CicSubstitution.subst_vars exp_named_subst body) tl) - | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t - | Cic.Variable _ -> raise ReferenceToVariable - | Cic.CurrentProof _ -> raise ReferenceToCurrentProof - | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - | Cic.Var (uri,exp_named_subst) as t -> - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match o with - Cic.Constant _ -> raise ReferenceToConstant - | Cic.CurrentProof _ -> raise ReferenceToCurrentProof - | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - | Cic.Variable (_,Some body,_,_,_) -> - CicReduction.head_beta_reduce - (appl (CicSubstitution.subst_vars exp_named_subst body) tl) - | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t - ) - | Cic.Appl [] -> assert false - | Cic.Appl (he::tl) -> hd_delta_beta context tl he - | t -> cannot_delta_expand t - in - let context_and_matched_term_list = - match what with - None -> [context, where] - | Some what -> - let res = - ProofEngineHelpers.locate_in_term - ~equality:first_is_the_expandable_head_of_second - what ~where context - in - if res = [] then - raise - (ProofEngineTypes.Fail - (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where))) - else - res - in - let reduced_terms = - List.map - (function (context,where) -> hd_delta_beta context [] where) - context_and_matched_term_list in - let whats = List.map snd context_and_matched_term_list in - replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where -;; diff --git a/helm/ocaml/tactics/proofEngineReduction.mli b/helm/ocaml/tactics/proofEngineReduction.mli deleted file mode 100644 index 67247876a..000000000 --- a/helm/ocaml/tactics/proofEngineReduction.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* 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:('a -> Cic.term -> 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 -val unfold : ?what:Cic.term -> Cic.context -> Cic.term -> Cic.term diff --git a/helm/ocaml/tactics/proofEngineStructuralRules.ml b/helm/ocaml/tactics/proofEngineStructuralRules.ml deleted file mode 100644 index 4677a33ac..000000000 --- a/helm/ocaml/tactics/proofEngineStructuralRules.ml +++ /dev/null @@ -1,195 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open ProofEngineTypes - -let clearbody ~hyp = - let clearbody ~hyp (proof, goal) = - let module C = Cic in - let curi,metasenv,pbo,pty = proof in - let metano,_,_ = CicUtil.lookup_meta 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 - Some (C.Name hyp',C.Def (term,ty)) when hyp = hyp' -> - let cleared_entry = - let ty = - match ty with - Some ty -> ty - | None -> - fst - (CicTypeChecker.type_of_aux' metasenv context term - CicUniv.empty_ugraph) (* TASSI: FIXME *) - in - Some (C.Name hyp, Cic.Decl ty) - in - cleared_entry::context - | None -> None::context - | Some (n,C.Decl t) - | Some (n,C.Def (t,None)) -> - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv context t - CicUniv.empty_ugraph (* TASSI: FIXME *) - with - _ -> - raise - (Fail - (lazy ("The correctness of hypothesis " ^ - string_of_name n ^ - " relies on the body of " ^ hyp) - )) - in - entry::context - | Some (_,Cic.Def (_,Some _)) -> assert false - ) canonical_context [] - in - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv canonical_context' ty - CicUniv.empty_ugraph (* TASSI: FIXME *) - with - _ -> - raise - (Fail - (lazy ("The correctness of the goal relies on the body of " ^ - hyp))) - in - m,canonical_context',ty - | t -> t - ) metasenv - in - (curi,metasenv',pbo,pty), [goal] - in - mk_tactic (clearbody ~hyp) - -let clear ~hyp = - let clear ~hyp (proof, goal) = - let module C = Cic in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = - CicUtil.lookup_meta 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 context_changed, canonical_context' = - List.fold_right - (fun entry (b, context) -> - match entry with - Some (Cic.Name hyp',_) when hyp' = hyp -> - (true, None::context) - | None -> (b, None::context) - | Some (n,C.Decl t) - | Some (n,Cic.Def (t,Some _)) - | Some (n,C.Def (t,None)) -> - if b then - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv context t - CicUniv.empty_ugraph - with _ -> - raise - (Fail - (lazy ("Hypothesis " ^ string_of_name n ^ - " uses hypothesis " ^ hyp))) - in - (b, entry::context) - else - (b, entry::context) - ) canonical_context (false, []) - in - if not context_changed then - raise (Fail (lazy ("Hypothesis " ^ hyp ^ " does not exist"))); - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv canonical_context' ty - CicUniv.empty_ugraph - with _ -> - raise (Fail (lazy ("Hypothesis " ^ hyp ^ " occurs in the goal"))) - in - m,canonical_context',ty - | t -> t - ) metasenv - in - (curi,metasenv',pbo,pty), [goal] - in - mk_tactic (clear ~hyp) - -(* Warning: this tactic has no effect on the proof term. - It just changes the name of an hypothesis in the current sequent *) -let rename ~from ~to_ = - let rename ~from ~to_ (proof, goal) = - let module C = Cic in - let curi,metasenv,pbo,pty = proof in - let metano,context,ty = - CicUtil.lookup_meta goal metasenv - in - let metasenv' = - List.map - (function - (m,canonical_context,ty) when m = metano -> - let canonical_context' = - List.map - (function - Some (Cic.Name hyp,decl_or_def) when hyp = from -> - Some (Cic.Name to_,decl_or_def) - | item -> item - ) canonical_context - in - m,canonical_context',ty - | t -> t - ) metasenv - in - (curi,metasenv',pbo,pty), [goal] - in - mk_tactic (rename ~from ~to_) - -let set_goal n = - ProofEngineTypes.mk_tactic - (fun (proof, goal) -> - let (_, metasenv, _, _) = proof in - if CicUtil.exists_meta n metasenv then - (proof, [n]) - else - raise (ProofEngineTypes.Fail (lazy ("no such meta: " ^ string_of_int n)))) diff --git a/helm/ocaml/tactics/proofEngineStructuralRules.mli b/helm/ocaml/tactics/proofEngineStructuralRules.mli deleted file mode 100644 index 91ebfecfb..000000000 --- a/helm/ocaml/tactics/proofEngineStructuralRules.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* 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:string -> ProofEngineTypes.tactic -val clear: hyp:string -> ProofEngineTypes.tactic - -(* Warning: this tactic has no effect on the proof term. - It just changes the name of an hypothesis in the current sequent *) -val rename: from:string -> to_:string -> ProofEngineTypes.tactic - - (* change the current goal to those referred by the given meta number *) -val set_goal: int -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/proofEngineTypes.ml b/helm/ocaml/tactics/proofEngineTypes.ml deleted file mode 100644 index 68ea561f9..000000000 --- a/helm/ocaml/tactics/proofEngineTypes.ml +++ /dev/null @@ -1,101 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - - (** - current proof (proof uri * metas * (in)complete proof * term to be prooved) - *) -type proof = UriManager.uri option * Cic.metasenv * Cic.term * Cic.term - (** current goal, integer index *) -type goal = int -type status = proof * goal - -let initial_status ty metasenv = - let rec aux max = function - | [] -> max + 1 - | (idx, _, _) :: tl -> - if idx > max then - aux idx tl - else - aux max tl - in - let newmeta_idx = aux 0 metasenv in - let proof = - None, (newmeta_idx, [], ty) :: metasenv, Cic.Meta (newmeta_idx, []), ty - in - (proof, newmeta_idx) - - (** - 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 list - - (** creates an opaque tactic from a status->proof*goal list function *) -let mk_tactic t = t - -type reduction = Cic.context -> Cic.term -> Cic.term - -let const_lazy_term t = - (fun _ metasenv ugraph -> t, metasenv, ugraph) - -type lazy_reduction = - Cic.context -> Cic.metasenv -> CicUniv.universe_graph -> - reduction * Cic.metasenv * CicUniv.universe_graph - -let const_lazy_reduction red = - (fun _ metasenv ugraph -> red, metasenv, ugraph) - -type ('term, 'lazy_term) pattern = - 'lazy_term option * (string * 'term) list * 'term option - -type lazy_pattern = (Cic.term, Cic.lazy_term) pattern - -let conclusion_pattern t = - let t' = - match t with - | None -> None - | Some t -> Some (fun _ m u -> t, m, u) - in - t',[],Some (Cic.Implicit (Some `Hole)) - - (** tactic failure *) -exception Fail of string Lazy.t - - (** - calls the opaque tactic on the status, restoring the original - universe graph if the tactic Fails - *) -let apply_tactic t status = - t status - - (** constraint: the returned value will always be constructed by Cic.Name **) -type mk_fresh_name_type = - Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name - -let goals_of_proof (_,metasenv,_,_) = List.map (fun (g,_,_) -> g) metasenv - diff --git a/helm/ocaml/tactics/proofEngineTypes.mli b/helm/ocaml/tactics/proofEngineTypes.mli deleted file mode 100644 index 4396ea78f..000000000 --- a/helm/ocaml/tactics/proofEngineTypes.mli +++ /dev/null @@ -1,76 +0,0 @@ -(* 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 option * Cic.metasenv * Cic.term * Cic.term - (** current goal, integer index *) -type goal = int -type status = proof * goal - - (** @param goal - * @param goal's metasenv - * @return initial proof status for the given goal *) -val initial_status: Cic.term -> Cic.metasenv -> status - - (** - 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 -val mk_tactic: (status -> proof * goal list) -> tactic - -type reduction = Cic.context -> Cic.term -> Cic.term - -val const_lazy_term: Cic.term -> Cic.lazy_term - -type lazy_reduction = - Cic.context -> Cic.metasenv -> CicUniv.universe_graph -> - reduction * Cic.metasenv * CicUniv.universe_graph - -val const_lazy_reduction: reduction -> lazy_reduction - - (** what, hypothesis patterns, conclusion pattern *) -type ('term, 'lazy_term) pattern = - 'lazy_term option * (string * 'term) list * 'term option - -type lazy_pattern = (Cic.term, Cic.lazy_term) pattern - - (** conclusion_pattern [t] returns the pattern (t,[],%) *) -val conclusion_pattern : Cic.term option -> lazy_pattern - - (** tactic failure *) -exception Fail of string Lazy.t - -val apply_tactic: tactic -> status -> proof * goal list - - (** constraint: the returned value will always be constructed by Cic.Name **) -type mk_fresh_name_type = - Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name - -val goals_of_proof: proof -> goal list - diff --git a/helm/ocaml/tactics/reductionTactics.ml b/helm/ocaml/tactics/reductionTactics.ml deleted file mode 100644 index 115faa80b..000000000 --- a/helm/ocaml/tactics/reductionTactics.ml +++ /dev/null @@ -1,220 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open ProofEngineTypes - -(* Note: this code is almost identical to change_tac and -* it could be unified by making the change function a callback *) -let reduction_tac ~reduction ~pattern (proof,goal) = - let curi,metasenv,pbo,pty = proof in - let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in - let change subst where terms metasenv ugraph = - if terms = [] then where, metasenv, ugraph - else - let pairs, metasenv, ugraph = - List.fold_left - (fun (pairs, metasenv, ugraph) (context, t) -> - let reduction, metasenv, ugraph = reduction context metasenv ugraph in - ((t, reduction context t) :: pairs), metasenv, ugraph) - ([], metasenv, ugraph) - terms - in - let terms, terms' = List.split pairs in - let where' = - ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms' - ~where:where - in - CicMetaSubst.apply_subst subst where', metasenv, ugraph - in - let (subst,metasenv,ugraph,selected_context,selected_ty) = - ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph - ~conjecture ~pattern - in - let ty', metasenv, ugraph = change subst ty selected_ty metasenv ugraph in - let context', metasenv, ugraph = - List.fold_right2 - (fun entry selected_entry (context', metasenv, ugraph) -> - match entry,selected_entry with - None,None -> None::context', metasenv, ugraph - | Some (name,Cic.Decl ty),Some (`Decl selected_ty) -> - let ty', metasenv, ugraph = - change subst ty selected_ty metasenv ugraph - in - Some (name,Cic.Decl ty')::context', metasenv, ugraph - | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) -> - let bo', metasenv, ugraph = - change subst bo selected_bo metasenv ugraph - in - let ty', metasenv, ugraph = - match ty,selected_ty with - None,None -> None, metasenv, ugraph - | Some ty,Some selected_ty -> - let ty', metasenv, ugraph = - change subst ty selected_ty metasenv ugraph - in - Some ty', metasenv, ugraph - | _,_ -> assert false - in - (Some (name,Cic.Def (bo',ty'))::context'), metasenv, ugraph - | _,_ -> assert false - ) context selected_context ([], metasenv, ugraph) 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 ~pattern = - mk_tactic (reduction_tac - ~reduction:(const_lazy_reduction ProofEngineReduction.simpl) ~pattern) - -let reduce_tac ~pattern = - mk_tactic (reduction_tac - ~reduction:(const_lazy_reduction ProofEngineReduction.reduce) ~pattern) - -let unfold_tac what ~pattern = - let reduction = - match what with - | None -> const_lazy_reduction (ProofEngineReduction.unfold ?what:None) - | Some lazy_term -> - (fun context metasenv ugraph -> - let what, metasenv, ugraph = lazy_term context metasenv ugraph in - ProofEngineReduction.unfold ~what, metasenv, ugraph) - in - mk_tactic (reduction_tac ~reduction ~pattern) - -let whd_tac ~pattern = - mk_tactic (reduction_tac - ~reduction:(const_lazy_reduction CicReduction.whd) ~pattern) - -let normalize_tac ~pattern = - mk_tactic (reduction_tac - ~reduction:(const_lazy_reduction CicReduction.normalize) ~pattern) - -exception NotConvertible - -(* Note: this code is almost identical to reduction_tac and -* it could be unified by making the change function a callback *) -(* CSC: with_what is parsed in the context of the goal, but it should replace - something that lives in a completely different context. Thus we - perform a delift + lift phase to move it in the right context. However, - in this way the tactic is less powerful than expected: with_what cannot - reference variables that are local to the term that is going to be - replaced. To fix this we should parse with_what in the context of the - term(s) to be replaced. *) -let change_tac ~pattern with_what = - let change_tac ~pattern ~with_what (proof, goal) = - let curi,metasenv,pbo,pty = proof in - let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in - let change subst where terms metasenv ugraph = - if terms = [] then where, metasenv, ugraph - else - let pairs, metasenv, ugraph = - List.fold_left - (fun (pairs, metasenv, ugraph) (context_of_t, t) -> - let with_what, metasenv, ugraph = - with_what context_of_t metasenv ugraph - in - let _,u = - CicTypeChecker.type_of_aux' metasenv context_of_t with_what ugraph - in - let b,_ = - CicReduction.are_convertible ~metasenv context_of_t t with_what u - in - if b then - ((t, with_what) :: pairs), metasenv, ugraph - else - raise NotConvertible) - ([], metasenv, ugraph) - terms - in - let terms, terms' = List.split pairs in - let where' = - ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms' - ~where:where - in - CicMetaSubst.apply_subst subst where', metasenv, ugraph - in - let (subst,metasenv,ugraph,selected_context,selected_ty) = - ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph ~conjecture - ~pattern in - let ty', metasenv, ugraph = change subst ty selected_ty metasenv ugraph in - let context', metasenv, ugraph = - List.fold_right2 - (fun entry selected_entry (context', metasenv, ugraph) -> - match entry,selected_entry with - None,None -> (None::context'), metasenv, ugraph - | Some (name,Cic.Decl ty),Some (`Decl selected_ty) -> - let ty', metasenv, ugraph = - change subst ty selected_ty metasenv ugraph - in - (Some (name,Cic.Decl ty')::context'), metasenv, ugraph - | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) -> - let bo', metasenv, ugraph = - change subst bo selected_bo metasenv ugraph - in - let ty', metasenv, ugraph = - match ty,selected_ty with - None,None -> None, metasenv, ugraph - | Some ty,Some selected_ty -> - let ty', metasenv, ugraph = - change subst ty selected_ty metasenv ugraph - in - Some ty', metasenv, ugraph - | _,_ -> assert false - in - (Some (name,Cic.Def (bo',ty'))::context'), metasenv, ugraph - | _,_ -> assert false - ) context selected_context ([], metasenv, ugraph) in - let metasenv' = - List.map - (function - | (n,_,_) when n = metano -> (metano,context',ty') - | _ as t -> t) - metasenv - in - (curi,metasenv',pbo,pty), [metano] - in - mk_tactic (change_tac ~pattern ~with_what) - -let fold_tac ~reduction ~term ~pattern = - let fold_tac ~reduction ~term ~pattern:(wanted,hyps_pat,concl_pat) status = - assert (wanted = None); (* this should be checked syntactically *) - let reduced_term = - (fun context metasenv ugraph -> - let term, metasenv, ugraph = term context metasenv ugraph in - let reduction, metasenv, ugraph = reduction context metasenv ugraph in - reduction context term, metasenv, ugraph) - in - apply_tactic - (change_tac ~pattern:(Some reduced_term,hyps_pat,concl_pat) term) status - in - mk_tactic (fold_tac ~reduction ~term ~pattern) - diff --git a/helm/ocaml/tactics/reductionTactics.mli b/helm/ocaml/tactics/reductionTactics.mli deleted file mode 100644 index 16e2bc23c..000000000 --- a/helm/ocaml/tactics/reductionTactics.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* 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 simpl_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val reduce_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val whd_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val normalize_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic - -(* The default of term is the thesis of the goal to be prooved *) -val unfold_tac: - Cic.lazy_term option -> - pattern:ProofEngineTypes.lazy_pattern -> - ProofEngineTypes.tactic - -val change_tac: - pattern:ProofEngineTypes.lazy_pattern -> - Cic.lazy_term -> - ProofEngineTypes.tactic - -val fold_tac: - reduction:ProofEngineTypes.lazy_reduction -> - term:Cic.lazy_term -> - pattern:ProofEngineTypes.lazy_pattern -> - ProofEngineTypes.tactic - diff --git a/helm/ocaml/tactics/ring.ml b/helm/ocaml/tactics/ring.ml deleted file mode 100644 index 4c58f1004..000000000 --- a/helm/ocaml/tactics/ring.ml +++ /dev/null @@ -1,596 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -open CicReduction -open PrimitiveTactics -open ProofEngineTypes -open UriManager - -(** DEBUGGING *) - - (** perform debugging output? *) -let debug = false -let debug_print = fun _ -> () - - (** debugging print *) -let warn s = debug_print (lazy ("RING WARNING: " ^ (Lazy.force 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 equality_is_a_congruence_A = - uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var" -let equality_is_a_congruence_x = - uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var" -let equality_is_a_congruence_y = - uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var" - -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 status current proof engine status - @raise Failure if proof is None - @return current goal's metasenv - *) -let metasenv_of_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 = - let (proof, goal) = status in - let metasenv = metasenv_of_status status in - let _, context, _ = CicUtil.lookup_meta 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 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 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 HelmLibraryObjects.Logic.eq_URI) -> true - | _ -> false - in - let is_real = function - | Cic.Const (uri, _) when (eq uri HelmLibraryObjects.Reals.r_URI) -> true - | _ -> false - in - function - | Cic.Appl (app::set::_::_::[]) when (is_equality app && is_real set) -> - warn (lazy "Goal Ringable!"); - true - | _ -> - warn (lazy "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 (lazy ("" ^ (CicPp.ppterm t1) ^ "")); - warn (lazy ("" ^ (CicPp.ppterm t2) ^ "")); - (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 = HelmLibraryObjects.Reals.r in - 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 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 HelmLibraryObjects.Reals.rplus_URI) bop) -> (* +. *) - Cic.Appl [mkCtor applus_uri []; aux t1; aux t2] - | Cic.Appl (bop::t1::t2::[]) - when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.rmult_URI) bop) -> (* *. *) - Cic.Appl [mkCtor apmult_uri []; aux t1; aux t2] - | Cic.Appl (uop::t::[]) - when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.ropp_URI) uop) -> (* ~-. *) - Cic.Appl [mkCtor apopp_uri []; aux t] - | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.r0_URI) t) -> (* 0. *) - mkCtor ap0_uri [] - | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.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 theory_args_subst varmap = - [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ; - abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ; - abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ; - abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ; - abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ; - abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.ropp ; - abstract_rings_vm_uri, varmap] in - let theory_args_subst' eq varmap t = - [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ; - abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ; - abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ; - abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ; - abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ; - abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.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 lxy_false = (** Cic funcion "fun (x,y):R -> false" *) - Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, - Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, HelmLibraryObjects.Datatypes.falseb)) - 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 HelmLibraryObjects.Reals.rtheory ; t] - ) aterms - - -let status_of_single_goal_tactic_result = - function - proof,[goal] -> proof,goal - | _ -> - raise (Fail (lazy "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 (lazy "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 - *) -(* FG: METTERE I NOMI ANCHE QUI? *) -let elim_type2_tac ~term ~proof = - let elim_type2_tac ~term ~proof status = - let module E = EliminationTactics in - warn (lazy "in Ring.elim_type2"); - ProofEngineTypes.apply_tactic - (Tacticals.thens ~start:(E.elim_type_tac term) - ~continuations:[Tacticals.id_tac ; exact_tac ~term:proof]) status - in - ProofEngineTypes.mk_tactic (elim_type2_tac ~term ~proof) - -(* 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 (proof, goal) = - warn (lazy "in Ring.reflexivity_tac"); - let refl_eqt = mkCtor ~uri:refl_eqt_uri ~exp_named_subst:[] in - try - apply_tac (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 = - let purge_hyps_tac ~count status = - let module S = ProofEngineStructuralRules in - let (proof, goal) = status in - let rec aux n context status = - assert(n>=0); - match (n, context) with - | (0, _) -> status - | (n, hd::tl) -> - let name_of_hyp = - match hd with - None - | Some (Cic.Anonymous,_) -> assert false - | Some (Cic.Name name,_) -> name - in - aux (n-1) tl - (status_of_single_goal_tactic_result - (ProofEngineTypes.apply_tactic (S.clear ~hyp:name_of_hyp) status)) - | (_, []) -> failwith "Ring.purge_hyps_tac: no hypotheses left" - in - let (_, metasenv, _, _) = proof in - let (_, context, _) = CicUtil.lookup_meta goal metasenv in - let proof',goal' = aux count context status in - assert (goal = goal') ; - proof',[goal'] - in - ProofEngineTypes.mk_tactic (purge_hyps_tac ~count) - -(** THE TACTIC! *) - - (** - Ring tactic, does associative and commutative rewritings in Reals ring - @param status current proof engine status - *) - -let ring_tac status = - let (proof, goal) = status in - warn (lazy "in Ring tactic"); - let eqt = mkMutInd (HelmLibraryObjects.Logic.eq_URI, 0) [] in - let r = HelmLibraryObjects.Reals.r in - let metasenv = metasenv_of_status status in - let (metano, context, ty) = CicUtil.lookup_meta 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 - if debug then - List.iter (* debugging, feel free to remove *) - (fun (descr, term) -> - warn (lazy (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 *) - ProofEngineTypes.apply_tactic - (Tacticals.first - ~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 HelmLibraryObjects.Logic.sym_eq_URI - [equality_is_a_congruence_A, HelmLibraryObjects.Reals.r; - equality_is_a_congruence_x, t1'' ; - equality_is_a_congruence_y, t1 - ] ; - t1'_eq_t1'' - ]) ; - "elim_type eqt su t1 ...", ProofEngineTypes.mk_tactic (fun status -> - let status' = (* status after 1st elim_type use *) - let context = context_of_status status in - let b,_ = (*TASSI : FIXME*) - are_convertible context t1'' t1 CicUniv.empty_ugraph in - if not b then begin - warn (lazy "t1'' and t1 are NOT CONVERTIBLE"); - let newstatus = - ProofEngineTypes.apply_tactic - (elim_type2_tac (* 1st elim_type use *) - ~proof:t1'_eq_t1'' - ~term:(Cic.Appl [eqt; r; t1''; t1])) - status - in - incr new_hyps; (* elim_type add an hyp *) - match newstatus with - (proof,[goal]) -> proof,goal - | _ -> assert false - end else begin - warn (lazy "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'' = - ProofEngineTypes.apply_tactic - (Tacticals.first (* try to solve 1st subgoal *) - ~tactics:[ - "exact t2'_eq_t2''", exact_tac ~term:t2'_eq_t2''; - "exact sym_eqt su t2 ...", - exact_tac - ~term:( - Cic.Appl - [mkConst HelmLibraryObjects.Logic.sym_eq_URI - [equality_is_a_congruence_A, HelmLibraryObjects.Reals.r; - equality_is_a_congruence_x, t2'' ; - equality_is_a_congruence_y, t2 - ] ; - t2'_eq_t2'' - ]) ; - "elim_type eqt su t2 ...", - ProofEngineTypes.mk_tactic (fun status -> - let status' = - let context = context_of_status status in - let b,_ = (* TASSI:FIXME *) - are_convertible context t2'' t2 CicUniv.empty_ugraph - in - if not b then begin - warn (lazy "t2'' and t2 are NOT CONVERTIBLE"); - let newstatus = - ProofEngineTypes.apply_tactic - (elim_type2_tac (* 2nd elim_type use *) - ~proof:t2'_eq_t2'' - ~term:(Cic.Appl [eqt; r; t2''; t2])) - status - in - incr new_hyps; (* elim_type add an hyp *) - match newstatus with - (proof,[goal]) -> proof,goal - | _ -> assert false - end else begin - warn (lazy "t2'' and t2 are CONVERTIBLE"); - status - end - in - try (* try to solve main goal *) - warn (lazy "trying reflexivity ...."); - ProofEngineTypes.apply_tactic - EqualityTactics.reflexivity_tac status' - with (Fail _) -> (* leave conclusion to the user *) - warn (lazy "reflexivity failed, solution's left as an ex :-)"); - ProofEngineTypes.apply_tactic - (purge_hyps_tac ~count:!new_hyps) status')]) - status' - in - status'')]) - status - with (Fail s) -> - raise (Fail (lazy ("Ring failure: " ^ Lazy.force 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 (lazy "goal unringable")) - -let ring_tac = ProofEngineTypes.mk_tactic ring_tac - diff --git a/helm/ocaml/tactics/ring.mli b/helm/ocaml/tactics/ring.mli deleted file mode 100644 index b6eb34b69..000000000 --- a/helm/ocaml/tactics/ring.mli +++ /dev/null @@ -1,12 +0,0 @@ - - (* 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 -*) diff --git a/helm/ocaml/tactics/statefulProofEngine.ml b/helm/ocaml/tactics/statefulProofEngine.ml deleted file mode 100644 index 9529c897c..000000000 --- a/helm/ocaml/tactics/statefulProofEngine.ml +++ /dev/null @@ -1,214 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let default_history_size = 20 - -exception No_goal_left -exception Uri_redefinition -type event = [ `Proof_changed | `Proof_completed ] -let all_events = [ `Proof_changed; `Proof_completed ] -let default_events: event list = [ `Proof_changed ] - -type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option - -type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit -type observer_id = int - -exception Observer_failures of (observer_id * exn) list -exception Tactic_failure of exn -exception Data_failure of exn - -class ['a] status - ?(history_size = default_history_size) - ?uri ~typ ~body ~metasenv init_data compute_data () - = - let next_observer_id = - let next_id = ref 0 in - fun () -> - incr next_id; - !next_id - in - let initial_proof = ((uri: UriManager.uri option), metasenv, body, typ) in - let next_goal (goals, proof) = - match goals, proof with - | goal :: _, _ -> Some goal - | [], (_, (goal, _, _) :: _, _, _) -> - (* the tactic left no open goal: let's choose the first open goal *) - Some goal - | _, _ -> None - in - let initial_goal = next_goal ([], initial_proof) in - object (self) - - val mutable _proof = initial_proof - val mutable _goal = initial_goal - val mutable _data: 'a = init_data (initial_proof, initial_goal) - - (* event -> (id, observer) list *) - val observers = Hashtbl.create 7 - - (* assumption: all items in history are uncompleted proofs, thus option on - * goal could be ignored and goal are stored as bare integers *) - val history = new History.history history_size - - initializer - history#push self#internal_status - - method proof = _proof - method private status = (_proof, _goal) (* logic status *) - method private set_status (proof, (goal: int option)) = - _proof <- proof; - _goal <- goal - - method goal = - match _goal with - | Some goal -> goal - | None -> raise No_goal_left - - (* what will be kept in history *) - method private internal_status = (self#status, _data) - method private set_internal_status (status, data) = - self#set_status status; - _data <- data - - method set_goal goal = - _goal <- Some goal -(* - let old_internal_status = self#internal_status in - _goal <- Some goal; - try - self#update_data old_internal_status; - history#push self#internal_status; - self#private_notify (Some old_internal_status) - with (Data_failure _) as exn -> - self#set_internal_status old_internal_status; - raise exn -*) - - method uri = let (uri, _, _, _) = _proof in uri - method metasenv = let (_, metasenv, _, _) = _proof in metasenv - method body = let (_, _, body, _) = _proof in body - method typ = let (_, _, _, typ) = _proof in typ - - method set_metasenv metasenv = - let (uri, _, body, typ) = _proof in - _proof <- (uri, metasenv, body, typ) - - method set_uri uri = - let (old_uri, metasenv, body, typ) = _proof in - if old_uri <> None then - raise Uri_redefinition; - _proof <- (Some uri, metasenv, body, typ) - - method conjecture goal = - let (_, metasenv, _, _) = _proof in - CicUtil.lookup_meta goal metasenv - - method apply_tactic tactic = - let old_internal_status = self#internal_status in - let (new_proof, new_goals) = - try - ProofEngineTypes.apply_tactic tactic (_proof, self#goal) - with exn -> raise (Tactic_failure exn) - in - _proof <- new_proof; - _goal <- next_goal (new_goals, new_proof); - try - self#update_data old_internal_status; - history#push self#internal_status; - self#private_notify (Some old_internal_status) - with (Data_failure _) as exn -> - self#set_internal_status old_internal_status; - raise exn - - method proof_completed = _goal = None - - method attach_observer ?(interested_in = default_events) observer - = - let id = next_observer_id () in - List.iter - (fun event -> - let prev_observers = - try Hashtbl.find observers event with Not_found -> [] - in - Hashtbl.replace observers event ((id, observer)::prev_observers)) - interested_in; - id - - method detach_observer id = - List.iter - (fun event -> - let prev_observers = - try Hashtbl.find observers event with Not_found -> [] - in - let new_observers = - List.filter (fun (id', _) -> id' <> id) prev_observers - in - Hashtbl.replace observers event new_observers) - all_events - - method private private_notify old_internal_status = - let cur_internal_status = (self#status, _data) in - let exns = ref [] in - let notify (id, observer) = - try - observer old_internal_status cur_internal_status - with exn -> exns := (id, exn) :: !exns - in - List.iter notify - (try Hashtbl.find observers `Proof_changed with Not_found -> []); - if self#proof_completed then - List.iter notify - (try Hashtbl.find observers `Proof_completed with Not_found -> []); - match !exns with - | [] -> () - | exns -> raise (Observer_failures exns) - - method private update_data old_internal_status = - (* invariant: _goal and/or _proof has been changed - * invariant: proof is not yet completed *) - let status = self#status in - try - _data <- compute_data old_internal_status status - with exn -> raise (Data_failure exn) - - method undo ?(steps = 1) () = - let ((proof, goal), data) = history#undo steps in - _proof <- proof; - _goal <- goal; - _data <- data; - self#private_notify None - - method redo ?(steps = 1) () = self#undo ~steps:~-steps () - - method notify = self#private_notify None - - end - -let trivial_status ?uri ~typ ~body ~metasenv () = - new status ?uri ~typ ~body ~metasenv (fun _ -> ()) (fun _ _ -> ()) () - diff --git a/helm/ocaml/tactics/statefulProofEngine.mli b/helm/ocaml/tactics/statefulProofEngine.mli deleted file mode 100644 index 4198876ca..000000000 --- a/helm/ocaml/tactics/statefulProofEngine.mli +++ /dev/null @@ -1,120 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(** Stateful handling of proof status *) - -exception No_goal_left -exception Uri_redefinition - -type event = [ `Proof_changed | `Proof_completed ] - -val all_events: event list - - (** from our point of view a status is the status of an incomplete proof, thus - * we have an optional goal which is None if the proof is not yet completed - * (i.e. some goal is still open) *) -type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option - - (** Proof observer. First callback argument is Some extended_status - * when a 'real 'change of the proof happened and None when Proof_changed event - * was triggered by a time travel by the means of undo/redo actions or by an - * external "#notify" invocation. Embedded status is the status _before_ the - * current change. Second status is the status reached _after_ the current - * change. *) -type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit - - (** needed to detach previously attached observers *) -type observer_id - - (** tactic application failed. @see apply_tactic *) -exception Tactic_failure of exn - - (** one or more observers failed. @see apply_tactic *) -exception Observer_failures of (observer_id * exn) list - - (** failure while updating internal data (: 'a). @see apply_tactic *) -exception Data_failure of exn - -(** {2 OO interface} *) - -class ['a] status: - ?history_size:int -> (** default 20 *) - ?uri:UriManager.uri -> - typ:Cic.term -> body:Cic.term -> metasenv:Cic.metasenv -> - (proof_status -> 'a) -> (* init data *) - (proof_status * 'a -> proof_status -> 'a) -> (* update data *) - unit -> - object - - method proof: ProofEngineTypes.proof - method metasenv: Cic.metasenv - method body: Cic.term - method typ: Cic.term - - (** change metasenv _without_ triggering any notification *) - method set_metasenv: Cic.metasenv -> unit - - (** goal -> conjecture - * @raise CicUtil.Meta_not_found *) - method conjecture: int -> Cic.conjecture - - method proof_completed: bool - method goal: int (** @raise No_goal_left *) - method set_goal: int -> unit (** @raise Data_failure *) - - method uri: UriManager.uri option - method set_uri: UriManager.uri -> unit (** @raise Uri_redefinition *) - - (** @raise Tactic_failure - * @raise Observer_failures - * @raise Data_failure - * - * In case of tactic failure, internal status is left unchanged. - * In case of observer failures internal status will be changed and is - * granted that all observer will be invoked collecting their failures. - * In case of data failure, internal status is left unchanged (rolling back - * last tactic application if needed) - *) - method apply_tactic: ProofEngineTypes.tactic -> unit - - method undo: ?steps:int -> unit -> unit - method redo: ?steps:int -> unit -> unit - - method attach_observer: - ?interested_in:(event list) -> 'a observer -> observer_id - - method detach_observer: observer_id -> unit - - (** force a notification to all observer, old status is passed as None *) - method notify: unit - - end - -val trivial_status: - ?uri:UriManager.uri -> - typ:Cic.term -> body:Cic.term -> metasenv:Cic.metasenv -> - unit -> - unit status - diff --git a/helm/ocaml/tactics/tacticChaser.ml b/helm/ocaml/tactics/tacticChaser.ml deleted file mode 100644 index cb700f776..000000000 --- a/helm/ocaml/tactics/tacticChaser.ml +++ /dev/null @@ -1,259 +0,0 @@ -(* 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 *) -(* 18/02/2003 *) -(* *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -module MQI = MQueryInterpreter -module MQIC = MQIConn -module I = MQueryInterpreter -module U = MQGUtil -module G = MQueryGenerator - - (* search arguments on which Apply tactic doesn't fail *) -let matchConclusion mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status = - let ((_, metasenv, _, _), metano) = status in - let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in - let list_of_must, only = CGMatchConclusion.get_constraints metasenv ey ty in -match list_of_must with - [] -> [] -|_ -> - let must = choose_must list_of_must only in - let result = - I.execute mqi_handle - (G.query_of_constraints - (Some CGMatchConclusion.universe) - (must,[],[]) (Some only,None,None)) in - let uris = - List.map - (function uri,_ -> - MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri - ) result - in - let uris = - (* TODO ristretto per ragioni di efficienza *) - prerr_endline "STO FILTRANDO"; - List.filter (fun uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris - in - prerr_endline "HO FILTRATO"; - let uris',exc = - let rec filter_out = - function - [] -> [],"" - | uri::tl -> - let tl',exc = filter_out tl in - try - if - let time = Unix.gettimeofday() in - (try - ignore(ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac - ~term:(MQueryMisc.term_of_cic_textual_parser_uri - (MQueryMisc.cic_textual_parser_uri_of_string uri))) - status); - let time1 = Unix.gettimeofday() in - prerr_endline (Printf.sprintf "%1.3f" (time1 -. time) ); - true - with ProofEngineTypes.Fail _ -> - let time1 = Unix.gettimeofday() in - prerr_endline (Printf.sprintf "%1.3f" (time1 -. time)); false) - then - uri::tl',exc - else - tl',exc - with - (ProofEngineTypes.Fail _) as e -> - let exc' = - "

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

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

    Objects that can actually be applied:

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

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

    " ^ - "

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

    " - in - output_html html' ; - uris' -;; - - -(*matchConclusion modificata per evitare una doppia apply*) -let matchConclusion2 mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status = - let ((_, metasenv, _, _), metano) = status in - let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in - let conn = - match mqi_handle.MQIConn.pgc with - MQIConn.MySQL_C conn -> conn - | _ -> assert false in - let uris = Match_concl.cmatch conn ty in - (* List.iter - (fun (n,u) -> prerr_endline ((string_of_int n) ^ " " ^u)) uris; *) - (* delete all .var uris *) - let uris = List.filter UriManager.is_var uris in - (* delete all not "cic:/Coq" uris *) - (* - let uris = - (* TODO ristretto per ragioni di efficienza *) - List.filter (fun _,uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris in - *) - (* concl_cost are the costants in the conclusion of the proof - while hyp_const are the constants in the hypothesis *) - let (main_concl,concl_const) = NewConstraints.mainandcons ty in - prerr_endline ("Ne sono rimasti" ^ string_of_int (List.length uris)); - let hyp t set = - match t with - Some (_,Cic.Decl t) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t)) - | Some (_,Cic.Def (t,_)) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t)) - | _ -> set in - let hyp_const = - List.fold_right hyp ey NewConstraints.StringSet.empty in - prerr_endline (NewConstraints.pp_StringSet (NewConstraints.StringSet.union hyp_const concl_const)); - (* uris with new constants in the proof are filtered *) - let all_const = NewConstraints.StringSet.union hyp_const concl_const in - let uris = - if (List.length uris < (Filter_auto.power 2 (List.length (NewConstraints.StringSet.elements all_const)))) - then - (prerr_endline("metodo vecchio");List.filter (Filter_auto.filter_new_constants conn all_const) uris) - else Filter_auto.filter_uris conn all_const uris main_concl in -(* - let uris = - (* ristretto all cache *) - prerr_endline "SOLO CACHE"; - List.filter - (fun uri -> CicEnvironment.in_cache (UriManager.uri_of_string uri)) uris - in - prerr_endline "HO FILTRATO2"; -*) - let uris = - List.map - (fun (n,u) -> - (n,MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' u)) - uris in - let uris' = - let rec filter_out = - function - [] -> [] - | (m,uri)::tl -> - let tl' = filter_out tl in - try - prerr_endline ("STO APPLICANDO " ^ uri); - let res = (m, - (ProofEngineTypes.apply_tactic( PrimitiveTactics.apply_tac - ~term:(MQueryMisc.term_of_cic_textual_parser_uri - (MQueryMisc.cic_textual_parser_uri_of_string uri))) - status))::tl' in - prerr_endline ("OK");res - (* with ProofEngineTypes.Fail _ -> tl' *) - (* patch to cover CSC's exportation bug *) - with _ -> prerr_endline ("FAIL");tl' - in - prerr_endline ("Ne sono rimasti 2 " ^ string_of_int (List.length uris)); - filter_out uris - in - prerr_endline ("Ne sono rimasti 3 " ^ string_of_int (List.length uris')); - - uris' -;; - -(*funzione che sceglie il penultimo livello di profondita' dei must*) - -(* -let choose_must list_of_must only= -let n = (List.length list_of_must) - 1 in - List.nth list_of_must n -;;*) - -(* questa prende solo il main *) -let choose_must list_of_must only = - List.nth list_of_must 0 - -(* livello 1 -let choose_must list_of_must only = - try - List.nth list_of_must 1 - with _ -> - List.nth list_of_must 0 *) - -let searchTheorems mqi_handle (proof,goal) = - let subproofs = - matchConclusion2 mqi_handle ~choose_must() (proof, goal) in - let res = - List.sort - (fun (n1,(_,gl1)) (n2,(_,gl2)) -> - let l1 = List.length gl1 in - let l2 = List.length gl2 in - (* if the list of subgoals have the same lenght we use the - prefix tag, where higher tags have precedence *) - if l1 = l2 then n2 - n1 - else l1 - l2) - subproofs - in - (* now we may drop the prefix tag *) - (*let res' = - List.map snd res in*) - let order_goal_list proof goal1 goal2 = - let _,metasenv,_,_ = proof in - let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in - let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in -(* - prerr_endline "PRIMA DELLA PRIMA TYPE OF " ; -*) - let ty_sort1,u = (*TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.empty_ugraph in -(* - prerr_endline (Printf.sprintf "PRIMA DELLA SECONDA TYPE OF %s \n### %s @@@%s " (CicMetaSubst.ppmetasenv metasenv []) (CicMetaSubst.ppcontext [] ey2) (CicMetaSubst.ppterm [] ty2)); -*) - let ty_sort2,u1 = CicTypeChecker.type_of_aux' metasenv ey2 ty2 u in -(* - prerr_endline "DOPO LA SECONDA TYPE OF " ; -*) - let b,u2 = - CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1 u1 in - let prop1 = if b then 0 else 1 in - let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2 u2 in - let prop2 = if b then 0 else 1 in - prop1 - prop2 in - List.map ( - fun (level,(proof,goallist)) -> - (proof, (List.stable_sort (order_goal_list proof) goallist)) - ) res -;; - diff --git a/helm/ocaml/tactics/tacticals.ml b/helm/ocaml/tactics/tacticals.ml deleted file mode 100644 index a674fe313..000000000 --- a/helm/ocaml/tactics/tacticals.ml +++ /dev/null @@ -1,351 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -(* open CicReduction -open ProofEngineTypes -open UriManager *) - -(** DEBUGGING *) - - (** perform debugging output? *) -let debug = false -let debug_print = fun _ -> () - - (** debugging print *) -let info s = debug_print (lazy ("TACTICALS INFO: " ^ (Lazy.force s))) - -let id_tac = - let id_tac (proof,goal) = - let _, metasenv, _, _ = proof in - let _, _, _ = CicUtil.lookup_meta goal metasenv in - (proof,[goal]) - in - ProofEngineTypes.mk_tactic id_tac - -let fail_tac = - let fail_tac (proof,goal) = - let _, metasenv, _, _ = proof in - let _, _, _ = CicUtil.lookup_meta goal metasenv in - raise (ProofEngineTypes.Fail (lazy "fail tactical")) - in - ProofEngineTypes.mk_tactic fail_tac - -type goal = ProofEngineTypes.goal - - (** TODO needed until tactics start returning both opened and closed goals - * First part of the function performs a diff among goals ~before tactic - * application and ~after it. Second part will add as both opened and closed - * the goals which are returned as opened by the tactic *) -let goals_diff ~before ~after ~opened = - let sort_opened opened add = - opened @ (List.filter (fun g -> not (List.mem g opened)) add) - in - let remove = - List.fold_left - (fun remove e -> if List.mem e after then remove else e :: remove) - [] before - in - let add = - List.fold_left - (fun add e -> if List.mem e before then add else e :: add) - [] - after - in - let add, remove = (* adds goals which have been both opened _and_ closed *) - List.fold_left - (fun (add, remove) opened_goal -> - if List.mem opened_goal before - then opened_goal :: add, opened_goal :: remove - else add, remove) - (add, remove) - opened - in - sort_opened opened add, remove - -module type T = -sig - type tactic - val first: tactics: (string * tactic) list -> tactic - val thens: start: tactic -> continuations: tactic list -> tactic - val then_: start: tactic -> continuation: tactic -> tactic - val seq: tactics: tactic list -> tactic - val repeat_tactic: tactic: tactic -> tactic - val do_tactic: n: int -> tactic: tactic -> tactic - val try_tactic: tactic: tactic -> tactic - val solve_tactics: tactics: (string * tactic) list -> tactic - - val tactic: tactic -> tactic - val skip: tactic - val dot: tactic - val semicolon: tactic - val branch: tactic - val shift: tactic - val pos: int -> tactic - val merge: tactic - val focus: int list -> tactic - val unfocus: tactic -end - -module Make (S: Continuationals.Status) : T with type tactic = S.tactic = -struct - module C = Continuationals.Make (S) - - type tactic = S.tactic - - let fold_eval status ts = - let istatus = - List.fold_left (fun istatus t -> S.focus ~-1 (C.eval t istatus)) status ts - in - S.inject istatus - - (** - 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") - *) - let first ~tactics = - let rec first ~(tactics: (string * tactic) list) istatus = - info (lazy "in Tacticals.first"); - match tactics with - | (descr, tac)::tactics -> - info (lazy ("Tacticals.first IS TRYING " ^ descr)); - (try - let res = S.apply_tactic tac istatus in - info (lazy ("Tacticals.first: " ^ descr ^ " succedeed!!!")); - res - with - e -> - match e with - | (ProofEngineTypes.Fail _) - | (CicTypeChecker.TypeCheckerFailure _) - | (CicUnification.UnificationFailure _) -> - info (lazy ( - "Tacticals.first failed with exn: " ^ - Printexc.to_string e)); - first ~tactics istatus - | _ -> raise e) (* [e] must not be caught ; let's re-raise it *) - | [] -> raise (ProofEngineTypes.Fail (lazy "first: no tactics left")) - in - S.mk_tactic (first ~tactics) - - let thens ~start ~continuations = - S.mk_tactic - (fun istatus -> - fold_eval istatus - ([ C.Tactical (C.Tactic start); C.Branch ] - @ (HExtlib.list_concat ~sep:[ C.Shift ] - (List.map (fun t -> [ C.Tactical (C.Tactic t) ]) continuations)) - @ [ C.Merge ])) - - let then_ ~start ~continuation = - S.mk_tactic - (fun istatus -> - let ostatus = C.eval (C.Tactical (C.Tactic start)) istatus in - let opened,closed = S.goals ostatus in - match opened with - [] -> ostatus - | _ -> - fold_eval (S.focus ~-1 ostatus) - [ C.Semicolon; - C.Tactical (C.Tactic continuation) ]) - - let seq ~tactics = - S.mk_tactic - (fun istatus -> - fold_eval istatus - (HExtlib.list_concat ~sep:[ C.Semicolon ] - (List.map (fun t -> [ C.Tactical (C.Tactic t) ]) tactics))) - - (* TODO: x debug: i due tatticali seguenti non contano quante volte hanno - * applicato la tattica *) - - let rec step f output_status opened closed = - match opened with - | [] -> output_status, [], closed - | head :: tail -> - let status = S.focus head output_status in - let output_status' = f status in - let opened', closed' = S.goals output_status' in - let output_status'', opened'', closed'' = - step f output_status' tail [] - in - output_status'', opened' @ opened'', closed' @ closed'' - - (* This keep on appling tactic until it fails. When generates more - * than one goal, you have a tree of application on the tactic, repeat_tactic - * works in depth on this tree *) - let repeat_tactic ~tactic = - let rec repeat_tactic ~tactic status = - info (lazy "in repeat_tactic"); - try - let output_status = S.apply_tactic tactic status in - let opened, closed = S.goals output_status in - let output_status, opened', closed' = - step (repeat_tactic ~tactic) output_status opened closed - in - S.set_goals (opened', closed') output_status - with - (ProofEngineTypes.Fail _) as e -> - info (lazy - ("Tacticals.repeat_tactic failed after nth time with exception: " - ^ Printexc.to_string e)); - S.apply_tactic S.id_tactic status - in - S.mk_tactic (repeat_tactic ~tactic) - - (* This tries to apply tactic n times *) - let do_tactic ~n ~tactic = - let rec do_tactic ~n ~tactic status = - if n = 0 then - S.apply_tactic S.id_tactic status - else - try - let output_status = S.apply_tactic tactic status in - let opened, closed = S.goals output_status in - let output_status, opened', closed' = - step (do_tactic ~n:(n-1) ~tactic) output_status opened closed - in - S.set_goals (opened', closed') output_status - with - (ProofEngineTypes.Fail _) as e -> - info (lazy - ("Tacticals.do_tactic failed after nth time with exception: " - ^ Printexc.to_string e)) ; - S.apply_tactic S.id_tactic status - in - S.mk_tactic (do_tactic ~n ~tactic) - - (* This applies tactic and catches its possible failure *) - let try_tactic ~tactic = - let rec try_tactic ~tactic status = - info (lazy "in Tacticals.try_tactic"); - try - S.apply_tactic tactic status - with - (ProofEngineTypes.Fail _) as e -> - info (lazy ( - "Tacticals.try_tactic failed with exn: " ^ Printexc.to_string e)); - S.apply_tactic S.id_tactic status - in - S.mk_tactic (try_tactic ~tactic) - - (* This tries tactics until one of them doesn't _solve_ the goal *) - (* TODO: si puo' unificare le 2(due) chiamate ricorsive? *) - let solve_tactics ~tactics = - let rec solve_tactics ~(tactics: (string * tactic) list) status = - info (lazy "in Tacticals.solve_tactics"); - match tactics with - | (descr, currenttactic)::moretactics -> - info (lazy ("Tacticals.solve_tactics is trying " ^ descr)); - (try - let output_status = S.apply_tactic currenttactic status in - let opened, closed = S.goals output_status in - match opened with - | [] -> info (lazy ("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!) *) - output_status - | _ -> info (lazy ("Tacticals.solve_tactics: try the next tactic")); - solve_tactics ~tactics:(moretactics) status - with - (ProofEngineTypes.Fail _) as e -> - info (lazy ( - "Tacticals.solve_tactics: current tactic failed with exn: " - ^ Printexc.to_string e)); - solve_tactics ~tactics status - ) - | [] -> - raise (ProofEngineTypes.Fail - (lazy "solve_tactics cannot solve the goal")) - in - S.mk_tactic (solve_tactics ~tactics) - - let cont_proxy cont = S.mk_tactic (C.eval cont) - - let tactic t = cont_proxy (C.Tactical (C.Tactic t)) - let skip = cont_proxy (C.Tactical C.Skip) - let dot = cont_proxy C.Dot - let semicolon = cont_proxy C.Semicolon - let branch = cont_proxy C.Branch - let shift = cont_proxy C.Shift - let pos i = cont_proxy (C.Pos i) - let merge = cont_proxy C.Merge - let focus goals = cont_proxy (C.Focus goals) - let unfocus = cont_proxy C.Unfocus -end - -module ProofEngineStatus = -struct - module Stack = Continuationals.Stack - - type input_status = - ProofEngineTypes.status (* (proof, goal) *) * Stack.t - - type output_status = - (ProofEngineTypes.proof * goal list * goal list) * Stack.t - - type tactic = ProofEngineTypes.tactic - - let id_tactic = id_tac - - let mk_tactic f = - ProofEngineTypes.mk_tactic - (fun (proof, goal) as pstatus -> - let stack = [ [ 1, Stack.Open goal ], [], [], `NoTag ] in - let istatus = pstatus, stack in -(* let ostatus = f istatus in - let ((proof, opened, _), _) = ostatus in *) - let (proof, _, _), stack = f istatus in - let opened = Continuationals.Stack.open_goals stack in - proof, opened) - - let apply_tactic tac ((proof, _) as pstatus, stack) = - let proof', opened = ProofEngineTypes.apply_tactic tac pstatus in -(* let _ = prerr_endline ("goal aperti dalla tattica " ^ String.concat "," (List.map string_of_int opened)) in *) - let before = ProofEngineTypes.goals_of_proof proof in - let after = ProofEngineTypes.goals_of_proof proof' in - let opened_goals, closed_goals = goals_diff ~before ~after ~opened in -(* let _ = prerr_endline ("goal ritornati dalla tattica " ^ String.concat "," (List.map string_of_int opened_goals)) in *) - (proof', opened_goals, closed_goals), stack - - let goals ((_, opened, closed), _) = opened, closed - let set_goals (opened, closed) ((proof, _, _), stack) = - (proof, opened, closed), stack - - let get_stack = snd - let set_stack stack (opstatus, _) = opstatus, stack - - let inject ((proof, _), stack) = ((proof, [], []), stack) - let focus goal ((proof, _, _), stack) = (proof, goal), stack -end - -module ProofEngineTacticals = Make (ProofEngineStatus) - -include ProofEngineTacticals - diff --git a/helm/ocaml/tactics/tacticals.mli b/helm/ocaml/tactics/tacticals.mli deleted file mode 100644 index 88fafc1f8..000000000 --- a/helm/ocaml/tactics/tacticals.mli +++ /dev/null @@ -1,92 +0,0 @@ -(* 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 -val fail_tac: ProofEngineTypes.tactic - -(* module type Status = - sig -|+ type external_input_status +| - type input_status - type output_status -|+ type external_output_status +| - -|+ val internalize: external_input_status -> input_status - val externalize: output_status -> external_output_status +| - - type tactic - - val mk_tactic : (input_status -> output_status) -> tactic - val apply_tactic : tactic -> input_status -> output_status - - val id_tac : tactic - - val goals : output_status -> ProofEngineTypes.goal list - val get_stack : input_status -> stack - val set_stack : stack -> output_status -> output_status - - val inject : input_status -> output_status - val focus : goal -> output_status -> input_status - end *) - -module type T = -sig - type tactic - - val first: tactics: (string * tactic) list -> tactic - val thens: start: tactic -> continuations: tactic list -> tactic - val then_: start: tactic -> continuation: tactic -> tactic - val seq: tactics: tactic list -> tactic (** "folding" of then_ *) - val repeat_tactic: tactic: tactic -> tactic - val do_tactic: n: int -> tactic: tactic -> tactic - val try_tactic: tactic: tactic -> tactic - val solve_tactics: tactics: (string * tactic) list -> tactic - -(* module C: - sig *) - val tactic: tactic -> tactic (** apply tactic to all goal in env *) - val skip: tactic - val dot: tactic - val semicolon: tactic - val branch: tactic - val shift: tactic - val pos: int -> tactic - val merge: tactic - val focus: int list -> tactic - val unfocus: tactic -(* end *) -end - -module Make (S: Continuationals.Status) : T with type tactic = S.tactic - -include T with type tactic = ProofEngineTypes.tactic - -(* TODO temporary *) -val goals_diff: - before:ProofEngineTypes.goal list -> - after:ProofEngineTypes.goal list -> - opened:ProofEngineTypes.goal list -> - ProofEngineTypes.goal list * ProofEngineTypes.goal list - diff --git a/helm/ocaml/tactics/tactics.ml b/helm/ocaml/tactics/tactics.ml deleted file mode 100644 index fe8adc549..000000000 --- a/helm/ocaml/tactics/tactics.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* Copyright (C) 2004, 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/. - *) - -(* $Id$ *) - -let absurd = NegationTactics.absurd_tac -let apply = PrimitiveTactics.apply_tac -let assumption = VariousTactics.assumption_tac -let auto = AutoTactic.auto_tac -let change = ReductionTactics.change_tac -let clear = ProofEngineStructuralRules.clear -let clearbody = ProofEngineStructuralRules.clearbody -let compare = DiscriminationTactics.compare_tac -let constructor = IntroductionTactics.constructor_tac -let contradiction = NegationTactics.contradiction_tac -let cut = PrimitiveTactics.cut_tac -let decide_equality = DiscriminationTactics.decide_equality_tac -let decompose = EliminationTactics.decompose_tac -let demodulate = Saturation.demodulate_tac -let discriminate = DiscriminationTactics.discriminate_tac -let elim_intros = PrimitiveTactics.elim_intros_tac -let elim_intros_simpl = PrimitiveTactics.elim_intros_simpl_tac -let elim_type = EliminationTactics.elim_type_tac -let exact = PrimitiveTactics.exact_tac -let exists = IntroductionTactics.exists_tac -let fail = Tacticals.fail_tac -let fold = ReductionTactics.fold_tac -let fourier = FourierR.fourier_tac -let fwd_simpl = FwdSimplTactic.fwd_simpl_tac -let generalize = VariousTactics.generalize_tac -let id = Tacticals.id_tac -let injection = DiscriminationTactics.injection_tac -let intros = PrimitiveTactics.intros_tac -let inversion = Inversion.inversion_tac -let lapply = FwdSimplTactic.lapply_tac -let left = IntroductionTactics.left_tac -let letin = PrimitiveTactics.letin_tac -let normalize = ReductionTactics.normalize_tac -let reduce = ReductionTactics.reduce_tac -let reflexivity = EqualityTactics.reflexivity_tac -let replace = EqualityTactics.replace_tac -let rewrite = EqualityTactics.rewrite_tac -let rewrite_simpl = EqualityTactics.rewrite_simpl_tac -let right = IntroductionTactics.right_tac -let ring = Ring.ring_tac -let set_goal = ProofEngineStructuralRules.set_goal -let simpl = ReductionTactics.simpl_tac -let split = IntroductionTactics.split_tac -let symmetry = EqualityTactics.symmetry_tac -let transitivity = EqualityTactics.transitivity_tac -let unfold = ReductionTactics.unfold_tac -let whd = ReductionTactics.whd_tac diff --git a/helm/ocaml/tactics/tactics.mli b/helm/ocaml/tactics/tactics.mli deleted file mode 100644 index c8c225cdd..000000000 --- a/helm/ocaml/tactics/tactics.mli +++ /dev/null @@ -1,93 +0,0 @@ -(* GENERATED FILE, DO NOT EDIT *) -val absurd : term:Cic.term -> ProofEngineTypes.tactic -val apply : term:Cic.term -> ProofEngineTypes.tactic -val assumption : ProofEngineTypes.tactic -val auto : - ?depth:int -> - ?width:int -> - ?paramodulation:string -> - ?full:string -> dbd:HMysql.dbd -> unit -> ProofEngineTypes.tactic -val change : - pattern:ProofEngineTypes.lazy_pattern -> - Cic.lazy_term -> ProofEngineTypes.tactic -val clear : hyp:string -> ProofEngineTypes.tactic -val clearbody : hyp:string -> ProofEngineTypes.tactic -val compare : term:Cic.term -> ProofEngineTypes.tactic -val constructor : n:int -> ProofEngineTypes.tactic -val contradiction : ProofEngineTypes.tactic -val cut : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - Cic.term -> ProofEngineTypes.tactic -val decide_equality : ProofEngineTypes.tactic -val decompose : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?user_types:(UriManager.uri * int) list -> - dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic -val demodulate : - dbd:HMysql.dbd -> - pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val discriminate : term:Cic.term -> ProofEngineTypes.tactic -val elim_intros : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic -val elim_intros_simpl : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic -val elim_type : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic -val exact : term:Cic.term -> ProofEngineTypes.tactic -val exists : ProofEngineTypes.tactic -val fail : ProofEngineTypes.tactic -val fold : - reduction:ProofEngineTypes.lazy_reduction -> - term:Cic.lazy_term -> - pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val fourier : ProofEngineTypes.tactic -val fwd_simpl : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic -val generalize : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val id : ProofEngineTypes.tactic -val injection : term:Cic.term -> ProofEngineTypes.tactic -val intros : - ?howmany:int -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - unit -> ProofEngineTypes.tactic -val inversion : term:Cic.term -> ProofEngineTypes.tactic -val lapply : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?how_many:int -> - ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic -val left : ProofEngineTypes.tactic -val letin : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - Cic.term -> ProofEngineTypes.tactic -val normalize : - pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val reduce : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val reflexivity : ProofEngineTypes.tactic -val replace : - pattern:ProofEngineTypes.lazy_pattern -> - with_what:Cic.lazy_term -> ProofEngineTypes.tactic -val rewrite : - direction:[ `LeftToRight | `RightToLeft ] -> - pattern:ProofEngineTypes.lazy_pattern -> - Cic.term -> ProofEngineTypes.tactic -val rewrite_simpl : - direction:[ `LeftToRight | `RightToLeft ] -> - pattern:ProofEngineTypes.lazy_pattern -> - Cic.term -> ProofEngineTypes.tactic -val right : ProofEngineTypes.tactic -val ring : ProofEngineTypes.tactic -val set_goal : int -> ProofEngineTypes.tactic -val simpl : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val split : ProofEngineTypes.tactic -val symmetry : ProofEngineTypes.tactic -val transitivity : term:Cic.term -> ProofEngineTypes.tactic -val unfold : - Cic.lazy_term option -> - pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val whd : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic diff --git a/helm/ocaml/tactics/variousTactics.ml b/helm/ocaml/tactics/variousTactics.ml deleted file mode 100644 index bc7b52200..000000000 --- a/helm/ocaml/tactics/variousTactics.ml +++ /dev/null @@ -1,191 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - - -(* 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 = - let module PET = ProofEngineTypes in - let assumption_tac status = - let (proof, goal) = status in - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module PT = PrimitiveTactics in - let _,metasenv,_,_ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let rec find n = function - hd::tl -> - (match hd with - (Some (_, C.Decl t)) when - fst (R.are_convertible context (S.lift n t) ty - CicUniv.empty_ugraph) -> n - | (Some (_, C.Def (_,Some ty'))) when - fst (R.are_convertible context (S.lift n ty') ty - CicUniv.empty_ugraph) -> n - | (Some (_, C.Def (t,None))) -> - let ty_t, u = (* TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv context (S.lift n t) - CicUniv.empty_ugraph in - let b,_ = R.are_convertible context ty_t ty u in - if b then n else find (n+1) tl - | _ -> find (n+1) tl - ) - | [] -> raise (PET.Fail (lazy "Assumption: No such assumption")) - in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status - in - PET.mk_tactic assumption_tac -;; - -(* ANCORA DA DEBUGGARE *) - -exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;; -exception TheSelectedTermsMustLiveInTheGoalContext -exception AllSelectedTermsMustBeConvertible;; -exception GeneralizationInHypothesesNotImplementedYet;; - -let generalize_tac - ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - pattern - = - let module PET = ProofEngineTypes in - let generalize_tac mk_fresh_name_callback - ~pattern:(term,hyps_pat,concl_pat) status - = - if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet; - let (proof, goal) = status in - let module C = Cic in - let module P = PrimitiveTactics in - let module T = Tacticals in - let uri,metasenv,pbo,pty = proof in - let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in - let subst,metasenv,u,selected_hyps,terms_with_context = - ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph - ~conjecture ~pattern in - let context = CicMetaSubst.apply_subst_context subst context in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let pbo = CicMetaSubst.apply_subst subst pbo in - let pty = CicMetaSubst.apply_subst subst pty in - let term = - match term with - None -> None - | Some term -> - Some (fun context metasenv ugraph -> - let term, metasenv, ugraph = term context metasenv ugraph in - CicMetaSubst.apply_subst subst term, - CicMetaSubst.apply_subst_metasenv subst metasenv, - ugraph) - in - let u,typ,term, metasenv' = - let context_of_t, (t, metasenv, u) = - match terms_with_context, term with - [], None -> - raise - UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly - | [], Some t -> context, t context metasenv u - | (context_of_t, _)::_, Some t -> - context_of_t, t context_of_t metasenv u - | (context_of_t, t)::_, None -> context_of_t, (t, metasenv, u) - in - let t,subst,metasenv' = - try - CicMetaSubst.delift_rels [] metasenv - (List.length context_of_t - List.length context) t - with - CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> - raise TheSelectedTermsMustLiveInTheGoalContext - in - (*CSC: I am not sure about the following two assertions; - maybe I need to propagate the new subst and metasenv *) - assert (subst = []); - assert (metasenv' = metasenv); - let typ,u = CicTypeChecker.type_of_aux' ~subst metasenv context t u in - u,typ,t,metasenv - in - (* We need to check: - 1. whether they live in the context of the goal; - if they do they are also well-typed since they are closed subterms - of a well-typed term in the well-typed context of the well-typed - term - 2. whether they are convertible - *) - ignore ( - List.fold_left - (fun u (context_of_t,t) -> - (* 1 *) - let t,subst,metasenv'' = - try - CicMetaSubst.delift_rels [] metasenv' - (List.length context_of_t - List.length context) t - with - CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> - raise TheSelectedTermsMustLiveInTheGoalContext in - (*CSC: I am not sure about the following two assertions; - maybe I need to propagate the new subst and metasenv *) - assert (subst = []); - assert (metasenv'' = metasenv'); - (* 2 *) - let b,u1 = CicReduction.are_convertible ~subst context term t u in - if not b then - raise AllSelectedTermsMustBeConvertible - else - u1 - ) u terms_with_context) ; - let status = (uri,metasenv',pbo,pty),goal in - let proof,goals = - PET.apply_tactic - (T.thens - ~start: - (P.cut_tac - (C.Prod( - (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ), - typ, - (ProofEngineReduction.replace_lifting_csc 1 - ~equality:(==) - ~what:(List.map snd terms_with_context) - ~with_what:(List.map (function _ -> C.Rel 1) terms_with_context) - ~where:ty) - ))) - ~continuations: - [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ; - T.id_tac]) - status - in - let _,metasenv'',_,_ = proof in - (* CSC: the following is just a bad approximation since a meta - can be closed and then re-opened! *) - (proof, - goals @ - (List.filter - (fun j -> List.exists (fun (i,_,_) -> i = j) metasenv'') - (ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv - ~newmetasenv:metasenv'))) - in - PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern) -;; diff --git a/helm/ocaml/tactics/variousTactics.mli b/helm/ocaml/tactics/variousTactics.mli deleted file mode 100644 index 35576326e..000000000 --- a/helm/ocaml/tactics/variousTactics.mli +++ /dev/null @@ -1,35 +0,0 @@ - -(* 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 -> - ProofEngineTypes.lazy_pattern -> - ProofEngineTypes.tactic - diff --git a/helm/ocaml/thread/.depend b/helm/ocaml/thread/.depend deleted file mode 100644 index 7759190c6..000000000 --- a/helm/ocaml/thread/.depend +++ /dev/null @@ -1,4 +0,0 @@ -threadSafe.cmo: threadSafe.cmi -threadSafe.cmx: threadSafe.cmi -extThread.cmo: extThread.cmi -extThread.cmx: extThread.cmi diff --git a/helm/ocaml/thread/Makefile b/helm/ocaml/thread/Makefile deleted file mode 100644 index 46f009e07..000000000 --- a/helm/ocaml/thread/Makefile +++ /dev/null @@ -1,31 +0,0 @@ - -PACKAGE = thread -INTERFACE_FILES = threadSafe.mli extThread.mli -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -all: thread_fake.cma -opt: thread_fake.cmxa - -include ../../Makefile.defs -include ../Makefile.common - -fake/threadSafe.cmi: fake/threadSafe.mli - @echo " OCAMLC $<" - @cd fake/ \ - && ocamlfind ocamlc -c threadSafe.mli -thread_fake.cma: fake/threadSafe.cmi - @echo " OCAMLC -a $@" - @cd fake/ \ - && ocamlfind ocamlc -a -o $@ threadSafe.ml \ - && cp $@ ../ -thread_fake.cmxa: fake/threadSafe.cmi - @echo " OCAMLOPT -a $@" - @cd fake/ \ - && ocamlfind opt -a -o $@ threadSafe.ml \ - && cp $@ ../ - -clean: clean_fake -clean_fake: - rm -f fake/*.cm[aiox] fake/*.cmxa fake/*.[ao] - rm -f thread_fake.cma thread_fake.cmxa - diff --git a/helm/ocaml/thread/extThread.ml b/helm/ocaml/thread/extThread.ml deleted file mode 100644 index d59cccd26..000000000 --- a/helm/ocaml/thread/extThread.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -let debug = true -let debug_print s = if debug then prerr_endline (Lazy.force s) - -exception Can_t_kill of Thread.t * string (* thread, reason *) -exception Thread_not_found of Thread.t - -module OrderedPid = - struct - type t = int - let compare = Pervasives.compare - end -module PidSet = Set.Make (OrderedPid) - - (* perform an action inside a critical section controlled by given mutex *) -let do_critical mutex = - fun action -> - try - Mutex.lock mutex; - let res = Lazy.force action in - Mutex.unlock mutex; - res - with e -> Mutex.unlock mutex; raise e - -let kill_signal = Sys.sigusr2 (* signal used to kill children *) -let chan = Event.new_channel () (* communication channel between threads *) -let creation_mutex = Mutex.create () -let dead_threads_walking = ref PidSet.empty -let pids: (Thread.t, int) Hashtbl.t = Hashtbl.create 17 - - (* given a thread body (i.e. first argument of a Thread.create invocation) - return a new thread body which unblock the kill signal and send its pid to - parent over "chan" *) -let wrap_thread body = - fun arg -> - ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [ kill_signal ]); - Event.sync (Event.send chan (Unix.getpid ())); - body arg - -(* -(* FAKE IMPLEMENTATION *) -let create = Thread.create -let kill _ = () -*) - -let create body arg = - do_critical creation_mutex (lazy ( - let thread_t = Thread.create (wrap_thread body) arg in - let pid = Event.sync (Event.receive chan) in - Hashtbl.add pids thread_t pid; - thread_t - )) - -let kill thread_t = - try - let pid = - try - Hashtbl.find pids thread_t - with Not_found -> raise (Thread_not_found thread_t) - in - dead_threads_walking := PidSet.add pid !dead_threads_walking; - Unix.kill pid kill_signal - with e -> raise (Can_t_kill (thread_t, Printexc.to_string e)) - - (* "kill_signal" handler, check if current process must die, if this is the - case exits with Thread.exit *) -let _ = - ignore (Sys.signal kill_signal (Sys.Signal_handle - (fun signal -> - let myself = Unix.getpid () in - match signal with - | sg when (sg = kill_signal) && - (PidSet.mem myself !dead_threads_walking) -> - dead_threads_walking := PidSet.remove myself !dead_threads_walking; - debug_print (lazy "AYEEEEH!"); - Thread.exit () - | _ -> ()))) - - (* block kill signal in main process *) -let _ = ignore (Unix.sigprocmask Unix.SIG_BLOCK [ kill_signal ]) - diff --git a/helm/ocaml/thread/extThread.mli b/helm/ocaml/thread/extThread.mli deleted file mode 100644 index 5fb3bd487..000000000 --- a/helm/ocaml/thread/extThread.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * 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/ - *) - -(** {2 Extended Thread module with killing capabilities} *) - -exception Can_t_kill of Thread.t * string - -val create: ('a -> 'b) -> 'a -> Thread.t -val kill: Thread.t -> unit - diff --git a/helm/ocaml/thread/fake/threadSafe.ml b/helm/ocaml/thread/fake/threadSafe.ml deleted file mode 100644 index b2c427710..000000000 --- a/helm/ocaml/thread/fake/threadSafe.ml +++ /dev/null @@ -1,35 +0,0 @@ -(* - * Copyright (C) 2003-2005: - * Stefano Zacchiroli - * 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/ - *) - -class threadSafe = - object - method private doCritical: 'a. 'a lazy_t -> 'a = fun a -> Lazy.force a - method private doReader: 'a. 'a lazy_t -> 'a = fun a -> Lazy.force a - method private doWriter: 'a. 'a lazy_t -> 'a = fun a -> Lazy.force a - end - diff --git a/helm/ocaml/thread/fake/threadSafe.mli b/helm/ocaml/thread/fake/threadSafe.mli deleted file mode 100644 index 78166abcc..000000000 --- a/helm/ocaml/thread/fake/threadSafe.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -class threadSafe: - object - - (** execute 'action' in mutual exclusion between all other threads *) - method private doCritical: 'a. 'a lazy_t -> 'a - - (** execute 'action' acting as a 'reader' i.e.: multiple readers can act - at the same time but no writer can act until no readers are acting *) - method private doReader: 'a. 'a lazy_t -> 'a - - (** execute 'action' acting as a 'writer' i.e.: when a writer is acting, - no readers or writer can act, beware that writers can starve *) - method private doWriter: 'a. 'a lazy_t -> 'a - - end - diff --git a/helm/ocaml/thread/threadSafe.ml b/helm/ocaml/thread/threadSafe.ml deleted file mode 100644 index afe953370..000000000 --- a/helm/ocaml/thread/threadSafe.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -(* $Id$ *) - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -class threadSafe = - object (self) - - val mutex = Mutex.create () - - (** condition variable: 'no readers is currently reading' *) - val noReaders = Condition.create () - - (** readers count *) - val mutable readersCount = 0 - - method private incrReadersCount = (* internal, not exported *) - self#doCritical (lazy ( - readersCount <- readersCount + 1 - )) - - method private decrReadersCount = (* internal, not exported *) - self#doCritical (lazy ( - if readersCount > 0 then readersCount <- readersCount - 1; - )) - - method private signalNoReaders = (* internal, not exported *) - self#doCritical (lazy ( - if readersCount = 0 then Condition.signal noReaders - )) - - method private doCritical: 'a. 'a lazy_t -> 'a = - fun action -> - debug_print (lazy ""); - (try - Mutex.lock mutex; - let res = Lazy.force action in - Mutex.unlock mutex; - debug_print (lazy ""); - res - with e -> - Mutex.unlock mutex; - raise e); - - method private doReader: 'a. 'a lazy_t -> 'a = - fun action -> - debug_print (lazy ""); - let cleanup () = - self#decrReadersCount; - self#signalNoReaders - in - self#incrReadersCount; - let res = (try Lazy.force action with e -> (cleanup (); raise e)) in - cleanup (); - debug_print (lazy ""); - res - - (* TODO may starve!!!! is what we want or not? *) - method private doWriter: 'a. 'a lazy_t -> 'a = - fun action -> - debug_print (lazy ""); - self#doCritical (lazy ( - while readersCount > 0 do - Condition.wait noReaders mutex - done; - let res = Lazy.force action in - debug_print (lazy ""); - res - )) - - end - diff --git a/helm/ocaml/thread/threadSafe.mli b/helm/ocaml/thread/threadSafe.mli deleted file mode 100644 index 78166abcc..000000000 --- a/helm/ocaml/thread/threadSafe.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Copyright (C) 2003-2004: - * Stefano Zacchiroli - * 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/ - *) - -class threadSafe: - object - - (** execute 'action' in mutual exclusion between all other threads *) - method private doCritical: 'a. 'a lazy_t -> 'a - - (** execute 'action' acting as a 'reader' i.e.: multiple readers can act - at the same time but no writer can act until no readers are acting *) - method private doReader: 'a. 'a lazy_t -> 'a - - (** execute 'action' acting as a 'writer' i.e.: when a writer is acting, - no readers or writer can act, beware that writers can starve *) - method private doWriter: 'a. 'a lazy_t -> 'a - - end - diff --git a/helm/ocaml/urimanager/.depend b/helm/ocaml/urimanager/.depend deleted file mode 100644 index 482148423..000000000 --- a/helm/ocaml/urimanager/.depend +++ /dev/null @@ -1,2 +0,0 @@ -uriManager.cmo: uriManager.cmi -uriManager.cmx: uriManager.cmi diff --git a/helm/ocaml/urimanager/Makefile b/helm/ocaml/urimanager/Makefile deleted file mode 100644 index 592c0854e..000000000 --- a/helm/ocaml/urimanager/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -PACKAGE = urimanager -PREDICATES = - -INTERFACE_FILES = uriManager.mli -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/urimanager/uriManager.ml b/helm/ocaml/urimanager/uriManager.ml deleted file mode 100644 index 9ff6a7966..000000000 --- a/helm/ocaml/urimanager/uriManager.ml +++ /dev/null @@ -1,225 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -(* - * "cic:/a/b/c.con" => ("cic:/a/b/c.con", id ) - * "cic:/a/b/c.ind#xpointer(1/1)" => ("cic:/a/b/c.con#xpointer(1/1)", id) - * "cic:/a/b/c.ind#xpointer(1/1/1)" => ("cic:/a/b/c.con#xpointer(1/1/1)", id) - *) - -let fresh_id = - let id = ref 0 in - function () -> - incr id; - !id - -(* (uriwithxpointer, uniqueid) - * where uniqueid is used to build a set of uri *) -type uri = string * int;; - -let eq uri1 uri2 = - uri1 == uri2 -;; - -let string_of_uri (uri,_) = - uri - -let name_of_uri (uri, _) = - let xpointer_offset = - try String.rindex uri '#' with Not_found -> String.length uri - 1 - in - let index1 = String.rindex_from uri xpointer_offset '/' + 1 in - let index2 = String.rindex uri '.' in - String.sub uri index1 (index2 - index1) - -let buri_of_uri (uri,_) = - let xpointer_offset = - try String.rindex uri '#' with Not_found -> String.length uri - 1 - in - let index = String.rindex_from uri xpointer_offset '/' in - String.sub uri 0 index - -module OrderedStrings = - struct - type t = string - let compare (s1 : t) (s2 : t) = compare s1 s2 - end -;; - -module MapStringsToUri = Map.Make(OrderedStrings);; - -(* Invariant: the map is the identity function, - * i.e. - * let str' = (MapStringsToUri.find str !set_of_uri) in - * str' == (MapStringsToUri.find str' !set_of_uri) - *) -let set_of_uri = ref MapStringsToUri.empty;; - -exception IllFormedUri of string;; - -let _dottypes = ".types" -let _types = "types",5 -let _dotuniv = ".univ" -let _univ = "univ",4 -let _dotann = ".ann" -let _ann = "ann",3 -let _var = "var",3 -let _dotbody = ".body" -let _con = "con",3 -let _ind = "ind",3 -let _xpointer = "#xpointer(1/" -let _con3 = "con" -let _var3 = "var" -let _ind3 = "ind" -let _ann3 = "ann" -let _univ4 = "univ" -let _types5 = "types" -let _xpointer8 = "xpointer" -let _cic5 = "cic:/" - -let is_malformed suri = - try - if String.sub suri 0 5 <> _cic5 then true - else - let len = String.length suri - 5 in - let last5 = String.sub suri len 5 in - let last4 = String.sub last5 1 4 in - let last3 = String.sub last5 2 3 in - if last3 = _con3 || last3 = _var3 || last3 = _ind3 || - last3 = _ann3 || last5 = _types5 || last5 = _dotbody || - last4 = _univ4 then - false - else - try - let index = String.rindex suri '#' + 1 in - let xptr = String.sub suri index 8 in - if xptr = _xpointer8 then - false - else - true - with Not_found -> true - with Invalid_argument _ -> true - -(* hash conses an uri *) -let uri_of_string suri = - try - MapStringsToUri.find suri !set_of_uri - with Not_found -> - if is_malformed suri then - raise (IllFormedUri suri) - else - let new_uri = suri, fresh_id () in - set_of_uri := MapStringsToUri.add suri new_uri !set_of_uri; - new_uri - - -let strip_xpointer ((uri,_) as olduri) = - try - let index = String.rindex uri '#' in - let no_xpointer = String.sub uri 0 index in - uri_of_string no_xpointer - with - Not_found -> olduri - -let clear_suffix uri ?(pat2="",0) pat1 = - try - let index = String.rindex uri '.' in - let index' = index + 1 in - let suffix = String.sub uri index' (String.length uri - index') in - if fst pat1 = suffix || fst pat2 = suffix then - String.sub uri 0 index - else - uri - with - Not_found -> assert false - -let has_suffix uri (pat,n) = - try - let suffix = String.sub uri (String.length uri - n) n in - pat = suffix - with - Not_found -> assert false - - -let cicuri_of_uri (uri, _) = uri_of_string (clear_suffix uri ~pat2:_types _ann) - -let annuri_of_uri (uri , _) = uri_of_string ((clear_suffix uri _ann) ^ _dotann) - -let uri_is_annuri (uri, _) = has_suffix uri _ann - -let uri_is_var (uri, _) = has_suffix uri _var - -let uri_is_con (uri, _) = has_suffix uri _con - -let uri_is_ind (uri, _) = has_suffix uri _ind - -let bodyuri_of_uri (uri, _) = - if has_suffix uri _con then - Some (uri_of_string (uri ^ _dotbody)) - else - None -;; - -(* these are bugged! - * we should remove _types, _univ, _ann all toghether *) -let innertypesuri_of_uri (uri, _) = - uri_of_string ((clear_suffix uri _types) ^ _dottypes) -;; -let univgraphuri_of_uri (uri,_) = - uri_of_string ((clear_suffix uri _univ) ^ _dotuniv) -;; - - -let uri_of_uriref (uri, _) typeno consno = - let typeno = typeno + 1 in - let suri = - match consno with - | None -> Printf.sprintf "%s%s%d)" uri _xpointer typeno - | Some n -> Printf.sprintf "%s%s%d/%d)" uri _xpointer typeno n - in - uri_of_string suri - -let compare (_,id1) (_,id2) = id1 - id2 - -module OrderedUri = -struct - type t = uri - let compare = compare (* the one above, not Pervasives.compare *) -end - -module UriSet = Set.Make (OrderedUri) - -module HashedUri = -struct - type t = uri - let equal = eq - let hash = snd -end - -module UriHashtbl = Hashtbl.Make (HashedUri) - - diff --git a/helm/ocaml/urimanager/uriManager.mli b/helm/ocaml/urimanager/uriManager.mli deleted file mode 100644 index 8250cc839..000000000 --- a/helm/ocaml/urimanager/uriManager.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* 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 IllFormedUri of string;; - -type uri - -val eq : uri -> uri -> bool -val compare : uri -> uri -> int - -val uri_of_string : string -> uri - -val string_of_uri : uri -> string (* complete uri *) -val name_of_uri : uri -> string (* name only (without extension)*) -val buri_of_uri : uri -> string (* base uri only, without trailing '/' *) - -(* given an uri, returns the uri of the corresponding cic file, *) -(* i.e. removes the [.types][.ann] suffix *) -val cicuri_of_uri : uri -> uri - -val strip_xpointer: uri -> uri (* remove trailing #xpointer..., if any *) - -(* given an uri, returns the uri of the corresponding annotation file, *) -(* i.e. adds the .ann suffix if not already present *) -val annuri_of_uri : uri -> uri - -val uri_is_annuri : uri -> bool -val uri_is_var : uri -> bool -val uri_is_con : uri -> bool -val uri_is_ind : 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 -(* given an uri, it gives back the uri of its univgraph *) -val univgraphuri_of_uri : uri -> uri - -(* builder for MutInd and MutConstruct URIs - * [uri] -> [typeno] -> [consno option] - *) -val uri_of_uriref : uri -> int -> int option -> uri - -module UriSet: Set.S with type elt = uri - -module UriHashtbl : Hashtbl.S with type key = uri - diff --git a/helm/ocaml/utf8_macros/.depend b/helm/ocaml/utf8_macros/.depend deleted file mode 100644 index f3c6a8bd1..000000000 --- a/helm/ocaml/utf8_macros/.depend +++ /dev/null @@ -1,2 +0,0 @@ -utf8Macro.cmo: utf8MacroTable.cmo utf8Macro.cmi -utf8Macro.cmx: utf8MacroTable.cmx utf8Macro.cmi diff --git a/helm/ocaml/utf8_macros/Makefile b/helm/ocaml/utf8_macros/Makefile deleted file mode 100644 index 2b737627f..000000000 --- a/helm/ocaml/utf8_macros/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -PACKAGE = utf8_macros -PREDICATES = -MAKE_TABLE_PACKAGES = helm-xml - -# modules which have both a .ml and a .mli -INTERFACE_FILES = utf8Macro.mli -IMPLEMENTATION_FILES = utf8MacroTable.ml $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -all: utf8_macros.cma pa_unicode_macro.cma - -make_table: make_table.ml - @echo " OCAMLC $<" - @$(OCAMLFIND) ocamlc -package $(MAKE_TABLE_PACKAGES) -linkpkg -o $@ $^ - -utf8MacroTable.ml: - ./make_table $@ -utf8MacroTable.cmo: utf8MacroTable.ml - @echo " OCAMLC $<" - @$(OCAMLFIND) ocamlc -c $< - -pa_unicode_macro.cmo: pa_unicode_macro.ml utf8Macro.cmo - @echo " OCAMLC $<" - @$(OCAMLFIND) ocamlc -package camlp4 -pp "camlp4o q_MLast.cmo pa_extend.cmo -loc loc" -c $< -pa_unicode_macro.cma: utf8MacroTable.cmo utf8Macro.cmo pa_unicode_macro.cmo - @echo " OCAMLC -a $@" - @$(OCAMLFIND) ocamlc -a -o $@ $^ - -.PHONY: test -test: test.ml - $(OCAMLFIND) ocamlc -package helm-utf8_macros -syntax camlp4o $< -o $@ - -clean: -distclean: extra_clean -extra_clean: - rm -f make_table test - -STATS_EXCLUDE = utf8MacroTable.ml - -include ../../Makefile.defs -include ../Makefile.common - diff --git a/helm/ocaml/utf8_macros/README.syntax b/helm/ocaml/utf8_macros/README.syntax deleted file mode 100644 index 210ecc095..000000000 --- a/helm/ocaml/utf8_macros/README.syntax +++ /dev/null @@ -1,15 +0,0 @@ - -Helm Utf8 macro syntax extension for Camlp4 - -Sample file: - - --- test.ml --- - - prerr_endline <:unicode> - - --------------- - -Compile it with: - - ocamlfind ocamlc -package helm-utf8_macros -syntax camlp4o test.ml - diff --git a/helm/ocaml/utf8_macros/data/dictionary-tex.xml b/helm/ocaml/utf8_macros/data/dictionary-tex.xml deleted file mode 100644 index 47995454f..000000000 --- a/helm/ocaml/utf8_macros/data/dictionary-tex.xml +++ /dev/null @@ -1,378 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/helm/ocaml/utf8_macros/data/entities-table.xml b/helm/ocaml/utf8_macros/data/entities-table.xml deleted file mode 100644 index c283631b4..000000000 --- a/helm/ocaml/utf8_macros/data/entities-table.xml +++ /dev/null @@ -1,2079 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/helm/ocaml/utf8_macros/data/extra-entities.xml b/helm/ocaml/utf8_macros/data/extra-entities.xml deleted file mode 100644 index 73b12ad5e..000000000 --- a/helm/ocaml/utf8_macros/data/extra-entities.xml +++ /dev/null @@ -1,16 +0,0 @@ - - - - - - - - - - - - - - - - diff --git a/helm/ocaml/utf8_macros/make_table.ml b/helm/ocaml/utf8_macros/make_table.ml deleted file mode 100644 index 4722af1e1..000000000 --- a/helm/ocaml/utf8_macros/make_table.ml +++ /dev/null @@ -1,102 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - - (* source files for tables xml parsing (if unmarshall=false) *) -let xml_tables = [ -(* - `Entities, "/usr/share/gtkmathview/entities-table.xml"; - `Dictionary, "/usr/share/editex/dictionary-tex.xml" -*) - `Entities, "data/entities-table.xml"; - `Dictionary, "data/dictionary-tex.xml"; - `Entities, "data/extra-entities.xml"; - (** extra-entities.xml should be the last one since it is used to override - * previous mappings. Add there overrides as needed. *) -] - -let iter_gen record_tag name_field value_field f fname = - let start_element tag attrs = - if tag = record_tag then - try - let name = List.assoc name_field attrs in - let value = List.assoc value_field attrs in - f name value - with Not_found -> () - in - let callbacks = { - XmlPushParser.default_callbacks with - XmlPushParser.start_element = Some start_element - } in - let xml_parser = XmlPushParser.create_parser callbacks in - XmlPushParser.parse xml_parser (`File fname) - -let iter_entities_file = iter_gen "entity" "name" "value" -let iter_dictionary_file = iter_gen "entry" "name" "val" - -let parse_from_xml () = - let (macro2utf8, utf82macro) = (Hashtbl.create 2000, Hashtbl.create 2000) in - let add_macro macro utf8 = - debug_print (lazy (sprintf "Adding macro %s = '%s'" macro utf8)); - Hashtbl.replace macro2utf8 macro utf8; - Hashtbl.replace utf82macro utf8 macro - in - let fill_table () = - List.iter - (fun (typ, fname) -> - match typ with - | `Entities -> iter_entities_file add_macro fname - | `Dictionary -> iter_dictionary_file add_macro fname) - xml_tables - in - fill_table (); - macro2utf8, utf82macro - -let main () = - let oc = open_out Sys.argv.(1) in - output_string oc "(* GENERATED by make_table: DO NOT EDIT! *)\n"; - output_string oc "let macro2utf8 = Hashtbl.create 2000\n"; - output_string oc "let utf82macro = Hashtbl.create 2000\n"; - let macro2utf8, utf82macro = parse_from_xml () in - Hashtbl.iter - (fun macro utf8 -> - fprintf oc "let _ = Hashtbl.replace macro2utf8 \"%s\" \"%s\"\n" - macro (String.escaped utf8)) - macro2utf8; - Hashtbl.iter - (fun utf8 macro -> - fprintf oc "let _ = Hashtbl.replace utf82macro \"%s\" \"%s\"\n" - (String.escaped utf8) macro) - utf82macro; - close_out oc - -let _ = main () - diff --git a/helm/ocaml/utf8_macros/pa_unicode_macro.ml b/helm/ocaml/utf8_macros/pa_unicode_macro.ml deleted file mode 100644 index dda7d4cab..000000000 --- a/helm/ocaml/utf8_macros/pa_unicode_macro.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -let loc = - let dummy_pos = - { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1; - Lexing.pos_cnum = -1 } - in - (dummy_pos, dummy_pos) - -let expand_unicode_macro macro = - debug_print (lazy (Printf.sprintf "Expanding macro '%s' ..." macro)); - let expansion = Utf8Macro.expand macro in - <:expr< $str:expansion$ >> - -let _ = - Quotation.add "unicode" - (Quotation.ExAst (expand_unicode_macro, (fun _ -> assert false))) - -open Pa_extend - -EXTEND - symbol: FIRST - [ - [ x = UIDENT; q = QUOTATION -> - let (quotation, arg) = - let pos = String.index q ':' in - (String.sub q 0 pos, - String.sub q (pos + 1) (String.length q - pos - 1)) - in - debug_print (lazy (Printf.sprintf "QUOTATION = %s; ARG = %s" quotation arg)); - if quotation = "unicode" then - let text = TXtok (loc, x, expand_unicode_macro arg) in - {used = []; text = text; styp = STlid (loc, "string")} - else - assert false - ] - ]; -END - diff --git a/helm/ocaml/utf8_macros/test.ml b/helm/ocaml/utf8_macros/test.ml deleted file mode 100644 index 8f98bfd44..000000000 --- a/helm/ocaml/utf8_macros/test.ml +++ /dev/null @@ -1,3 +0,0 @@ -(* $Id$ *) - -prerr_endline <:unicode> diff --git a/helm/ocaml/utf8_macros/utf8Macro.ml b/helm/ocaml/utf8_macros/utf8Macro.ml deleted file mode 100644 index e5fca10c4..000000000 --- a/helm/ocaml/utf8_macros/utf8Macro.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception Macro_not_found of string -exception Utf8_not_found of string - -let expand macro = - try - Hashtbl.find Utf8MacroTable.macro2utf8 macro - with Not_found -> raise (Macro_not_found macro) - -let unicode_of_tex s = - try - if s.[0] = '\\' then - expand (String.sub s 1 (String.length s - 1)) - else s - with Macro_not_found _ -> s - -let tex_of_unicode s = - try - "\\" ^ Hashtbl.find Utf8MacroTable.utf82macro s - with Not_found -> s - diff --git a/helm/ocaml/utf8_macros/utf8Macro.mli b/helm/ocaml/utf8_macros/utf8Macro.mli deleted file mode 100644 index d92f60b37..000000000 --- a/helm/ocaml/utf8_macros/utf8Macro.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2004, 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://helm.cs.unibo.it/ - *) - -exception Macro_not_found of string -exception Utf8_not_found of string - - (** @param macro name - @return utf8 string *) -val expand: string -> string - - (** @param tex TeX like command (e.g. \forall, \lnot, ...) - * @return unicode character corresponding to the command if it exists, or the - * unchanged command if not *) -val unicode_of_tex: string -> string - - (** ... the other way round *) -val tex_of_unicode: string -> string - diff --git a/helm/ocaml/utf8_macros/utf8MacroTable.ml b/helm/ocaml/utf8_macros/utf8MacroTable.ml deleted file mode 100644 index 8b4a02e47..000000000 --- a/helm/ocaml/utf8_macros/utf8MacroTable.ml +++ /dev/null @@ -1,3625 +0,0 @@ -(* GENERATED by make_table: DO NOT EDIT! *) -let macro2utf8 = Hashtbl.create 2000 -let utf82macro = Hashtbl.create 2000 -let _ = Hashtbl.replace macro2utf8 "nscr" "\240\157\147\131" -let _ = Hashtbl.replace macro2utf8 "LJcy" "\208\137" -let _ = Hashtbl.replace macro2utf8 "dd" "\226\133\134" -let _ = Hashtbl.replace macro2utf8 "Omacr" "\197\140" -let _ = Hashtbl.replace macro2utf8 "npreceq" "\226\170\175\204\184" -let _ = Hashtbl.replace macro2utf8 "Gcirc" "\196\156" -let _ = Hashtbl.replace macro2utf8 "utilde" "\197\169" -let _ = Hashtbl.replace macro2utf8 "rdca" "\226\164\183" -let _ = Hashtbl.replace macro2utf8 "racute" "\197\149" -let _ = Hashtbl.replace macro2utf8 "mstpos" "\226\136\190" -let _ = Hashtbl.replace macro2utf8 "supnE" "\226\138\139" -let _ = Hashtbl.replace macro2utf8 "NotLessLess" "\226\137\170\204\184\239\184\128" -let _ = Hashtbl.replace macro2utf8 "iiint" "\226\136\173" -let _ = Hashtbl.replace macro2utf8 "uscr" "\240\157\147\138" -let _ = Hashtbl.replace macro2utf8 "Sfr" "\240\157\148\150" -let _ = Hashtbl.replace macro2utf8 "nsupseteqq" "\226\138\137" -let _ = Hashtbl.replace macro2utf8 "nwarrow" "\226\134\150" -let _ = Hashtbl.replace macro2utf8 "twoheadrightarrow" "\226\134\160" -let _ = Hashtbl.replace macro2utf8 "sccue" "\226\137\189" -let _ = Hashtbl.replace macro2utf8 "NotSquareSuperset" "\226\138\144\204\184" -let _ = Hashtbl.replace macro2utf8 "ee" "\226\133\135" -let _ = Hashtbl.replace macro2utf8 "boxbox" "\226\167\137" -let _ = Hashtbl.replace macro2utf8 "andand" "\226\169\149" -let _ = Hashtbl.replace macro2utf8 "LeftVectorBar" "\226\165\146" -let _ = Hashtbl.replace macro2utf8 "eg" "\226\170\154" -let _ = Hashtbl.replace macro2utf8 "csc" "csc" -let _ = Hashtbl.replace macro2utf8 "NotRightTriangleEqual" "\226\139\173" -let _ = Hashtbl.replace macro2utf8 "filig" "\239\172\129" -let _ = Hashtbl.replace macro2utf8 "atilde" "\195\163" -let _ = Hashtbl.replace macro2utf8 "ring" "\203\154" -let _ = Hashtbl.replace macro2utf8 "congdot" "\226\169\173" -let _ = Hashtbl.replace macro2utf8 "gE" "\226\137\167" -let _ = Hashtbl.replace macro2utf8 "rcedil" "\197\151" -let _ = Hashtbl.replace macro2utf8 "el" "\226\170\153" -let _ = Hashtbl.replace macro2utf8 "HorizontalLine" "\226\148\128" -let _ = Hashtbl.replace macro2utf8 "incare" "\226\132\133" -let _ = Hashtbl.replace macro2utf8 "hoarr" "\226\135\191" -let _ = Hashtbl.replace macro2utf8 "SOFTcy" "\208\172" -let _ = Hashtbl.replace macro2utf8 "conint" "\226\136\174" -let _ = Hashtbl.replace macro2utf8 "OverParenthesis" "\239\184\181" -let _ = Hashtbl.replace macro2utf8 "Uogon" "\197\178" -let _ = Hashtbl.replace macro2utf8 "supne" "\226\138\139" -let _ = Hashtbl.replace macro2utf8 "num" "#" -let _ = Hashtbl.replace macro2utf8 "zcy" "\208\183" -let _ = Hashtbl.replace macro2utf8 "Hfr" "\226\132\140" -let _ = Hashtbl.replace macro2utf8 "dtri" "\226\150\191" -let _ = Hashtbl.replace macro2utf8 "FilledSmallSquare" "\226\151\190" -let _ = Hashtbl.replace macro2utf8 "SucceedsEqual" "\226\137\189" -let _ = Hashtbl.replace macro2utf8 "leftthreetimes" "\226\139\139" -let _ = Hashtbl.replace macro2utf8 "ycirc" "\197\183" -let _ = Hashtbl.replace macro2utf8 "sqcup" "\226\138\148" -let _ = Hashtbl.replace macro2utf8 "DoubleLeftArrow" "\226\135\144" -let _ = Hashtbl.replace macro2utf8 "gtrless" "\226\137\183" -let _ = Hashtbl.replace macro2utf8 "ge" "\226\137\165" -let _ = Hashtbl.replace macro2utf8 "Product" "\226\136\143" -let _ = Hashtbl.replace macro2utf8 "NotExists" "\226\136\132" -let _ = Hashtbl.replace macro2utf8 "gg" "\226\137\171" -let _ = Hashtbl.replace macro2utf8 "curlyvee" "\226\139\142" -let _ = Hashtbl.replace macro2utf8 "ntrianglerighteq" "\226\139\173" -let _ = Hashtbl.replace macro2utf8 "Colon" "\226\136\183" -let _ = Hashtbl.replace macro2utf8 "rbrke" "\226\166\140" -let _ = Hashtbl.replace macro2utf8 "LeftDownVector" "\226\135\131" -let _ = Hashtbl.replace macro2utf8 "gl" "\226\137\183" -let _ = Hashtbl.replace macro2utf8 "lrcorner" "\226\140\159" -let _ = Hashtbl.replace macro2utf8 "mapstodown" "\226\134\167" -let _ = Hashtbl.replace macro2utf8 "excl" "!" -let _ = Hashtbl.replace macro2utf8 "cdots" "\226\139\175" -let _ = Hashtbl.replace macro2utf8 "larr" "\226\134\144" -let _ = Hashtbl.replace macro2utf8 "dtdot" "\226\139\177" -let _ = Hashtbl.replace macro2utf8 "kgreen" "\196\184" -let _ = Hashtbl.replace macro2utf8 "rtri" "\226\150\185" -let _ = Hashtbl.replace macro2utf8 "rbarr" "\226\164\141" -let _ = Hashtbl.replace macro2utf8 "ocy" "\208\190" -let _ = Hashtbl.replace macro2utf8 "gt" ">" -let _ = Hashtbl.replace macro2utf8 "DownLeftRightVector" "\226\165\144" -let _ = Hashtbl.replace macro2utf8 "cup" "\226\136\170" -let _ = Hashtbl.replace macro2utf8 "updownarrow" "\226\134\149" -let _ = Hashtbl.replace macro2utf8 "Imacr" "\196\170" -let _ = Hashtbl.replace macro2utf8 "cross" "\226\156\151" -let _ = Hashtbl.replace macro2utf8 "Acirc" "\195\130" -let _ = Hashtbl.replace macro2utf8 "lvertneqq" "\226\137\168\239\184\128" -let _ = Hashtbl.replace macro2utf8 "ccaps" "\226\169\141" -let _ = Hashtbl.replace macro2utf8 "NotLeftTriangleEqual" "\226\139\172" -let _ = Hashtbl.replace macro2utf8 "IJlig" "\196\178" -let _ = Hashtbl.replace macro2utf8 "boxplus" "\226\138\158" -let _ = Hashtbl.replace macro2utf8 "epsilon" "\207\181" -let _ = Hashtbl.replace macro2utf8 "zfr" "\240\157\148\183" -let _ = Hashtbl.replace macro2utf8 "late" "\226\170\173" -let _ = Hashtbl.replace macro2utf8 "ic" "\226\128\139" -let _ = Hashtbl.replace macro2utf8 "lrhar" "\226\135\139" -let _ = Hashtbl.replace macro2utf8 "gsim" "\226\137\179" -let _ = Hashtbl.replace macro2utf8 "inf" "inf" -let _ = Hashtbl.replace macro2utf8 "top" "\226\138\164" -let _ = Hashtbl.replace macro2utf8 "odsold" "\226\166\188" -let _ = Hashtbl.replace macro2utf8 "circlearrowright" "\226\134\187" -let _ = Hashtbl.replace macro2utf8 "rtimes" "\226\139\138" -let _ = Hashtbl.replace macro2utf8 "ii" "\226\133\136" -let _ = Hashtbl.replace macro2utf8 "DoubleRightTee" "\226\138\168" -let _ = Hashtbl.replace macro2utf8 "dcy" "\208\180" -let _ = Hashtbl.replace macro2utf8 "boxdL" "\226\149\149" -let _ = Hashtbl.replace macro2utf8 "duhar" "\226\165\175" -let _ = Hashtbl.replace macro2utf8 "vert" "|" -let _ = Hashtbl.replace macro2utf8 "sacute" "\197\155" -let _ = Hashtbl.replace macro2utf8 "in" "\226\136\136" -let _ = Hashtbl.replace macro2utf8 "Assign" "\226\137\148" -let _ = Hashtbl.replace macro2utf8 "nsim" "\226\137\129" -let _ = Hashtbl.replace macro2utf8 "boxdR" "\226\149\146" -let _ = Hashtbl.replace macro2utf8 "o" "\206\191" -let _ = Hashtbl.replace macro2utf8 "radic" "\226\136\154" -let _ = Hashtbl.replace macro2utf8 "it" "\226\129\162" -let _ = Hashtbl.replace macro2utf8 "int" "\226\136\171" -let _ = Hashtbl.replace macro2utf8 "cwint" "\226\136\177" -let _ = Hashtbl.replace macro2utf8 "ForAll" "\226\136\128" -let _ = Hashtbl.replace macro2utf8 "simplus" "\226\168\164" -let _ = Hashtbl.replace macro2utf8 "isindot" "\226\139\181" -let _ = Hashtbl.replace macro2utf8 "rightthreetimes" "\226\139\140" -let _ = Hashtbl.replace macro2utf8 "supseteqq" "\226\138\135" -let _ = Hashtbl.replace macro2utf8 "bnot" "\226\140\144" -let _ = Hashtbl.replace macro2utf8 "rppolint" "\226\168\146" -let _ = Hashtbl.replace macro2utf8 "def" "\226\137\157" -let _ = Hashtbl.replace macro2utf8 "TScy" "\208\166" -let _ = Hashtbl.replace macro2utf8 "lE" "\226\137\166" -let _ = Hashtbl.replace macro2utf8 "ffilig" "\239\172\131" -let _ = Hashtbl.replace macro2utf8 "deg" "deg" -let _ = Hashtbl.replace macro2utf8 "{" "{" -let _ = Hashtbl.replace macro2utf8 "RightVector" "\226\135\128" -let _ = Hashtbl.replace macro2utf8 "ofr" "\240\157\148\172" -let _ = Hashtbl.replace macro2utf8 "|" "|" -let _ = Hashtbl.replace macro2utf8 "liminf" "liminf" -let _ = Hashtbl.replace macro2utf8 "}" "}" -let _ = Hashtbl.replace macro2utf8 "LeftUpTeeVector" "\226\165\160" -let _ = Hashtbl.replace macro2utf8 "scirc" "\197\157" -let _ = Hashtbl.replace macro2utf8 "scedil" "\197\159" -let _ = Hashtbl.replace macro2utf8 "ufisht" "\226\165\190" -let _ = Hashtbl.replace macro2utf8 "LeftUpDownVector" "\226\165\145" -let _ = Hashtbl.replace macro2utf8 "questeq" "\226\137\159" -let _ = Hashtbl.replace macro2utf8 "leftarrow" "\226\134\144" -let _ = Hashtbl.replace macro2utf8 "Ycy" "\208\171" -let _ = Hashtbl.replace macro2utf8 "Coproduct" "\226\136\144" -let _ = Hashtbl.replace macro2utf8 "det" "det" -let _ = Hashtbl.replace macro2utf8 "boxdl" "\226\148\144" -let _ = Hashtbl.replace macro2utf8 "Aopf" "\240\157\148\184" -let _ = Hashtbl.replace macro2utf8 "srarr" "\226\134\146\239\184\128" -let _ = Hashtbl.replace macro2utf8 "lbrke" "\226\166\139" -let _ = Hashtbl.replace macro2utf8 "boxdr" "\226\148\140" -let _ = Hashtbl.replace macro2utf8 "Ntilde" "\195\145" -let _ = Hashtbl.replace macro2utf8 "gnap" "\226\170\138" -let _ = Hashtbl.replace macro2utf8 "Cap" "\226\139\146" -let _ = Hashtbl.replace macro2utf8 "swarhk" "\226\164\166" -let _ = Hashtbl.replace macro2utf8 "ogt" "\226\167\129" -let _ = Hashtbl.replace macro2utf8 "emptyset" "\226\136\133\239\184\128" -let _ = Hashtbl.replace macro2utf8 "harrw" "\226\134\173" -let _ = Hashtbl.replace macro2utf8 "lbarr" "\226\164\140" -let _ = Hashtbl.replace macro2utf8 "Tilde" "\226\136\188" -let _ = Hashtbl.replace macro2utf8 "delta" "\206\180" -let _ = Hashtbl.replace macro2utf8 "Hopf" "\226\132\141" -let _ = Hashtbl.replace macro2utf8 "dfr" "\240\157\148\161" -let _ = Hashtbl.replace macro2utf8 "le" "\226\137\164" -let _ = Hashtbl.replace macro2utf8 "lg" "lg" -let _ = Hashtbl.replace macro2utf8 "ohm" "\226\132\166" -let _ = Hashtbl.replace macro2utf8 "Jsercy" "\208\136" -let _ = Hashtbl.replace macro2utf8 "quaternions" "\226\132\141" -let _ = Hashtbl.replace macro2utf8 "DoubleLongLeftArrow" "\239\149\185" -let _ = Hashtbl.replace macro2utf8 "Ncy" "\208\157" -let _ = Hashtbl.replace macro2utf8 "nabla" "\226\136\135" -let _ = Hashtbl.replace macro2utf8 "ltcir" "\226\169\185" -let _ = Hashtbl.replace macro2utf8 "ll" "\226\137\170" -let _ = Hashtbl.replace macro2utf8 "ln" "ln" -let _ = Hashtbl.replace macro2utf8 "rmoust" "\226\142\177" -let _ = Hashtbl.replace macro2utf8 "Oopf" "\240\157\149\134" -let _ = Hashtbl.replace macro2utf8 "nbsp" "\194\160" -let _ = Hashtbl.replace macro2utf8 "Kcedil" "\196\182" -let _ = Hashtbl.replace macro2utf8 "vdots" "\226\139\174" -let _ = Hashtbl.replace macro2utf8 "NotLessTilde" "\226\137\180" -let _ = Hashtbl.replace macro2utf8 "lt" "<" -let _ = Hashtbl.replace macro2utf8 "djcy" "\209\146" -let _ = Hashtbl.replace macro2utf8 "DownRightTeeVector" "\226\165\159" -let _ = Hashtbl.replace macro2utf8 "Ograve" "\195\146" -let _ = Hashtbl.replace macro2utf8 "boxhD" "\226\149\165" -let _ = Hashtbl.replace macro2utf8 "nsime" "\226\137\132" -let _ = Hashtbl.replace macro2utf8 "egsdot" "\226\170\152" -let _ = Hashtbl.replace macro2utf8 "mDDot" "\226\136\186" -let _ = Hashtbl.replace macro2utf8 "bigodot" "\226\138\153" -let _ = Hashtbl.replace macro2utf8 "Vopf" "\240\157\149\141" -let _ = Hashtbl.replace macro2utf8 "looparrowright" "\226\134\172" -let _ = Hashtbl.replace macro2utf8 "yucy" "\209\142" -let _ = Hashtbl.replace macro2utf8 "trade" "\226\132\162" -let _ = Hashtbl.replace macro2utf8 "Yfr" "\240\157\148\156" -let _ = Hashtbl.replace macro2utf8 "kjcy" "\209\156" -let _ = Hashtbl.replace macro2utf8 "mp" "\226\136\147" -let _ = Hashtbl.replace macro2utf8 "leftrightarrows" "\226\135\134" -let _ = Hashtbl.replace macro2utf8 "uharl" "\226\134\191" -let _ = Hashtbl.replace macro2utf8 "ncap" "\226\169\131" -let _ = Hashtbl.replace macro2utf8 "Iogon" "\196\174" -let _ = Hashtbl.replace macro2utf8 "NotSubset" "\226\138\132" -let _ = Hashtbl.replace macro2utf8 "Bumpeq" "\226\137\142" -let _ = Hashtbl.replace macro2utf8 "mu" "\206\188" -let _ = Hashtbl.replace macro2utf8 "FilledVerySmallSquare" "\239\150\155" -let _ = Hashtbl.replace macro2utf8 "breve" "\203\152" -let _ = Hashtbl.replace macro2utf8 "boxhU" "\226\149\168" -let _ = Hashtbl.replace macro2utf8 "Sigma" "\206\163" -let _ = Hashtbl.replace macro2utf8 "uharr" "\226\134\190" -let _ = Hashtbl.replace macro2utf8 "xrArr" "\239\149\186" -let _ = Hashtbl.replace macro2utf8 "ne" "\226\137\160" -let _ = Hashtbl.replace macro2utf8 "oS" "\226\147\136" -let _ = Hashtbl.replace macro2utf8 "xodot" "\226\138\153" -let _ = Hashtbl.replace macro2utf8 "ni" "\226\136\139" -let _ = Hashtbl.replace macro2utf8 "mdash" "\226\128\148" -let _ = Hashtbl.replace macro2utf8 "Verbar" "\226\128\150" -let _ = Hashtbl.replace macro2utf8 "die" "\194\168" -let _ = Hashtbl.replace macro2utf8 "veebar" "\226\138\187" -let _ = Hashtbl.replace macro2utf8 "UpArrowBar" "\226\164\146" -let _ = Hashtbl.replace macro2utf8 "Ncaron" "\197\135" -let _ = Hashtbl.replace macro2utf8 "RightArrowBar" "\226\135\165" -let _ = Hashtbl.replace macro2utf8 "LongLeftArrow" "\239\149\182" -let _ = Hashtbl.replace macro2utf8 "rceil" "\226\140\137" -let _ = Hashtbl.replace macro2utf8 "LeftDownVectorBar" "\226\165\153" -let _ = Hashtbl.replace macro2utf8 "umacr" "\197\171" -let _ = Hashtbl.replace macro2utf8 "Hacek" "\203\135" -let _ = Hashtbl.replace macro2utf8 "odblac" "\197\145" -let _ = Hashtbl.replace macro2utf8 "lmidot" "\197\128" -let _ = Hashtbl.replace macro2utf8 "dopf" "\240\157\149\149" -let _ = Hashtbl.replace macro2utf8 "boxhd" "\226\148\172" -let _ = Hashtbl.replace macro2utf8 "dim" "dim" -let _ = Hashtbl.replace macro2utf8 "vnsub" "\226\138\132" -let _ = Hashtbl.replace macro2utf8 "Bscr" "\226\132\172" -let _ = Hashtbl.replace macro2utf8 "plussim" "\226\168\166" -let _ = Hashtbl.replace macro2utf8 "doublebarwedge" "\226\140\134" -let _ = Hashtbl.replace macro2utf8 "nu" "\206\189" -let _ = Hashtbl.replace macro2utf8 "eqcolon" "\226\137\149" -let _ = Hashtbl.replace macro2utf8 "luruhar" "\226\165\166" -let _ = Hashtbl.replace macro2utf8 "Nfr" "\240\157\148\145" -let _ = Hashtbl.replace macro2utf8 "preceq" "\226\170\175" -let _ = Hashtbl.replace macro2utf8 "LeftTee" "\226\138\163" -let _ = Hashtbl.replace macro2utf8 "div" "\195\183" -let _ = Hashtbl.replace macro2utf8 "nVDash" "\226\138\175" -let _ = Hashtbl.replace macro2utf8 "kopf" "\240\157\149\156" -let _ = Hashtbl.replace macro2utf8 "Iscr" "\226\132\144" -let _ = Hashtbl.replace macro2utf8 "vnsup" "\226\138\133" -let _ = Hashtbl.replace macro2utf8 "gneq" "\226\137\169" -let _ = Hashtbl.replace macro2utf8 "backepsilon" "\207\182" -let _ = Hashtbl.replace macro2utf8 "boxhu" "\226\148\180" -let _ = Hashtbl.replace macro2utf8 "ominus" "\226\138\150" -let _ = Hashtbl.replace macro2utf8 "or" "\226\136\168" -let _ = Hashtbl.replace macro2utf8 "lesdot" "\226\169\191" -let _ = Hashtbl.replace macro2utf8 "RightVectorBar" "\226\165\147" -let _ = Hashtbl.replace macro2utf8 "tcedil" "\197\163" -let _ = Hashtbl.replace macro2utf8 "hstrok" "\196\167" -let _ = Hashtbl.replace macro2utf8 "nrarrc" "\226\164\179\204\184" -let _ = Hashtbl.replace macro2utf8 "ropf" "\240\157\149\163" -let _ = Hashtbl.replace macro2utf8 "diamond" "\226\139\132" -let _ = Hashtbl.replace macro2utf8 "smid" "\226\136\163\239\184\128" -let _ = Hashtbl.replace macro2utf8 "nltri" "\226\139\170" -let _ = Hashtbl.replace macro2utf8 "Pscr" "\240\157\146\171" -let _ = Hashtbl.replace macro2utf8 "vartheta" "\207\145" -let _ = Hashtbl.replace macro2utf8 "therefore" "\226\136\180" -let _ = Hashtbl.replace macro2utf8 "pi" "\207\128" -let _ = Hashtbl.replace macro2utf8 "ntrianglelefteq" "\226\139\172" -let _ = Hashtbl.replace macro2utf8 "nearrow" "\226\134\151" -let _ = Hashtbl.replace macro2utf8 "pm" "\194\177" -let _ = Hashtbl.replace macro2utf8 "natural" "\226\153\174" -let _ = Hashtbl.replace macro2utf8 "ucy" "\209\131" -let _ = Hashtbl.replace macro2utf8 "olt" "\226\167\128" -let _ = Hashtbl.replace macro2utf8 "Cfr" "\226\132\173" -let _ = Hashtbl.replace macro2utf8 "yopf" "\240\157\149\170" -let _ = Hashtbl.replace macro2utf8 "Otilde" "\195\149" -let _ = Hashtbl.replace macro2utf8 "ntriangleleft" "\226\139\170" -let _ = Hashtbl.replace macro2utf8 "pr" "\226\137\186" -let _ = Hashtbl.replace macro2utf8 "Wscr" "\240\157\146\178" -let _ = Hashtbl.replace macro2utf8 "midcir" "\226\171\176" -let _ = Hashtbl.replace macro2utf8 "Lacute" "\196\185" -let _ = Hashtbl.replace macro2utf8 "DoubleDot" "\194\168" -let _ = Hashtbl.replace macro2utf8 "Tstrok" "\197\166" -let _ = Hashtbl.replace macro2utf8 "nrarrw" "\226\134\157\204\184" -let _ = Hashtbl.replace macro2utf8 "uArr" "\226\135\145" -let _ = Hashtbl.replace macro2utf8 "nLtv" "\226\137\170\204\184\239\184\128" -let _ = Hashtbl.replace macro2utf8 "rangle" "\226\140\170" -let _ = Hashtbl.replace macro2utf8 "olcir" "\226\166\190" -let _ = Hashtbl.replace macro2utf8 "Auml" "\195\132" -let _ = Hashtbl.replace macro2utf8 "Succeeds" "\226\137\187" -let _ = Hashtbl.replace macro2utf8 "DoubleLongLeftRightArrow" "\239\149\187" -let _ = Hashtbl.replace macro2utf8 "TSHcy" "\208\139" -let _ = Hashtbl.replace macro2utf8 "gammad" "\207\156" -let _ = Hashtbl.replace macro2utf8 "epsiv" "\201\155" -let _ = Hashtbl.replace macro2utf8 "notinva" "\226\136\137\204\184" -let _ = Hashtbl.replace macro2utf8 "notinvb" "\226\139\183" -let _ = Hashtbl.replace macro2utf8 "eqvparsl" "\226\167\165" -let _ = Hashtbl.replace macro2utf8 "notinvc" "\226\139\182" -let _ = Hashtbl.replace macro2utf8 "nsubE" "\226\138\136" -let _ = Hashtbl.replace macro2utf8 "supplus" "\226\171\128" -let _ = Hashtbl.replace macro2utf8 "RightUpDownVector" "\226\165\143" -let _ = Hashtbl.replace macro2utf8 "Tab" "\t" -let _ = Hashtbl.replace macro2utf8 "Lcedil" "\196\187" -let _ = Hashtbl.replace macro2utf8 "backslash" "\\" -let _ = Hashtbl.replace macro2utf8 "pointint" "\226\168\149" -let _ = Hashtbl.replace macro2utf8 "jcy" "\208\185" -let _ = Hashtbl.replace macro2utf8 "iocy" "\209\145" -let _ = Hashtbl.replace macro2utf8 "escr" "\226\132\175" -let _ = Hashtbl.replace macro2utf8 "submult" "\226\171\129" -let _ = Hashtbl.replace macro2utf8 "iiota" "\226\132\169" -let _ = Hashtbl.replace macro2utf8 "lceil" "\226\140\136" -let _ = Hashtbl.replace macro2utf8 "omacr" "\197\141" -let _ = Hashtbl.replace macro2utf8 "gneqq" "\226\137\169" -let _ = Hashtbl.replace macro2utf8 "gcirc" "\196\157" -let _ = Hashtbl.replace macro2utf8 "dotsquare" "\226\138\161" -let _ = Hashtbl.replace macro2utf8 "ccaron" "\196\141" -let _ = Hashtbl.replace macro2utf8 "Square" "\226\150\161" -let _ = Hashtbl.replace macro2utf8 "RightDownTeeVector" "\226\165\157" -let _ = Hashtbl.replace macro2utf8 "Ouml" "\195\150" -let _ = Hashtbl.replace macro2utf8 "lurdshar" "\226\165\138" -let _ = Hashtbl.replace macro2utf8 "SuchThat" "\226\136\139" -let _ = Hashtbl.replace macro2utf8 "setminus" "\226\136\150" -let _ = Hashtbl.replace macro2utf8 "lscr" "\226\132\147" -let _ = Hashtbl.replace macro2utf8 "LessLess" "\226\170\161" -let _ = Hashtbl.replace macro2utf8 "Sub" "\226\139\144" -let _ = Hashtbl.replace macro2utf8 "sc" "\226\137\187" -let _ = Hashtbl.replace macro2utf8 "rx" "\226\132\158" -let _ = Hashtbl.replace macro2utf8 "RightFloor" "\226\140\139" -let _ = Hashtbl.replace macro2utf8 "blacksquare" "\226\150\170" -let _ = Hashtbl.replace macro2utf8 "ufr" "\240\157\148\178" -let _ = Hashtbl.replace macro2utf8 "block" "\226\150\136" -let _ = Hashtbl.replace macro2utf8 "dots" "\226\128\166" -let _ = Hashtbl.replace macro2utf8 "nvsim" "\226\137\129\204\184" -let _ = Hashtbl.replace macro2utf8 "caret" "\226\129\129" -let _ = Hashtbl.replace macro2utf8 "demptyv" "\226\166\177" -let _ = Hashtbl.replace macro2utf8 "Sum" "\226\136\145" -let _ = Hashtbl.replace macro2utf8 "sscr" "\240\157\147\136" -let _ = Hashtbl.replace macro2utf8 "nsube" "\226\138\136" -let _ = Hashtbl.replace macro2utf8 "Sup" "\226\139\145" -let _ = Hashtbl.replace macro2utf8 "ccupssm" "\226\169\144" -let _ = Hashtbl.replace macro2utf8 "Because" "\226\136\181" -let _ = Hashtbl.replace macro2utf8 "harrcir" "\226\165\136" -let _ = Hashtbl.replace macro2utf8 "capbrcup" "\226\169\137" -let _ = Hashtbl.replace macro2utf8 "RightUpVectorBar" "\226\165\148" -let _ = Hashtbl.replace macro2utf8 "caps" "\226\136\169\239\184\128" -let _ = Hashtbl.replace macro2utf8 "ohbar" "\226\166\181" -let _ = Hashtbl.replace macro2utf8 "laemptyv" "\226\166\180" -let _ = Hashtbl.replace macro2utf8 "uacute" "\195\186" -let _ = Hashtbl.replace macro2utf8 "straightphi" "\207\134" -let _ = Hashtbl.replace macro2utf8 "RightDoubleBracket" "\227\128\155" -let _ = Hashtbl.replace macro2utf8 "zscr" "\240\157\147\143" -let _ = Hashtbl.replace macro2utf8 "uogon" "\197\179" -let _ = Hashtbl.replace macro2utf8 "Uarr" "\226\134\159" -let _ = Hashtbl.replace macro2utf8 "nsucc" "\226\138\129" -let _ = Hashtbl.replace macro2utf8 "RBarr" "\226\164\144" -let _ = Hashtbl.replace macro2utf8 "NotRightTriangleBar" "\226\167\144\204\184" -let _ = Hashtbl.replace macro2utf8 "to" "\226\134\146" -let _ = Hashtbl.replace macro2utf8 "rpar" ")" -let _ = Hashtbl.replace macro2utf8 "rdsh" "\226\134\179" -let _ = Hashtbl.replace macro2utf8 "jfr" "\240\157\148\167" -let _ = Hashtbl.replace macro2utf8 "ldquor" "\226\128\158" -let _ = Hashtbl.replace macro2utf8 "bsime" "\226\139\141" -let _ = Hashtbl.replace macro2utf8 "lAtail" "\226\164\155" -let _ = Hashtbl.replace macro2utf8 "Hcirc" "\196\164" -let _ = Hashtbl.replace macro2utf8 "aacute" "\195\161" -let _ = Hashtbl.replace macro2utf8 "dot" "\203\153" -let _ = Hashtbl.replace macro2utf8 "Tcy" "\208\162" -let _ = Hashtbl.replace macro2utf8 "nsub" "\226\138\132" -let _ = Hashtbl.replace macro2utf8 "kappa" "\206\186" -let _ = Hashtbl.replace macro2utf8 "ovbar" "\226\140\189" -let _ = Hashtbl.replace macro2utf8 "shcy" "\209\136" -let _ = Hashtbl.replace macro2utf8 "kappav" "\207\176" -let _ = Hashtbl.replace macro2utf8 "ropar" "\227\128\153" -let _ = Hashtbl.replace macro2utf8 "gtcc" "\226\170\167" -let _ = Hashtbl.replace macro2utf8 "ecolon" "\226\137\149" -let _ = Hashtbl.replace macro2utf8 "circledast" "\226\138\155" -let _ = Hashtbl.replace macro2utf8 "colon" ":" -let _ = Hashtbl.replace macro2utf8 "timesbar" "\226\168\177" -let _ = Hashtbl.replace macro2utf8 "precnsim" "\226\139\168" -let _ = Hashtbl.replace macro2utf8 "ord" "\226\169\157" -let _ = Hashtbl.replace macro2utf8 "real" "\226\132\156" -let _ = Hashtbl.replace macro2utf8 "nexists" "\226\136\132" -let _ = Hashtbl.replace macro2utf8 "nsup" "\226\138\133" -let _ = Hashtbl.replace macro2utf8 "zhcy" "\208\182" -let _ = Hashtbl.replace macro2utf8 "imacr" "\196\171" -let _ = Hashtbl.replace macro2utf8 "egrave" "\195\168" -let _ = Hashtbl.replace macro2utf8 "acirc" "\195\162" -let _ = Hashtbl.replace macro2utf8 "grave" "`" -let _ = Hashtbl.replace macro2utf8 "biguplus" "\226\138\142" -let _ = Hashtbl.replace macro2utf8 "HumpEqual" "\226\137\143" -let _ = Hashtbl.replace macro2utf8 "GreaterSlantEqual" "\226\169\190" -let _ = Hashtbl.replace macro2utf8 "capand" "\226\169\132" -let _ = Hashtbl.replace macro2utf8 "yuml" "\195\191" -let _ = Hashtbl.replace macro2utf8 "orv" "\226\169\155" -let _ = Hashtbl.replace macro2utf8 "Icy" "\208\152" -let _ = Hashtbl.replace macro2utf8 "rightharpoondown" "\226\135\129" -let _ = Hashtbl.replace macro2utf8 "upsilon" "\207\133" -let _ = Hashtbl.replace macro2utf8 "preccurlyeq" "\226\137\188" -let _ = Hashtbl.replace macro2utf8 "ShortUpArrow" "\226\140\131\239\184\128" -let _ = Hashtbl.replace macro2utf8 "searhk" "\226\164\165" -let _ = Hashtbl.replace macro2utf8 "commat" "@" -let _ = Hashtbl.replace macro2utf8 "Sqrt" "\226\136\154" -let _ = Hashtbl.replace macro2utf8 "wp" "\226\132\152" -let _ = Hashtbl.replace macro2utf8 "succnapprox" "\226\139\169" -let _ = Hashtbl.replace macro2utf8 "wr" "\226\137\128" -let _ = Hashtbl.replace macro2utf8 "NotTildeTilde" "\226\137\137" -let _ = Hashtbl.replace macro2utf8 "dcaron" "\196\143" -let _ = Hashtbl.replace macro2utf8 "Tfr" "\240\157\148\151" -let _ = Hashtbl.replace macro2utf8 "bigwedge" "\226\139\128" -let _ = Hashtbl.replace macro2utf8 "DScy" "\208\133" -let _ = Hashtbl.replace macro2utf8 "nrtrie" "\226\139\173" -let _ = Hashtbl.replace macro2utf8 "esim" "\226\137\130" -let _ = Hashtbl.replace macro2utf8 "Not" "\226\171\172" -let _ = Hashtbl.replace macro2utf8 "xmap" "\239\149\189" -let _ = Hashtbl.replace macro2utf8 "rect" "\226\150\173" -let _ = Hashtbl.replace macro2utf8 "Fouriertrf" "\226\132\177" -let _ = Hashtbl.replace macro2utf8 "xi" "\206\190" -let _ = Hashtbl.replace macro2utf8 "NotTilde" "\226\137\129" -let _ = Hashtbl.replace macro2utf8 "gbreve" "\196\159" -let _ = Hashtbl.replace macro2utf8 "par" "\226\136\165" -let _ = Hashtbl.replace macro2utf8 "ddots" "\226\139\177" -let _ = Hashtbl.replace macro2utf8 "nhArr" "\226\135\142" -let _ = Hashtbl.replace macro2utf8 "lsim" "\226\137\178" -let _ = Hashtbl.replace macro2utf8 "RightCeiling" "\226\140\137" -let _ = Hashtbl.replace macro2utf8 "nedot" "\226\137\160\239\184\128" -let _ = Hashtbl.replace macro2utf8 "thksim" "\226\136\188\239\184\128" -let _ = Hashtbl.replace macro2utf8 "lEg" "\226\139\154" -let _ = Hashtbl.replace macro2utf8 "Ifr" "\226\132\145" -let _ = Hashtbl.replace macro2utf8 "emsp" "\226\128\131" -let _ = Hashtbl.replace macro2utf8 "lopar" "\227\128\152" -let _ = Hashtbl.replace macro2utf8 "iiiint" "\226\168\140" -let _ = Hashtbl.replace macro2utf8 "straightepsilon" "\206\181" -let _ = Hashtbl.replace macro2utf8 "intlarhk" "\226\168\151" -let _ = Hashtbl.replace macro2utf8 "image" "\226\132\145" -let _ = Hashtbl.replace macro2utf8 "sqsubseteq" "\226\138\145" -let _ = Hashtbl.replace macro2utf8 "lnapprox" "\226\170\137" -let _ = Hashtbl.replace macro2utf8 "Leftrightarrow" "\226\135\148" -let _ = Hashtbl.replace macro2utf8 "cemptyv" "\226\166\178" -let _ = Hashtbl.replace macro2utf8 "alpha" "\206\177" -let _ = Hashtbl.replace macro2utf8 "uml" "\194\168" -let _ = Hashtbl.replace macro2utf8 "barwedge" "\226\138\188" -let _ = Hashtbl.replace macro2utf8 "KHcy" "\208\165" -let _ = Hashtbl.replace macro2utf8 "tilde" "\203\156" -let _ = Hashtbl.replace macro2utf8 "Superset" "\226\138\131" -let _ = Hashtbl.replace macro2utf8 "gesles" "\226\170\148" -let _ = Hashtbl.replace macro2utf8 "bigoplus" "\226\138\149" -let _ = Hashtbl.replace macro2utf8 "boxuL" "\226\149\155" -let _ = Hashtbl.replace macro2utf8 "rbbrk" "\227\128\149" -let _ = Hashtbl.replace macro2utf8 "nrightarrow" "\226\134\155" -let _ = Hashtbl.replace macro2utf8 "hkswarow" "\226\164\166" -let _ = Hashtbl.replace macro2utf8 "DiacriticalDoubleAcute" "\203\157" -let _ = Hashtbl.replace macro2utf8 "nbumpe" "\226\137\143\204\184" -let _ = Hashtbl.replace macro2utf8 "uhblk" "\226\150\128" -let _ = Hashtbl.replace macro2utf8 "NotSupersetEqual" "\226\138\137" -let _ = Hashtbl.replace macro2utf8 "ntgl" "\226\137\185" -let _ = Hashtbl.replace macro2utf8 "Fopf" "\240\157\148\189" -let _ = Hashtbl.replace macro2utf8 "boxuR" "\226\149\152" -let _ = Hashtbl.replace macro2utf8 "swarr" "\226\134\153" -let _ = Hashtbl.replace macro2utf8 "nsqsube" "\226\139\162" -let _ = Hashtbl.replace macro2utf8 "pluscir" "\226\168\162" -let _ = Hashtbl.replace macro2utf8 "pcy" "\208\191" -let _ = Hashtbl.replace macro2utf8 "leqslant" "\226\169\189" -let _ = Hashtbl.replace macro2utf8 "lnap" "\226\170\137" -let _ = Hashtbl.replace macro2utf8 "lthree" "\226\139\139" -let _ = Hashtbl.replace macro2utf8 "smte" "\226\170\172" -let _ = Hashtbl.replace macro2utf8 "olcross" "\226\166\187" -let _ = Hashtbl.replace macro2utf8 "nvrArr" "\226\135\143" -let _ = Hashtbl.replace macro2utf8 "andslope" "\226\169\152" -let _ = Hashtbl.replace macro2utf8 "MediumSpace" "\226\129\159" -let _ = Hashtbl.replace macro2utf8 "boxvH" "\226\149\170" -let _ = Hashtbl.replace macro2utf8 "Nacute" "\197\131" -let _ = Hashtbl.replace macro2utf8 "nGtv" "\226\137\171\204\184\239\184\128" -let _ = Hashtbl.replace macro2utf8 "Mopf" "\240\157\149\132" -let _ = Hashtbl.replace macro2utf8 "dfisht" "\226\165\191" -let _ = Hashtbl.replace macro2utf8 "boxvL" "\226\149\161" -let _ = Hashtbl.replace macro2utf8 "pertenk" "\226\128\177" -let _ = Hashtbl.replace macro2utf8 "NotPrecedes" "\226\138\128" -let _ = Hashtbl.replace macro2utf8 "profalar" "\226\140\174" -let _ = Hashtbl.replace macro2utf8 "roplus" "\226\168\174" -let _ = Hashtbl.replace macro2utf8 "boxvR" "\226\149\158" -let _ = Hashtbl.replace macro2utf8 "utrif" "\226\150\180" -let _ = Hashtbl.replace macro2utf8 "uHar" "\226\165\163" -let _ = Hashtbl.replace macro2utf8 "nltrie" "\226\139\172" -let _ = Hashtbl.replace macro2utf8 "NotNestedGreaterGreater" "\226\146\162\204\184" -let _ = Hashtbl.replace macro2utf8 "smtes" "\226\170\172\239\184\128" -let _ = Hashtbl.replace macro2utf8 "LeftAngleBracket" "\226\140\169" -let _ = Hashtbl.replace macro2utf8 "iogon" "\196\175" -let _ = Hashtbl.replace macro2utf8 "ExponentialE" "\226\133\135" -let _ = Hashtbl.replace macro2utf8 "Topf" "\240\157\149\139" -let _ = Hashtbl.replace macro2utf8 "GreaterEqual" "\226\137\165" -let _ = Hashtbl.replace macro2utf8 "DownTee" "\226\138\164" -let _ = Hashtbl.replace macro2utf8 "boxul" "\226\148\152" -let _ = Hashtbl.replace macro2utf8 "wreath" "\226\137\128" -let _ = Hashtbl.replace macro2utf8 "sigma" "\207\131" -let _ = Hashtbl.replace macro2utf8 "ENG" "\197\138" -let _ = Hashtbl.replace macro2utf8 "Ncedil" "\197\133" -let _ = Hashtbl.replace macro2utf8 "ecy" "\209\141" -let _ = Hashtbl.replace macro2utf8 "nsubset" "\226\138\132" -let _ = Hashtbl.replace macro2utf8 "LessFullEqual" "\226\137\166" -let _ = Hashtbl.replace macro2utf8 "bsolb" "\226\167\133" -let _ = Hashtbl.replace macro2utf8 "boxur" "\226\148\148" -let _ = Hashtbl.replace macro2utf8 "ThinSpace" "\226\128\137" -let _ = Hashtbl.replace macro2utf8 "supdsub" "\226\171\152" -let _ = Hashtbl.replace macro2utf8 "colone" "\226\137\148" -let _ = Hashtbl.replace macro2utf8 "curren" "\194\164" -let _ = Hashtbl.replace macro2utf8 "boxvh" "\226\148\188" -let _ = Hashtbl.replace macro2utf8 "ecaron" "\196\155" -let _ = Hashtbl.replace macro2utf8 "UnderBrace" "\239\184\184" -let _ = Hashtbl.replace macro2utf8 "caron" "\203\135" -let _ = Hashtbl.replace macro2utf8 "ultri" "\226\151\184" -let _ = Hashtbl.replace macro2utf8 "boxvl" "\226\148\164" -let _ = Hashtbl.replace macro2utf8 "scap" "\226\137\191" -let _ = Hashtbl.replace macro2utf8 "boxvr" "\226\148\156" -let _ = Hashtbl.replace macro2utf8 "bopf" "\240\157\149\147" -let _ = Hashtbl.replace macro2utf8 "pfr" "\240\157\148\173" -let _ = Hashtbl.replace macro2utf8 "nspar" "\226\136\166\239\184\128" -let _ = Hashtbl.replace macro2utf8 "NegativeMediumSpace" "\226\129\159\239\184\128" -let _ = Hashtbl.replace macro2utf8 "simgE" "\226\170\160" -let _ = Hashtbl.replace macro2utf8 "nvDash" "\226\138\173" -let _ = Hashtbl.replace macro2utf8 "NotGreaterFullEqual" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "uparrow" "\226\134\145" -let _ = Hashtbl.replace macro2utf8 "nsupset" "\226\138\133" -let _ = Hashtbl.replace macro2utf8 "simeq" "\226\137\131" -let _ = Hashtbl.replace macro2utf8 "Zcy" "\208\151" -let _ = Hashtbl.replace macro2utf8 "RightTriangle" "\226\138\179" -let _ = Hashtbl.replace macro2utf8 "Lang" "\227\128\138" -let _ = Hashtbl.replace macro2utf8 "Ucirc" "\195\155" -let _ = Hashtbl.replace macro2utf8 "iopf" "\240\157\149\154" -let _ = Hashtbl.replace macro2utf8 "leftrightsquigarrow" "\226\134\173" -let _ = Hashtbl.replace macro2utf8 "Gscr" "\240\157\146\162" -let _ = Hashtbl.replace macro2utf8 "lfloor" "\226\140\138" -let _ = Hashtbl.replace macro2utf8 "lbbrk" "\227\128\148" -let _ = Hashtbl.replace macro2utf8 "bigvee" "\226\139\129" -let _ = Hashtbl.replace macro2utf8 "ordf" "\194\170" -let _ = Hashtbl.replace macro2utf8 "rsquo" "\226\128\153" -let _ = Hashtbl.replace macro2utf8 "parallel" "\226\136\165" -let _ = Hashtbl.replace macro2utf8 "half" "\194\189" -let _ = Hashtbl.replace macro2utf8 "supseteq" "\226\138\135" -let _ = Hashtbl.replace macro2utf8 "ngeqq" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "popf" "\240\157\149\161" -let _ = Hashtbl.replace macro2utf8 "NonBreakingSpace" "\194\160" -let _ = Hashtbl.replace macro2utf8 "softcy" "\209\140" -let _ = Hashtbl.replace macro2utf8 "ordm" "\194\186" -let _ = Hashtbl.replace macro2utf8 "Nscr" "\240\157\146\169" -let _ = Hashtbl.replace macro2utf8 "owns" "\226\136\139" -let _ = Hashtbl.replace macro2utf8 "phi" "\207\149" -let _ = Hashtbl.replace macro2utf8 "efr" "\240\157\148\162" -let _ = Hashtbl.replace macro2utf8 "nesear" "\226\164\168" -let _ = Hashtbl.replace macro2utf8 "marker" "\226\150\174" -let _ = Hashtbl.replace macro2utf8 "lneq" "\226\137\168" -let _ = Hashtbl.replace macro2utf8 "parallet" "????" -let _ = Hashtbl.replace macro2utf8 "ndash" "\226\128\147" -let _ = Hashtbl.replace macro2utf8 "DoubleLeftTee" "\226\171\164" -let _ = Hashtbl.replace macro2utf8 "lArr" "\226\135\144" -let _ = Hashtbl.replace macro2utf8 "becaus" "\226\136\181" -let _ = Hashtbl.replace macro2utf8 "RightTee" "\226\138\162" -let _ = Hashtbl.replace macro2utf8 "Ocy" "\208\158" -let _ = Hashtbl.replace macro2utf8 "ntlg" "\226\137\184" -let _ = Hashtbl.replace macro2utf8 "cacute" "\196\135" -let _ = Hashtbl.replace macro2utf8 "wopf" "\240\157\149\168" -let _ = Hashtbl.replace macro2utf8 "Cup" "\226\139\147" -let _ = Hashtbl.replace macro2utf8 "Uscr" "\240\157\146\176" -let _ = Hashtbl.replace macro2utf8 "NotHumpEqual" "\226\137\143\204\184" -let _ = Hashtbl.replace macro2utf8 "rnmid" "\226\171\174" -let _ = Hashtbl.replace macro2utf8 "nsupE" "\226\138\137" -let _ = Hashtbl.replace macro2utf8 "bemptyv" "\226\166\176" -let _ = Hashtbl.replace macro2utf8 "lsqb" "[" -let _ = Hashtbl.replace macro2utf8 "nrarr" "\226\134\155" -let _ = Hashtbl.replace macro2utf8 "egs" "\226\139\157" -let _ = Hashtbl.replace macro2utf8 "reals" "\226\132\157" -let _ = Hashtbl.replace macro2utf8 "CupCap" "\226\137\141" -let _ = Hashtbl.replace macro2utf8 "Oacute" "\195\147" -let _ = Hashtbl.replace macro2utf8 "Zfr" "\226\132\168" -let _ = Hashtbl.replace macro2utf8 "ReverseEquilibrium" "\226\135\139" -let _ = Hashtbl.replace macro2utf8 "ccedil" "\195\167" -let _ = Hashtbl.replace macro2utf8 "bigtriangleup" "\226\150\179" -let _ = Hashtbl.replace macro2utf8 "piv" "\207\150" -let _ = Hashtbl.replace macro2utf8 "cirscir" "\226\167\130" -let _ = Hashtbl.replace macro2utf8 "exists" "\226\136\131" -let _ = Hashtbl.replace macro2utf8 "Uarrocir" "\226\165\137" -let _ = Hashtbl.replace macro2utf8 "Dcy" "\208\148" -let _ = Hashtbl.replace macro2utf8 "cscr" "\240\157\146\184" -let _ = Hashtbl.replace macro2utf8 "zcaron" "\197\190" -let _ = Hashtbl.replace macro2utf8 "isinE" "\226\139\185" -let _ = Hashtbl.replace macro2utf8 "gtcir" "\226\169\186" -let _ = Hashtbl.replace macro2utf8 "hookrightarrow" "\226\134\170" -let _ = Hashtbl.replace macro2utf8 "Int" "\226\136\172" -let _ = Hashtbl.replace macro2utf8 "nsupe" "\226\138\137" -let _ = Hashtbl.replace macro2utf8 "dotplus" "\226\136\148" -let _ = Hashtbl.replace macro2utf8 "ncup" "\226\169\130" -let _ = Hashtbl.replace macro2utf8 "jscr" "\240\157\146\191" -let _ = Hashtbl.replace macro2utf8 "angmsdaa" "\226\166\168" -let _ = Hashtbl.replace macro2utf8 "Iukcy" "\208\134" -let _ = Hashtbl.replace macro2utf8 "flat" "\226\153\173" -let _ = Hashtbl.replace macro2utf8 "bNot" "\226\171\173" -let _ = Hashtbl.replace macro2utf8 "angmsdab" "\226\166\169" -let _ = Hashtbl.replace macro2utf8 "angmsdac" "\226\166\170" -let _ = Hashtbl.replace macro2utf8 "xdtri" "\226\150\189" -let _ = Hashtbl.replace macro2utf8 "iota" "\206\185" -let _ = Hashtbl.replace macro2utf8 "angmsdad" "\226\166\171" -let _ = Hashtbl.replace macro2utf8 "angmsdae" "\226\166\172" -let _ = Hashtbl.replace macro2utf8 "rightarrowtail" "\226\134\163" -let _ = Hashtbl.replace macro2utf8 "angmsdaf" "\226\166\173" -let _ = Hashtbl.replace macro2utf8 "Ocirc" "\195\148" -let _ = Hashtbl.replace macro2utf8 "angmsdag" "\226\166\174" -let _ = Hashtbl.replace macro2utf8 "Ofr" "\240\157\148\146" -let _ = Hashtbl.replace macro2utf8 "maltese" "\226\156\160" -let _ = Hashtbl.replace macro2utf8 "angmsdah" "\226\166\175" -let _ = Hashtbl.replace macro2utf8 "Del" "\226\136\135" -let _ = Hashtbl.replace macro2utf8 "Barwed" "\226\140\134" -let _ = Hashtbl.replace macro2utf8 "drbkarow" "\226\164\144" -let _ = Hashtbl.replace macro2utf8 "qscr" "\240\157\147\134" -let _ = Hashtbl.replace macro2utf8 "ETH" "\195\144" -let _ = Hashtbl.replace macro2utf8 "operp" "\226\166\185" -let _ = Hashtbl.replace macro2utf8 "daleth" "\226\132\184" -let _ = Hashtbl.replace macro2utf8 "bull" "\226\128\162" -let _ = Hashtbl.replace macro2utf8 "simlE" "\226\170\159" -let _ = Hashtbl.replace macro2utf8 "lsquo" "\226\128\152" -let _ = Hashtbl.replace macro2utf8 "Larr" "\226\134\158" -let _ = Hashtbl.replace macro2utf8 "curarr" "\226\134\183" -let _ = Hashtbl.replace macro2utf8 "blacktriangleleft" "\226\151\130" -let _ = Hashtbl.replace macro2utf8 "hellip" "\226\128\166" -let _ = Hashtbl.replace macro2utf8 "DoubleVerticalBar" "\226\136\165" -let _ = Hashtbl.replace macro2utf8 "rBarr" "\226\164\143" -let _ = Hashtbl.replace macro2utf8 "chcy" "\209\135" -let _ = Hashtbl.replace macro2utf8 "varpi" "\207\150" -let _ = Hashtbl.replace macro2utf8 "Cconint" "\226\136\176" -let _ = Hashtbl.replace macro2utf8 "xlarr" "\239\149\182" -let _ = Hashtbl.replace macro2utf8 "xscr" "\240\157\147\141" -let _ = Hashtbl.replace macro2utf8 "DoubleLongRightArrow" "\239\149\186" -let _ = Hashtbl.replace macro2utf8 "CounterClockwiseContourIntegral" "\226\136\179" -let _ = Hashtbl.replace macro2utf8 "urcrop" "\226\140\142" -let _ = Hashtbl.replace macro2utf8 "RightAngleBracket" "\226\140\170" -let _ = Hashtbl.replace macro2utf8 "Rcaron" "\197\152" -let _ = Hashtbl.replace macro2utf8 "latail" "\226\164\153" -let _ = Hashtbl.replace macro2utf8 "pitchfork" "\226\139\148" -let _ = Hashtbl.replace macro2utf8 "nvinfin" "\226\167\158" -let _ = Hashtbl.replace macro2utf8 "hcirc" "\196\165" -let _ = Hashtbl.replace macro2utf8 "nexist" "\226\136\132" -let _ = Hashtbl.replace macro2utf8 "checkmark" "\226\156\147" -let _ = Hashtbl.replace macro2utf8 "tridot" "\226\151\172" -let _ = Hashtbl.replace macro2utf8 "vcy" "\208\178" -let _ = Hashtbl.replace macro2utf8 "isins" "\226\139\180" -let _ = Hashtbl.replace macro2utf8 "fllig" "\239\172\130" -let _ = Hashtbl.replace macro2utf8 "Dfr" "\240\157\148\135" -let _ = Hashtbl.replace macro2utf8 "hercon" "\226\138\185" -let _ = Hashtbl.replace macro2utf8 "gEl" "\226\139\155" -let _ = Hashtbl.replace macro2utf8 "bump" "\226\137\142" -let _ = Hashtbl.replace macro2utf8 "aleph" "\226\132\181" -let _ = Hashtbl.replace macro2utf8 "Ubreve" "\197\172" -let _ = Hashtbl.replace macro2utf8 "isinv" "\226\136\136" -let _ = Hashtbl.replace macro2utf8 "smile" "\226\140\163" -let _ = Hashtbl.replace macro2utf8 "llcorner" "\226\140\158" -let _ = Hashtbl.replace macro2utf8 "boxH" "\226\149\144" -let _ = Hashtbl.replace macro2utf8 "ecir" "\226\137\150" -let _ = Hashtbl.replace macro2utf8 "varnothing" "\226\136\133" -let _ = Hashtbl.replace macro2utf8 "iuml" "\195\175" -let _ = Hashtbl.replace macro2utf8 "mlcp" "\226\171\155" -let _ = Hashtbl.replace macro2utf8 "leftrightharpoons" "\226\135\139" -let _ = Hashtbl.replace macro2utf8 "ncong" "\226\137\135" -let _ = Hashtbl.replace macro2utf8 "Vert" "\226\128\150" -let _ = Hashtbl.replace macro2utf8 "vee" "\226\136\168" -let _ = Hashtbl.replace macro2utf8 "star" "\226\139\134" -let _ = Hashtbl.replace macro2utf8 "boxV" "\226\149\145" -let _ = Hashtbl.replace macro2utf8 "LeftRightArrow" "\226\134\148" -let _ = Hashtbl.replace macro2utf8 "leftrightarrow" "\226\134\148" -let _ = Hashtbl.replace macro2utf8 "lstrok" "\197\130" -let _ = Hashtbl.replace macro2utf8 "ell" "\226\132\147" -let _ = Hashtbl.replace macro2utf8 "VerticalSeparator" "\226\157\152" -let _ = Hashtbl.replace macro2utf8 "Ubrcy" "\208\142" -let _ = Hashtbl.replace macro2utf8 "NotGreater" "\226\137\175" -let _ = Hashtbl.replace macro2utf8 "Abreve" "\196\130" -let _ = Hashtbl.replace macro2utf8 "TildeTilde" "\226\137\136" -let _ = Hashtbl.replace macro2utf8 "CircleTimes" "\226\138\151" -let _ = Hashtbl.replace macro2utf8 "subsetneq" "\226\138\138" -let _ = Hashtbl.replace macro2utf8 "ltcc" "\226\170\166" -let _ = Hashtbl.replace macro2utf8 "els" "\226\139\156" -let _ = Hashtbl.replace macro2utf8 "succneqq" "\226\170\182" -let _ = Hashtbl.replace macro2utf8 "kcy" "\208\186" -let _ = Hashtbl.replace macro2utf8 "nshortmid" "\226\136\164\239\184\128" -let _ = Hashtbl.replace macro2utf8 "mldr" "\226\128\166" -let _ = Hashtbl.replace macro2utf8 "harr" "\226\134\148" -let _ = Hashtbl.replace macro2utf8 "gimel" "\226\132\183" -let _ = Hashtbl.replace macro2utf8 "Otimes" "\226\168\183" -let _ = Hashtbl.replace macro2utf8 "vsubnE" "\226\138\138\239\184\128" -let _ = Hashtbl.replace macro2utf8 "ltdot" "\226\139\150" -let _ = Hashtbl.replace macro2utf8 "boxh" "\226\148\128" -let _ = Hashtbl.replace macro2utf8 "notin" "\226\136\137" -let _ = Hashtbl.replace macro2utf8 "RuleDelayed" "\226\167\180" -let _ = Hashtbl.replace macro2utf8 "sqsube" "\226\138\145" -let _ = Hashtbl.replace macro2utf8 "macr" "\194\175" -let _ = Hashtbl.replace macro2utf8 "Icirc" "\195\142" -let _ = Hashtbl.replace macro2utf8 "comma" "," -let _ = Hashtbl.replace macro2utf8 "Cayleys" "\226\132\173" -let _ = Hashtbl.replace macro2utf8 "rightleftharpoons" "\226\135\140" -let _ = Hashtbl.replace macro2utf8 "Rarrtl" "\226\164\150" -let _ = Hashtbl.replace macro2utf8 "SquareSubsetEqual" "\226\138\145" -let _ = Hashtbl.replace macro2utf8 "NotGreaterEqual" "\226\137\177\226\131\165" -let _ = Hashtbl.replace macro2utf8 "vfr" "\240\157\148\179" -let _ = Hashtbl.replace macro2utf8 "utri" "\226\150\181" -let _ = Hashtbl.replace macro2utf8 "simne" "\226\137\134" -let _ = Hashtbl.replace macro2utf8 "LeftUpVectorBar" "\226\165\152" -let _ = Hashtbl.replace macro2utf8 "hksearow" "\226\164\165" -let _ = Hashtbl.replace macro2utf8 "boxv" "\226\148\130" -let _ = Hashtbl.replace macro2utf8 "curvearrowleft" "\226\134\182" -let _ = Hashtbl.replace macro2utf8 "eng" "\197\139" -let _ = Hashtbl.replace macro2utf8 "gtrarr" "\226\165\184" -let _ = Hashtbl.replace macro2utf8 "iecy" "\208\181" -let _ = Hashtbl.replace macro2utf8 "varr" "\226\134\149" -let _ = Hashtbl.replace macro2utf8 "lBarr" "\226\164\142" -let _ = Hashtbl.replace macro2utf8 "ker" "ker" -let _ = Hashtbl.replace macro2utf8 "imath" "\196\177" -let _ = Hashtbl.replace macro2utf8 "Dstrok" "\196\144" -let _ = Hashtbl.replace macro2utf8 "rlarr" "\226\135\132" -let _ = Hashtbl.replace macro2utf8 "leftleftarrows" "\226\135\135" -let _ = Hashtbl.replace macro2utf8 "DifferentialD" "\226\133\134" -let _ = Hashtbl.replace macro2utf8 "because" "\226\136\181" -let _ = Hashtbl.replace macro2utf8 "ulcrop" "\226\140\143" -let _ = Hashtbl.replace macro2utf8 "prE" "\226\170\175" -let _ = Hashtbl.replace macro2utf8 "oast" "\226\138\155" -let _ = Hashtbl.replace macro2utf8 "DotEqual" "\226\137\144" -let _ = Hashtbl.replace macro2utf8 "vsubne" "\226\138\138\239\184\128" -let _ = Hashtbl.replace macro2utf8 "hbar" "\226\132\143\239\184\128" -let _ = Hashtbl.replace macro2utf8 "subset" "\226\138\130" -let _ = Hashtbl.replace macro2utf8 "UpTeeArrow" "\226\134\165" -let _ = Hashtbl.replace macro2utf8 "LeftFloor" "\226\140\138" -let _ = Hashtbl.replace macro2utf8 "kfr" "\240\157\148\168" -let _ = Hashtbl.replace macro2utf8 "nisd" "\226\139\186" -let _ = Hashtbl.replace macro2utf8 "scnE" "\226\170\182" -let _ = Hashtbl.replace macro2utf8 "Ucy" "\208\163" -let _ = Hashtbl.replace macro2utf8 "nprec" "\226\138\128" -let _ = Hashtbl.replace macro2utf8 "ltrPar" "\226\166\150" -let _ = Hashtbl.replace macro2utf8 "Scaron" "\197\160" -let _ = Hashtbl.replace macro2utf8 "InvisibleComma" "\226\128\139" -let _ = Hashtbl.replace macro2utf8 "SquareUnion" "\226\138\148" -let _ = Hashtbl.replace macro2utf8 "ffllig" "\239\172\132" -let _ = Hashtbl.replace macro2utf8 "approxeq" "\226\137\138" -let _ = Hashtbl.replace macro2utf8 "yacute" "\195\189" -let _ = Hashtbl.replace macro2utf8 "pre" "\226\170\175" -let _ = Hashtbl.replace macro2utf8 "nsqsupe" "\226\139\163" -let _ = Hashtbl.replace macro2utf8 "supset" "\226\138\131" -let _ = Hashtbl.replace macro2utf8 "bsolhsub" "\\\226\138\130" -let _ = Hashtbl.replace macro2utf8 "nshortparallel" "\226\136\166\239\184\128" -let _ = Hashtbl.replace macro2utf8 "lozenge" "\226\151\138" -let _ = Hashtbl.replace macro2utf8 "lnot" "\194\172" -let _ = Hashtbl.replace macro2utf8 "Dopf" "\240\157\148\187" -let _ = Hashtbl.replace macro2utf8 "leftharpoonup" "\226\134\188" -let _ = Hashtbl.replace macro2utf8 "Jcy" "\208\153" -let _ = Hashtbl.replace macro2utf8 "rightarrow" "\226\134\146" -let _ = Hashtbl.replace macro2utf8 "ntriangleright" "\226\139\171" -let _ = Hashtbl.replace macro2utf8 "Ccirc" "\196\136" -let _ = Hashtbl.replace macro2utf8 "eacute" "\195\169" -let _ = Hashtbl.replace macro2utf8 "acute" "\194\180" -let _ = Hashtbl.replace macro2utf8 "Precedes" "\226\137\186" -let _ = Hashtbl.replace macro2utf8 "middot" "\194\183" -let _ = Hashtbl.replace macro2utf8 "lHar" "\226\165\162" -let _ = Hashtbl.replace macro2utf8 "eparsl" "\226\167\163" -let _ = Hashtbl.replace macro2utf8 "psi" "\207\136" -let _ = Hashtbl.replace macro2utf8 "parsl" "\226\136\165\239\184\128" -let _ = Hashtbl.replace macro2utf8 "UpperLeftArrow" "\226\134\150" -let _ = Hashtbl.replace macro2utf8 "oror" "\226\169\150" -let _ = Hashtbl.replace macro2utf8 "Kopf" "\240\157\149\130" -let _ = Hashtbl.replace macro2utf8 "apacir" "\226\169\175" -let _ = Hashtbl.replace macro2utf8 "dharl" "\226\135\131" -let _ = Hashtbl.replace macro2utf8 "nequiv" "\226\137\162" -let _ = Hashtbl.replace macro2utf8 "rightleftarrows" "\226\135\132" -let _ = Hashtbl.replace macro2utf8 "UnderParenthesis" "\239\184\182" -let _ = Hashtbl.replace macro2utf8 "notni" "\226\136\140" -let _ = Hashtbl.replace macro2utf8 "dagger" "\226\128\160" -let _ = Hashtbl.replace macro2utf8 "dharr" "\226\135\130" -let _ = Hashtbl.replace macro2utf8 "twoheadleftarrow" "\226\134\158" -let _ = Hashtbl.replace macro2utf8 "frac12" "\194\189" -let _ = Hashtbl.replace macro2utf8 "varsubsetneqq" "\226\138\138\239\184\128" -let _ = Hashtbl.replace macro2utf8 "frac13" "\226\133\147" -let _ = Hashtbl.replace macro2utf8 "Ufr" "\240\157\148\152" -let _ = Hashtbl.replace macro2utf8 "NestedLessLess" "\226\137\170" -let _ = Hashtbl.replace macro2utf8 "llarr" "\226\135\135" -let _ = Hashtbl.replace macro2utf8 "frac14" "\194\188" -let _ = Hashtbl.replace macro2utf8 "frac15" "\226\133\149" -let _ = Hashtbl.replace macro2utf8 "Ropf" "\226\132\157" -let _ = Hashtbl.replace macro2utf8 "frac16" "\226\133\153" -let _ = Hashtbl.replace macro2utf8 "lrtri" "\226\138\191" -let _ = Hashtbl.replace macro2utf8 "frac18" "\226\133\155" -let _ = Hashtbl.replace macro2utf8 "cedil" "\194\184" -let _ = Hashtbl.replace macro2utf8 "subsim" "\226\171\135" -let _ = Hashtbl.replace macro2utf8 "PrecedesTilde" "\226\137\190" -let _ = Hashtbl.replace macro2utf8 "igrave" "\195\172" -let _ = Hashtbl.replace macro2utf8 "gjcy" "\209\147" -let _ = Hashtbl.replace macro2utf8 "LeftVector" "\226\134\188" -let _ = Hashtbl.replace macro2utf8 "notniva" "\226\136\140" -let _ = Hashtbl.replace macro2utf8 "notnivb" "\226\139\190" -let _ = Hashtbl.replace macro2utf8 "ogon" "\203\155" -let _ = Hashtbl.replace macro2utf8 "notnivc" "\226\139\189" -let _ = Hashtbl.replace macro2utf8 "Yopf" "\240\157\149\144" -let _ = Hashtbl.replace macro2utf8 "there4" "\226\136\180" -let _ = Hashtbl.replace macro2utf8 "udarr" "\226\135\133" -let _ = Hashtbl.replace macro2utf8 "bkarow" "\226\164\141" -let _ = Hashtbl.replace macro2utf8 "frac23" "\226\133\148" -let _ = Hashtbl.replace macro2utf8 "frac25" "\226\133\150" -let _ = Hashtbl.replace macro2utf8 "njcy" "\209\154" -let _ = Hashtbl.replace macro2utf8 "Dashv" "\226\171\164" -let _ = Hashtbl.replace macro2utf8 "eta" "\206\183" -let _ = Hashtbl.replace macro2utf8 "bcong" "\226\137\140" -let _ = Hashtbl.replace macro2utf8 "Ugrave" "\195\153" -let _ = Hashtbl.replace macro2utf8 "csube" "\226\171\145" -let _ = Hashtbl.replace macro2utf8 "clubs" "\226\153\163" -let _ = Hashtbl.replace macro2utf8 "supmult" "\226\171\130" -let _ = Hashtbl.replace macro2utf8 "MinusPlus" "\226\136\147" -let _ = Hashtbl.replace macro2utf8 "Jfr" "\240\157\148\141" -let _ = Hashtbl.replace macro2utf8 "ensp" "\226\128\130" -let _ = Hashtbl.replace macro2utf8 "ucirc" "\195\187" -let _ = Hashtbl.replace macro2utf8 "supsim" "\226\171\136" -let _ = Hashtbl.replace macro2utf8 "eth" "\195\176" -let _ = Hashtbl.replace macro2utf8 "OverBrace" "\239\184\183" -let _ = Hashtbl.replace macro2utf8 "Dot" "\194\168" -let _ = Hashtbl.replace macro2utf8 "xcap" "\226\139\130" -let _ = Hashtbl.replace macro2utf8 "vangrt" "\226\138\190" -let _ = Hashtbl.replace macro2utf8 "NotSubsetEqual" "\226\138\136" -let _ = Hashtbl.replace macro2utf8 "frac34" "\194\190" -let _ = Hashtbl.replace macro2utf8 "frac35" "\226\133\151" -let _ = Hashtbl.replace macro2utf8 "planck" "\226\132\143\239\184\128" -let _ = Hashtbl.replace macro2utf8 "lnsim" "\226\139\166" -let _ = Hashtbl.replace macro2utf8 "gopf" "\240\157\149\152" -let _ = Hashtbl.replace macro2utf8 "frac38" "\226\133\156" -let _ = Hashtbl.replace macro2utf8 "DotDot" "\226\131\156" -let _ = Hashtbl.replace macro2utf8 "mapstoup" "\226\134\165" -let _ = Hashtbl.replace macro2utf8 "Escr" "\226\132\176" -let _ = Hashtbl.replace macro2utf8 "Integral" "\226\136\171" -let _ = Hashtbl.replace macro2utf8 "Agrave" "\195\128" -let _ = Hashtbl.replace macro2utf8 "longleftarrow" "????;" -let _ = Hashtbl.replace macro2utf8 "Tcaron" "\197\164" -let _ = Hashtbl.replace macro2utf8 "nopf" "\240\157\149\159" -let _ = Hashtbl.replace macro2utf8 "LongLeftRightArrow" "\239\149\184" -let _ = Hashtbl.replace macro2utf8 "Emacr" "\196\146" -let _ = Hashtbl.replace macro2utf8 "omid" "\226\166\182" -let _ = Hashtbl.replace macro2utf8 "spades" "\226\153\160" -let _ = Hashtbl.replace macro2utf8 "naturals" "\226\132\149" -let _ = Hashtbl.replace macro2utf8 "Lscr" "\226\132\146" -let _ = Hashtbl.replace macro2utf8 "udblac" "\197\177" -let _ = Hashtbl.replace macro2utf8 "SucceedsTilde" "\226\137\191" -let _ = Hashtbl.replace macro2utf8 "frac45" "\226\133\152" -let _ = Hashtbl.replace macro2utf8 "clubsuit" "\226\153\163" -let _ = Hashtbl.replace macro2utf8 "mumap" "\226\138\184" -let _ = Hashtbl.replace macro2utf8 "vltri" "\226\138\178" -let _ = Hashtbl.replace macro2utf8 "LeftArrowBar" "\226\135\164" -let _ = Hashtbl.replace macro2utf8 "zacute" "\197\186" -let _ = Hashtbl.replace macro2utf8 "szlig" "\195\159" -let _ = Hashtbl.replace macro2utf8 "suplarr" "\226\165\187" -let _ = Hashtbl.replace macro2utf8 "RightDownVector" "\226\135\130" -let _ = Hashtbl.replace macro2utf8 "male" "\226\153\130" -let _ = Hashtbl.replace macro2utf8 "RightDownVectorBar" "\226\165\149" -let _ = Hashtbl.replace macro2utf8 "gdot" "\196\161" -let _ = Hashtbl.replace macro2utf8 "nleqq" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "uopf" "\240\157\149\166" -let _ = Hashtbl.replace macro2utf8 "YIcy" "\208\135" -let _ = Hashtbl.replace macro2utf8 "Sscr" "\240\157\146\174" -let _ = Hashtbl.replace macro2utf8 "empty" "\226\136\133\239\184\128" -let _ = Hashtbl.replace macro2utf8 "Vdash" "\226\138\169" -let _ = Hashtbl.replace macro2utf8 "sqsubset" "\226\138\143" -let _ = Hashtbl.replace macro2utf8 "efDot" "\226\137\146" -let _ = Hashtbl.replace macro2utf8 "times" "\195\151" -let _ = Hashtbl.replace macro2utf8 "Oslash" "\195\152" -let _ = Hashtbl.replace macro2utf8 "itilde" "\196\169" -let _ = Hashtbl.replace macro2utf8 "frac56" "\226\133\154" -let _ = Hashtbl.replace macro2utf8 "numero" "\226\132\150" -let _ = Hashtbl.replace macro2utf8 "malt" "\226\156\160" -let _ = Hashtbl.replace macro2utf8 "npart" "\226\136\130\204\184" -let _ = Hashtbl.replace macro2utf8 "frac58" "\226\133\157" -let _ = Hashtbl.replace macro2utf8 "Zscr" "\240\157\146\181" -let _ = Hashtbl.replace macro2utf8 "integers" "\226\132\164" -let _ = Hashtbl.replace macro2utf8 "CloseCurlyQuote" "\226\128\153" -let _ = Hashtbl.replace macro2utf8 "NewLine" "\n" -let _ = Hashtbl.replace macro2utf8 "fcy" "\209\132" -let _ = Hashtbl.replace macro2utf8 "nwarr" "\226\134\150" -let _ = Hashtbl.replace macro2utf8 "thicksim" "\226\136\188\239\184\128" -let _ = Hashtbl.replace macro2utf8 "nprcue" "\226\139\160" -let _ = Hashtbl.replace macro2utf8 "lcub" "{" -let _ = Hashtbl.replace macro2utf8 "forall" "\226\136\128" -let _ = Hashtbl.replace macro2utf8 "plusacir" "\226\168\163" -let _ = Hashtbl.replace macro2utf8 "ascr" "\240\157\146\182" -let _ = Hashtbl.replace macro2utf8 "plustwo" "\226\168\167" -let _ = Hashtbl.replace macro2utf8 "Utilde" "\197\168" -let _ = Hashtbl.replace macro2utf8 "lambda" "\206\187" -let _ = Hashtbl.replace macro2utf8 "odash" "\226\138\157" -let _ = Hashtbl.replace macro2utf8 "iukcy" "\209\150" -let _ = Hashtbl.replace macro2utf8 "sqsupset" "\226\138\144" -let _ = Hashtbl.replace macro2utf8 "Racute" "\197\148" -let _ = Hashtbl.replace macro2utf8 "Longleftarrow" "????" -let _ = Hashtbl.replace macro2utf8 "capcap" "\226\169\139" -let _ = Hashtbl.replace macro2utf8 "ocirc" "\195\180" -let _ = Hashtbl.replace macro2utf8 "nless" "\226\137\174" -let _ = Hashtbl.replace macro2utf8 "Wedge" "\226\139\128" -let _ = Hashtbl.replace macro2utf8 "qfr" "\240\157\148\174" -let _ = Hashtbl.replace macro2utf8 "natur" "\226\153\174" -let _ = Hashtbl.replace macro2utf8 "hscr" "\240\157\146\189" -let _ = Hashtbl.replace macro2utf8 "ldca" "\226\164\182" -let _ = Hashtbl.replace macro2utf8 "ClockwiseContourIntegral" "\226\136\178" -let _ = Hashtbl.replace macro2utf8 "exp" "exp" -let _ = Hashtbl.replace macro2utf8 "RightTeeArrow" "\226\134\166" -let _ = Hashtbl.replace macro2utf8 "orarr" "\226\134\187" -let _ = Hashtbl.replace macro2utf8 "tanh" "tanh" -let _ = Hashtbl.replace macro2utf8 "frac78" "\226\133\158" -let _ = Hashtbl.replace macro2utf8 "Atilde" "\195\131" -let _ = Hashtbl.replace macro2utf8 "arcsin" "arcsin" -let _ = Hashtbl.replace macro2utf8 "Rcedil" "\197\150" -let _ = Hashtbl.replace macro2utf8 "oscr" "\226\132\180" -let _ = Hashtbl.replace macro2utf8 "InvisibleTimes" "\226\129\162" -let _ = Hashtbl.replace macro2utf8 "sime" "\226\137\131" -let _ = Hashtbl.replace macro2utf8 "simg" "\226\170\158" -let _ = Hashtbl.replace macro2utf8 "Conint" "\226\136\175" -let _ = Hashtbl.replace macro2utf8 "Yuml" "\197\184" -let _ = Hashtbl.replace macro2utf8 "rlhar" "\226\135\140" -let _ = Hashtbl.replace macro2utf8 "rarrbfs" "\226\164\160" -let _ = Hashtbl.replace macro2utf8 "siml" "\226\170\157" -let _ = Hashtbl.replace macro2utf8 "DownRightVectorBar" "\226\165\151" -let _ = Hashtbl.replace macro2utf8 "vscr" "\240\157\147\139" -let _ = Hashtbl.replace macro2utf8 "divide" "\195\183" -let _ = Hashtbl.replace macro2utf8 "PlusMinus" "\194\177" -let _ = Hashtbl.replace macro2utf8 "ffr" "\240\157\148\163" -let _ = Hashtbl.replace macro2utf8 "DownLeftTeeVector" "\226\165\158" -let _ = Hashtbl.replace macro2utf8 "EmptySmallSquare" "\226\151\189" -let _ = Hashtbl.replace macro2utf8 "SHCHcy" "\208\169" -let _ = Hashtbl.replace macro2utf8 "cirmid" "\226\171\175" -let _ = Hashtbl.replace macro2utf8 "sigmav" "\207\130" -let _ = Hashtbl.replace macro2utf8 "csub" "\226\171\143" -let _ = Hashtbl.replace macro2utf8 "npar" "\226\136\166" -let _ = Hashtbl.replace macro2utf8 "bsemi" "\226\129\143" -let _ = Hashtbl.replace macro2utf8 "swArr" "\226\135\153" -let _ = Hashtbl.replace macro2utf8 "Pcy" "\208\159" -let _ = Hashtbl.replace macro2utf8 "sinh" "sinh" -let _ = Hashtbl.replace macro2utf8 "lharul" "\226\165\170" -let _ = Hashtbl.replace macro2utf8 "Jukcy" "\208\132" -let _ = Hashtbl.replace macro2utf8 "permil" "\226\128\176" -let _ = Hashtbl.replace macro2utf8 "ndivides" "\226\136\164" -let _ = Hashtbl.replace macro2utf8 "Aring" "\195\133" -let _ = Hashtbl.replace macro2utf8 "longmapsto" "????" -let _ = Hashtbl.replace macro2utf8 "Esim" "\226\169\179" -let _ = Hashtbl.replace macro2utf8 "csup" "\226\171\144" -let _ = Hashtbl.replace macro2utf8 "trie" "\226\137\156" -let _ = Hashtbl.replace macro2utf8 "ubrcy" "\209\158" -let _ = Hashtbl.replace macro2utf8 "NotEqualTilde" "\226\137\130\204\184" -let _ = Hashtbl.replace macro2utf8 "dotminus" "\226\136\184" -let _ = Hashtbl.replace macro2utf8 "diamondsuit" "\226\153\162" -let _ = Hashtbl.replace macro2utf8 "xnis" "\226\139\187" -let _ = Hashtbl.replace macro2utf8 "Eogon" "\196\152" -let _ = Hashtbl.replace macro2utf8 "cuvee" "\226\139\142" -let _ = Hashtbl.replace macro2utf8 "DZcy" "\208\143" -let _ = Hashtbl.replace macro2utf8 "nRightarrow" "\226\135\143" -let _ = Hashtbl.replace macro2utf8 "sqsupe" "\226\138\146" -let _ = Hashtbl.replace macro2utf8 "nsccue" "\226\139\161" -let _ = Hashtbl.replace macro2utf8 "drcrop" "\226\140\140" -let _ = Hashtbl.replace macro2utf8 "DownBreve" "\204\145" -let _ = Hashtbl.replace macro2utf8 "Ecy" "\208\173" -let _ = Hashtbl.replace macro2utf8 "rdquor" "\226\128\157" -let _ = Hashtbl.replace macro2utf8 "rAtail" "\226\164\156" -let _ = Hashtbl.replace macro2utf8 "icirc" "\195\174" -let _ = Hashtbl.replace macro2utf8 "gacute" "\199\181" -let _ = Hashtbl.replace macro2utf8 "hyphen" "\226\128\144" -let _ = Hashtbl.replace macro2utf8 "uuml" "\195\188" -let _ = Hashtbl.replace macro2utf8 "thorn" "\195\190" -let _ = Hashtbl.replace macro2utf8 "ltri" "\226\151\131" -let _ = Hashtbl.replace macro2utf8 "eqslantgtr" "\226\139\157" -let _ = Hashtbl.replace macro2utf8 "DoubleContourIntegral" "\226\136\175" -let _ = Hashtbl.replace macro2utf8 "lescc" "\226\170\168" -let _ = Hashtbl.replace macro2utf8 "DiacriticalGrave" "`" -let _ = Hashtbl.replace macro2utf8 "NotPrecedesEqual" "\226\170\175\204\184" -let _ = Hashtbl.replace macro2utf8 "RightArrow" "\226\134\146" -let _ = Hashtbl.replace macro2utf8 "race" "\226\167\154" -let _ = Hashtbl.replace macro2utf8 "topbot" "\226\140\182" -let _ = Hashtbl.replace macro2utf8 "Pfr" "\240\157\148\147" -let _ = Hashtbl.replace macro2utf8 "napprox" "\226\137\137" -let _ = Hashtbl.replace macro2utf8 "Sacute" "\197\154" -let _ = Hashtbl.replace macro2utf8 "cupor" "\226\169\133" -let _ = Hashtbl.replace macro2utf8 "OverBar" "\194\175" -let _ = Hashtbl.replace macro2utf8 "bepsi" "\207\182" -let _ = Hashtbl.replace macro2utf8 "plankv" "\226\132\143" -let _ = Hashtbl.replace macro2utf8 "lap" "\226\137\178" -let _ = Hashtbl.replace macro2utf8 "orslope" "\226\169\151" -let _ = Hashtbl.replace macro2utf8 "beta" "\206\178" -let _ = Hashtbl.replace macro2utf8 "ShortDownArrow" "\226\140\132\239\184\128" -let _ = Hashtbl.replace macro2utf8 "perp" "\226\138\165" -let _ = Hashtbl.replace macro2utf8 "lat" "\226\170\171" -let _ = Hashtbl.replace macro2utf8 "CenterDot" "\194\183" -let _ = Hashtbl.replace macro2utf8 "urcorner" "\226\140\157" -let _ = Hashtbl.replace macro2utf8 "models" "\226\138\167" -let _ = Hashtbl.replace macro2utf8 "beth" "\226\132\182" -let _ = Hashtbl.replace macro2utf8 "subE" "\226\138\134" -let _ = Hashtbl.replace macro2utf8 "subnE" "\226\138\138" -let _ = Hashtbl.replace macro2utf8 "ldots" "\226\128\166" -let _ = Hashtbl.replace macro2utf8 "yacy" "\209\143" -let _ = Hashtbl.replace macro2utf8 "udhar" "\226\165\174" -let _ = Hashtbl.replace macro2utf8 "Scedil" "\197\158" -let _ = Hashtbl.replace macro2utf8 "subsub" "\226\171\149" -let _ = Hashtbl.replace macro2utf8 "nvrtrie" "\226\139\173\204\184" -let _ = Hashtbl.replace macro2utf8 "Phi" "\206\166" -let _ = Hashtbl.replace macro2utf8 "Efr" "\240\157\148\136" -let _ = Hashtbl.replace macro2utf8 "larrfs" "\226\164\157" -let _ = Hashtbl.replace macro2utf8 "angle" "\226\136\160" -let _ = Hashtbl.replace macro2utf8 "TildeFullEqual" "\226\137\133" -let _ = Hashtbl.replace macro2utf8 "Jcirc" "\196\180" -let _ = Hashtbl.replace macro2utf8 "THORN" "\195\158" -let _ = Hashtbl.replace macro2utf8 "acE" "\226\167\155" -let _ = Hashtbl.replace macro2utf8 "Longleftrightarrow" "????" -let _ = Hashtbl.replace macro2utf8 "xuplus" "\226\138\142" -let _ = Hashtbl.replace macro2utf8 "searr" "\226\134\152" -let _ = Hashtbl.replace macro2utf8 "gvertneqq" "\226\137\169\239\184\128" -let _ = Hashtbl.replace macro2utf8 "subsup" "\226\171\147" -let _ = Hashtbl.replace macro2utf8 "NotSucceedsEqual" "\226\170\176\204\184" -let _ = Hashtbl.replace macro2utf8 "gtrsim" "\226\137\179" -let _ = Hashtbl.replace macro2utf8 "nrArr" "\226\135\143" -let _ = Hashtbl.replace macro2utf8 "NotSquareSupersetEqual" "\226\139\163" -let _ = Hashtbl.replace macro2utf8 "notindot" "\226\139\182\239\184\128" -let _ = Hashtbl.replace macro2utf8 "HARDcy" "\208\170" -let _ = Hashtbl.replace macro2utf8 "jmath" "j\239\184\128" -let _ = Hashtbl.replace macro2utf8 "aelig" "\195\166" -let _ = Hashtbl.replace macro2utf8 "slarr" "\226\134\144\239\184\128" -let _ = Hashtbl.replace macro2utf8 "dlcrop" "\226\140\141" -let _ = Hashtbl.replace macro2utf8 "sube" "\226\138\134" -let _ = Hashtbl.replace macro2utf8 "cuepr" "\226\139\158" -let _ = Hashtbl.replace macro2utf8 "supsub" "\226\171\148" -let _ = Hashtbl.replace macro2utf8 "trianglelefteq" "\226\138\180" -let _ = Hashtbl.replace macro2utf8 "subne" "\226\138\138" -let _ = Hashtbl.replace macro2utf8 "between" "\226\137\172" -let _ = Hashtbl.replace macro2utf8 "measuredangle" "\226\136\161" -let _ = Hashtbl.replace macro2utf8 "swnwar" "\226\164\170" -let _ = Hashtbl.replace macro2utf8 "lcy" "\208\187" -let _ = Hashtbl.replace macro2utf8 "ccirc" "\196\137" -let _ = Hashtbl.replace macro2utf8 "larrhk" "\226\134\169" -let _ = Hashtbl.replace macro2utf8 "DiacriticalTilde" "\203\156" -let _ = Hashtbl.replace macro2utf8 "brvbar" "\194\166" -let _ = Hashtbl.replace macro2utf8 "triangledown" "\226\150\191" -let _ = Hashtbl.replace macro2utf8 "dtrif" "\226\150\190" -let _ = Hashtbl.replace macro2utf8 "Bopf" "\240\157\148\185" -let _ = Hashtbl.replace macro2utf8 "xwedge" "\226\139\128" -let _ = Hashtbl.replace macro2utf8 "rightsquigarrow" "\226\134\157" -let _ = Hashtbl.replace macro2utf8 "acd" "\226\136\191" -let _ = Hashtbl.replace macro2utf8 "supsup" "\226\171\150" -let _ = Hashtbl.replace macro2utf8 "UpEquilibrium" "\226\165\174" -let _ = Hashtbl.replace macro2utf8 "succ" "\226\137\187" -let _ = Hashtbl.replace macro2utf8 "eqslantless" "\226\139\156" -let _ = Hashtbl.replace macro2utf8 "coprod" "\226\136\144" -let _ = Hashtbl.replace macro2utf8 "OpenCurlyDoubleQuote" "\226\128\156" -let _ = Hashtbl.replace macro2utf8 "NotGreaterSlantEqual" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "solb" "\226\167\132" -let _ = Hashtbl.replace macro2utf8 "HumpDownHump" "\226\137\142" -let _ = Hashtbl.replace macro2utf8 "gtrapprox" "\226\137\179" -let _ = Hashtbl.replace macro2utf8 "Iopf" "\240\157\149\128" -let _ = Hashtbl.replace macro2utf8 "leg" "\226\139\154" -let _ = Hashtbl.replace macro2utf8 "wfr" "\240\157\148\180" -let _ = Hashtbl.replace macro2utf8 "mapstoleft" "\226\134\164" -let _ = Hashtbl.replace macro2utf8 "gnapprox" "\226\170\138" -let _ = Hashtbl.replace macro2utf8 "lgE" "\226\170\145" -let _ = Hashtbl.replace macro2utf8 "CloseCurlyDoubleQuote" "\226\128\157" -let _ = Hashtbl.replace macro2utf8 "NotNestedLessLess" "\226\146\161\204\184" -let _ = Hashtbl.replace macro2utf8 "acy" "\208\176" -let _ = Hashtbl.replace macro2utf8 "leq" "\226\137\164" -let _ = Hashtbl.replace macro2utf8 "Popf" "\226\132\153" -let _ = Hashtbl.replace macro2utf8 "les" "\226\169\189" -let _ = Hashtbl.replace macro2utf8 "succcurlyeq" "\226\137\189" -let _ = Hashtbl.replace macro2utf8 "heartsuit" "\226\153\161" -let _ = Hashtbl.replace macro2utf8 "angmsd" "\226\136\161" -let _ = Hashtbl.replace macro2utf8 "cuesc" "\226\139\159" -let _ = Hashtbl.replace macro2utf8 "lesseqgtr" "\226\139\154" -let _ = Hashtbl.replace macro2utf8 "vartriangleright" "\226\138\179" -let _ = Hashtbl.replace macro2utf8 "csupe" "\226\171\146" -let _ = Hashtbl.replace macro2utf8 "rthree" "\226\139\140" -let _ = Hashtbl.replace macro2utf8 "Idot" "\196\176" -let _ = Hashtbl.replace macro2utf8 "gtdot" "\226\139\151" -let _ = Hashtbl.replace macro2utf8 "dashv" "\226\138\163" -let _ = Hashtbl.replace macro2utf8 "Odblac" "\197\144" -let _ = Hashtbl.replace macro2utf8 "Lmidot" "\196\191" -let _ = Hashtbl.replace macro2utf8 "andd" "\226\169\156" -let _ = Hashtbl.replace macro2utf8 "Wopf" "\240\157\149\142" -let _ = Hashtbl.replace macro2utf8 "nvltrie" "\226\139\172\204\184" -let _ = Hashtbl.replace macro2utf8 "nhpar" "\226\171\178" -let _ = Hashtbl.replace macro2utf8 "geqslant" "\226\169\190" -let _ = Hashtbl.replace macro2utf8 "xlArr" "\239\149\185" -let _ = Hashtbl.replace macro2utf8 "SquareSubset" "\226\138\143" -let _ = Hashtbl.replace macro2utf8 "intcal" "\226\138\186" -let _ = Hashtbl.replace macro2utf8 "ljcy" "\209\153" -let _ = Hashtbl.replace macro2utf8 "lfr" "\240\157\148\169" -let _ = Hashtbl.replace macro2utf8 "gtlPar" "\226\166\149" -let _ = Hashtbl.replace macro2utf8 "zigrarr" "\226\135\157" -let _ = Hashtbl.replace macro2utf8 "nvap" "\226\137\137\204\184" -let _ = Hashtbl.replace macro2utf8 "boxtimes" "\226\138\160" -let _ = Hashtbl.replace macro2utf8 "raquo" "\194\187" -let _ = Hashtbl.replace macro2utf8 "CircleMinus" "\226\138\150" -let _ = Hashtbl.replace macro2utf8 "centerdot" "\194\183" -let _ = Hashtbl.replace macro2utf8 "xoplus" "\226\138\149" -let _ = Hashtbl.replace macro2utf8 "simdot" "\226\169\170" -let _ = Hashtbl.replace macro2utf8 "Vcy" "\208\146" -let _ = Hashtbl.replace macro2utf8 "profline" "\226\140\146" -let _ = Hashtbl.replace macro2utf8 "ltquest" "\226\169\187" -let _ = Hashtbl.replace macro2utf8 "andv" "\226\169\154" -let _ = Hashtbl.replace macro2utf8 "lessgtr" "\226\137\182" -let _ = Hashtbl.replace macro2utf8 "lesdoto" "\226\170\129" -let _ = Hashtbl.replace macro2utf8 "NotSquareSubset" "\226\138\143\204\184" -let _ = Hashtbl.replace macro2utf8 "bullet" "\226\128\162" -let _ = Hashtbl.replace macro2utf8 "rarrsim" "\226\165\180" -let _ = Hashtbl.replace macro2utf8 "Tcedil" "\197\162" -let _ = Hashtbl.replace macro2utf8 "Hstrok" "\196\166" -let _ = Hashtbl.replace macro2utf8 "eopf" "\240\157\149\150" -let _ = Hashtbl.replace macro2utf8 "Theta" "\206\152" -let _ = Hashtbl.replace macro2utf8 "Cscr" "\240\157\146\158" -let _ = Hashtbl.replace macro2utf8 "emacr" "\196\147" -let _ = Hashtbl.replace macro2utf8 "UnionPlus" "\226\138\142" -let _ = Hashtbl.replace macro2utf8 "Vee" "\226\139\129" -let _ = Hashtbl.replace macro2utf8 "arctan" "arctan" -let _ = Hashtbl.replace macro2utf8 "afr" "\240\157\148\158" -let _ = Hashtbl.replace macro2utf8 "thinsp" "\226\128\137" -let _ = Hashtbl.replace macro2utf8 "bottom" "\226\138\165" -let _ = Hashtbl.replace macro2utf8 "lopf" "\240\157\149\157" -let _ = Hashtbl.replace macro2utf8 "larrlp" "\226\134\171" -let _ = Hashtbl.replace macro2utf8 "lbrace" "{" -let _ = Hashtbl.replace macro2utf8 "Jscr" "\240\157\146\165" -let _ = Hashtbl.replace macro2utf8 "Kcy" "\208\154" -let _ = Hashtbl.replace macro2utf8 "shortparallel" "\226\136\165\239\184\128" -let _ = Hashtbl.replace macro2utf8 "hairsp" "\226\128\138" -let _ = Hashtbl.replace macro2utf8 "osol" "\226\138\152" -let _ = Hashtbl.replace macro2utf8 "lbrack" "[" -let _ = Hashtbl.replace macro2utf8 "hArr" "\226\135\148" -let _ = Hashtbl.replace macro2utf8 "vdash" "\226\138\162" -let _ = Hashtbl.replace macro2utf8 "UpDownArrow" "\226\134\149" -let _ = Hashtbl.replace macro2utf8 "edot" "\196\151" -let _ = Hashtbl.replace macro2utf8 "vzigzag" "\226\166\154" -let _ = Hashtbl.replace macro2utf8 "sopf" "\240\157\149\164" -let _ = Hashtbl.replace macro2utf8 "NotLessGreater" "\226\137\184" -let _ = Hashtbl.replace macro2utf8 "Qscr" "\240\157\146\172" -let _ = Hashtbl.replace macro2utf8 "Gammad" "\207\156" -let _ = Hashtbl.replace macro2utf8 "SubsetEqual" "\226\138\134" -let _ = Hashtbl.replace macro2utf8 "uplus" "\226\138\142" -let _ = Hashtbl.replace macro2utf8 "LeftTriangle" "\226\138\178" -let _ = Hashtbl.replace macro2utf8 "ange" "\226\166\164" -let _ = Hashtbl.replace macro2utf8 "lim" "lim" -let _ = Hashtbl.replace macro2utf8 "triangleright" "\226\150\185" -let _ = Hashtbl.replace macro2utf8 "angrt" "\226\136\159" -let _ = Hashtbl.replace macro2utf8 "rfloor" "\226\140\139" -let _ = Hashtbl.replace macro2utf8 "bigtriangledown" "\226\150\189" -let _ = Hashtbl.replace macro2utf8 "ofcir" "\226\166\191" -let _ = Hashtbl.replace macro2utf8 "Vfr" "\240\157\148\153" -let _ = Hashtbl.replace macro2utf8 "zopf" "\240\157\149\171" -let _ = Hashtbl.replace macro2utf8 "UpArrowDownArrow" "\226\135\133" -let _ = Hashtbl.replace macro2utf8 "Xscr" "\240\157\146\179" -let _ = Hashtbl.replace macro2utf8 "digamma" "\207\156" -let _ = Hashtbl.replace macro2utf8 "SmallCircle" "\226\136\152" -let _ = Hashtbl.replace macro2utf8 "vArr" "\226\135\149" -let _ = Hashtbl.replace macro2utf8 "eqsim" "\226\137\130" -let _ = Hashtbl.replace macro2utf8 "downharpoonright" "\226\135\130" -let _ = Hashtbl.replace macro2utf8 "Ccaron" "\196\140" -let _ = Hashtbl.replace macro2utf8 "sdot" "\226\139\133" -let _ = Hashtbl.replace macro2utf8 "frown" "\226\140\162" -let _ = Hashtbl.replace macro2utf8 "angst" "\226\132\171" -let _ = Hashtbl.replace macro2utf8 "lesges" "\226\170\147" -let _ = Hashtbl.replace macro2utf8 "iacute" "\195\173" -let _ = Hashtbl.replace macro2utf8 "wedge" "\226\136\167" -let _ = Hashtbl.replace macro2utf8 "ssetmn" "\226\136\150\239\184\128" -let _ = Hashtbl.replace macro2utf8 "rotimes" "\226\168\181" -let _ = Hashtbl.replace macro2utf8 "laquo" "\194\171" -let _ = Hashtbl.replace macro2utf8 "bigstar" "\226\152\133" -let _ = Hashtbl.replace macro2utf8 "Rrightarrow" "\226\135\155" -let _ = Hashtbl.replace macro2utf8 "erDot" "\226\137\147" -let _ = Hashtbl.replace macro2utf8 "subseteq" "\226\138\134" -let _ = Hashtbl.replace macro2utf8 "leftharpoondown" "\226\134\189" -let _ = Hashtbl.replace macro2utf8 "infin" "\226\136\158" -let _ = Hashtbl.replace macro2utf8 "zdot" "\197\188" -let _ = Hashtbl.replace macro2utf8 "solbar" "\226\140\191" -let _ = Hashtbl.replace macro2utf8 "Iuml" "\195\143" -let _ = Hashtbl.replace macro2utf8 "Kfr" "\240\157\148\142" -let _ = Hashtbl.replace macro2utf8 "fscr" "\240\157\146\187" -let _ = Hashtbl.replace macro2utf8 "DJcy" "\208\130" -let _ = Hashtbl.replace macro2utf8 "veeeq" "\226\137\154" -let _ = Hashtbl.replace macro2utf8 "Star" "\226\139\134" -let _ = Hashtbl.replace macro2utf8 "lsquor" "\226\128\154" -let _ = Hashtbl.replace macro2utf8 "Uacute" "\195\154" -let _ = Hashtbl.replace macro2utf8 "weierp" "\226\132\152" -let _ = Hashtbl.replace macro2utf8 "rang" "\226\140\170" -let _ = Hashtbl.replace macro2utf8 "hamilt" "\226\132\139" -let _ = Hashtbl.replace macro2utf8 "angsph" "\226\136\162" -let _ = Hashtbl.replace macro2utf8 "YUcy" "\208\174" -let _ = Hashtbl.replace macro2utf8 "Wcirc" "\197\180" -let _ = Hashtbl.replace macro2utf8 "supsetneq" "\226\138\139" -let _ = Hashtbl.replace macro2utf8 "gap" "\226\137\179" -let _ = Hashtbl.replace macro2utf8 "mscr" "\240\157\147\130" -let _ = Hashtbl.replace macro2utf8 "KJcy" "\208\140" -let _ = Hashtbl.replace macro2utf8 "qprime" "\226\129\151" -let _ = Hashtbl.replace macro2utf8 "EqualTilde" "\226\137\130" -let _ = Hashtbl.replace macro2utf8 "vBar" "\226\171\168" -let _ = Hashtbl.replace macro2utf8 "larrpl" "\226\164\185" -let _ = Hashtbl.replace macro2utf8 "nvge" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "approx" "\226\137\136" -let _ = Hashtbl.replace macro2utf8 "lnE" "\226\137\168" -let _ = Hashtbl.replace macro2utf8 "NotGreaterLess" "\226\137\185" -let _ = Hashtbl.replace macro2utf8 "epar" "\226\139\149" -let _ = Hashtbl.replace macro2utf8 "bigotimes" "\226\138\151" -let _ = Hashtbl.replace macro2utf8 "xharr" "\239\149\184" -let _ = Hashtbl.replace macro2utf8 "roang" "\239\149\153" -let _ = Hashtbl.replace macro2utf8 "xcup" "\226\139\131" -let _ = Hashtbl.replace macro2utf8 "tscr" "\240\157\147\137" -let _ = Hashtbl.replace macro2utf8 "thkap" "\226\137\136\239\184\128" -let _ = Hashtbl.replace macro2utf8 "Aacute" "\195\129" -let _ = Hashtbl.replace macro2utf8 "rcy" "\209\128" -let _ = Hashtbl.replace macro2utf8 "jukcy" "\209\148" -let _ = Hashtbl.replace macro2utf8 "hookleftarrow" "\226\134\169" -let _ = Hashtbl.replace macro2utf8 "napid" "\226\137\139\204\184" -let _ = Hashtbl.replace macro2utf8 "tscy" "\209\134" -let _ = Hashtbl.replace macro2utf8 "nvgt" "\226\137\175" -let _ = Hashtbl.replace macro2utf8 "lpar" "(" -let _ = Hashtbl.replace macro2utf8 "ldsh" "\226\134\178" -let _ = Hashtbl.replace macro2utf8 "aring" "\195\165" -let _ = Hashtbl.replace macro2utf8 "nGg" "\226\139\153\204\184" -let _ = Hashtbl.replace macro2utf8 "LessEqualGreater" "\226\139\154" -let _ = Hashtbl.replace macro2utf8 "gcd" "gcd" -let _ = Hashtbl.replace macro2utf8 "oplus" "\226\138\149" -let _ = Hashtbl.replace macro2utf8 "lcaron" "\196\190" -let _ = Hashtbl.replace macro2utf8 "DownArrow" "\226\134\147" -let _ = Hashtbl.replace macro2utf8 "xutri" "\226\150\179" -let _ = Hashtbl.replace macro2utf8 "Psi" "\206\168" -let _ = Hashtbl.replace macro2utf8 "lesssim" "\226\137\178" -let _ = Hashtbl.replace macro2utf8 "topcir" "\226\171\177" -let _ = Hashtbl.replace macro2utf8 "puncsp" "\226\128\136" -let _ = Hashtbl.replace macro2utf8 "origof" "\226\138\182" -let _ = Hashtbl.replace macro2utf8 "gnsim" "\226\139\167" -let _ = Hashtbl.replace macro2utf8 "eogon" "\196\153" -let _ = Hashtbl.replace macro2utf8 "spar" "\226\136\165\239\184\128" -let _ = Hashtbl.replace macro2utf8 "LowerRightArrow" "\226\134\152" -let _ = Hashtbl.replace macro2utf8 "Lleftarrow" "\226\135\154" -let _ = Hashtbl.replace macro2utf8 "nGt" "\226\137\171\204\184" -let _ = Hashtbl.replace macro2utf8 "euml" "\195\171" -let _ = Hashtbl.replace macro2utf8 "reg" "\194\174" -let _ = Hashtbl.replace macro2utf8 "exponentiale" "\226\133\135" -let _ = Hashtbl.replace macro2utf8 "qint" "\226\168\140" -let _ = Hashtbl.replace macro2utf8 "sqcups" "\226\138\148\239\184\128" -let _ = Hashtbl.replace macro2utf8 "lne" "\226\137\168" -let _ = Hashtbl.replace macro2utf8 "LessSlantEqual" "\226\169\189" -let _ = Hashtbl.replace macro2utf8 "Egrave" "\195\136" -let _ = Hashtbl.replace macro2utf8 "orderof" "\226\132\180" -let _ = Hashtbl.replace macro2utf8 "cirE" "\226\167\131" -let _ = Hashtbl.replace macro2utf8 "nleqslant" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "gcy" "\208\179" -let _ = Hashtbl.replace macro2utf8 "curvearrowright" "\226\134\183" -let _ = Hashtbl.replace macro2utf8 "ratail" "\226\134\163" -let _ = Hashtbl.replace macro2utf8 "emsp13" "\226\128\132" -let _ = Hashtbl.replace macro2utf8 "sdotb" "\226\138\161" -let _ = Hashtbl.replace macro2utf8 "horbar" "\226\128\149" -let _ = Hashtbl.replace macro2utf8 "emsp14" "\226\128\133" -let _ = Hashtbl.replace macro2utf8 "npre" "\226\170\175\204\184" -let _ = Hashtbl.replace macro2utf8 "rbrksld" "\226\166\142" -let _ = Hashtbl.replace macro2utf8 "sdote" "\226\169\166" -let _ = Hashtbl.replace macro2utf8 "varsupsetneqq" "\226\138\139\239\184\128" -let _ = Hashtbl.replace macro2utf8 "VeryThinSpace" "\226\128\138" -let _ = Hashtbl.replace macro2utf8 "DownArrowBar" "\226\164\147" -let _ = Hashtbl.replace macro2utf8 "Rightarrow" "\226\135\146" -let _ = Hashtbl.replace macro2utf8 "ocir" "\226\138\154" -let _ = Hashtbl.replace macro2utf8 "NotHumpDownHump" "\226\137\142\204\184" -let _ = Hashtbl.replace macro2utf8 "darr" "\226\134\147" -let _ = Hashtbl.replace macro2utf8 "geqq" "\226\137\167" -let _ = Hashtbl.replace macro2utf8 "sup1" "\194\185" -let _ = Hashtbl.replace macro2utf8 "log" "log" -let _ = Hashtbl.replace macro2utf8 "sup2" "\194\178" -let _ = Hashtbl.replace macro2utf8 "micro" "\194\181" -let _ = Hashtbl.replace macro2utf8 "amp" "&" -let _ = Hashtbl.replace macro2utf8 "arccos" "arccos" -let _ = Hashtbl.replace macro2utf8 "sup3" "\194\179" -let _ = Hashtbl.replace macro2utf8 "GreaterTilde" "\226\137\179" -let _ = Hashtbl.replace macro2utf8 "circeq" "\226\137\151" -let _ = Hashtbl.replace macro2utf8 "rfr" "\240\157\148\175" -let _ = Hashtbl.replace macro2utf8 "dash" "\226\128\144" -let _ = Hashtbl.replace macro2utf8 "rbrkslu" "\226\166\144" -let _ = Hashtbl.replace macro2utf8 "Dcaron" "\196\142" -let _ = Hashtbl.replace macro2utf8 "and" "\226\136\167" -let _ = Hashtbl.replace macro2utf8 "Vbar" "\226\171\171" -let _ = Hashtbl.replace macro2utf8 "angzarr" "\226\141\188" -let _ = Hashtbl.replace macro2utf8 "gel" "\226\139\155" -let _ = Hashtbl.replace macro2utf8 "ang" "\226\136\160" -let _ = Hashtbl.replace macro2utf8 "lor" "\226\136\168" -let _ = Hashtbl.replace macro2utf8 "circ" "\226\136\152" -let _ = Hashtbl.replace macro2utf8 "upharpoonright" "\226\134\190" -let _ = Hashtbl.replace macro2utf8 "dblac" "\203\157" -let _ = Hashtbl.replace macro2utf8 "subsetneqq" "\226\138\138" -let _ = Hashtbl.replace macro2utf8 "rhard" "\226\135\129" -let _ = Hashtbl.replace macro2utf8 "Intersection" "\226\139\130" -let _ = Hashtbl.replace macro2utf8 "cire" "\226\137\151" -let _ = Hashtbl.replace macro2utf8 "apE" "\226\137\138" -let _ = Hashtbl.replace macro2utf8 "sung" "\226\153\170" -let _ = Hashtbl.replace macro2utf8 "geq" "\226\137\165" -let _ = Hashtbl.replace macro2utf8 "succsim" "\226\137\191" -let _ = Hashtbl.replace macro2utf8 "ges" "\226\169\190" -let _ = Hashtbl.replace macro2utf8 "Gbreve" "\196\158" -let _ = Hashtbl.replace macro2utf8 "intercal" "\226\138\186" -let _ = Hashtbl.replace macro2utf8 "supE" "\226\138\135" -let _ = Hashtbl.replace macro2utf8 "NotCupCap" "\226\137\173" -let _ = Hashtbl.replace macro2utf8 "loz" "\226\151\138" -let _ = Hashtbl.replace macro2utf8 "capcup" "\226\169\135" -let _ = Hashtbl.replace macro2utf8 "larrtl" "\226\134\162" -let _ = Hashtbl.replace macro2utf8 "AElig" "\195\134" -let _ = Hashtbl.replace macro2utf8 "rarr" "\226\134\146" -let _ = Hashtbl.replace macro2utf8 "varkappa" "\207\176" -let _ = Hashtbl.replace macro2utf8 "upsi" "\207\133" -let _ = Hashtbl.replace macro2utf8 "loang" "\239\149\152" -let _ = Hashtbl.replace macro2utf8 "looparrowleft" "\226\134\171" -let _ = Hashtbl.replace macro2utf8 "IOcy" "\208\129" -let _ = Hashtbl.replace macro2utf8 "backprime" "\226\128\181" -let _ = Hashtbl.replace macro2utf8 "sstarf" "\226\139\134" -let _ = Hashtbl.replace macro2utf8 "rharu" "\226\135\128" -let _ = Hashtbl.replace macro2utf8 "gesl" "\226\139\155\239\184\128" -let _ = Hashtbl.replace macro2utf8 "xotime" "\226\138\151" -let _ = Hashtbl.replace macro2utf8 "minus" "\226\136\146" -let _ = Hashtbl.replace macro2utf8 "gvnE" "\226\137\169\239\184\128" -let _ = Hashtbl.replace macro2utf8 "gfr" "\240\157\148\164" -let _ = Hashtbl.replace macro2utf8 "lfisht" "\226\165\188" -let _ = Hashtbl.replace macro2utf8 "jcirc" "\196\181" -let _ = Hashtbl.replace macro2utf8 "roarr" "\226\135\190" -let _ = Hashtbl.replace macro2utf8 "rho" "\207\129" -let _ = Hashtbl.replace macro2utf8 "nvle" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "sect" "\194\167" -let _ = Hashtbl.replace macro2utf8 "ggg" "\226\139\153" -let _ = Hashtbl.replace macro2utf8 "plusb" "\226\138\158" -let _ = Hashtbl.replace macro2utf8 "NotTildeFullEqual" "\226\137\135" -let _ = Hashtbl.replace macro2utf8 "NegativeVeryThinSpace" "\226\128\138\239\184\128" -let _ = Hashtbl.replace macro2utf8 "ape" "\226\137\138" -let _ = Hashtbl.replace macro2utf8 "pluse" "\226\169\178" -let _ = Hashtbl.replace macro2utf8 "dollar" "$" -let _ = Hashtbl.replace macro2utf8 "divonx" "\226\139\135" -let _ = Hashtbl.replace macro2utf8 "partial" "\226\136\130" -let _ = Hashtbl.replace macro2utf8 "DoubleLeftRightArrow" "\226\135\148" -let _ = Hashtbl.replace macro2utf8 "varepsilon" "\206\181" -let _ = Hashtbl.replace macro2utf8 "supe" "\226\138\135" -let _ = Hashtbl.replace macro2utf8 "nvlt" "\226\137\174" -let _ = Hashtbl.replace macro2utf8 "angrtvb" "\226\166\157\239\184\128" -let _ = Hashtbl.replace macro2utf8 "gets" "\226\134\144" -let _ = Hashtbl.replace macro2utf8 "nparallel" "\226\136\166" -let _ = Hashtbl.replace macro2utf8 "varphi" "\207\134" -let _ = Hashtbl.replace macro2utf8 "nsupseteq" "\226\138\137" -let _ = Hashtbl.replace macro2utf8 "circledR" "\194\174" -let _ = Hashtbl.replace macro2utf8 "circledS" "\226\147\136" -let _ = Hashtbl.replace macro2utf8 "primes" "\226\132\153" -let _ = Hashtbl.replace macro2utf8 "cuwed" "\226\139\143" -let _ = Hashtbl.replace macro2utf8 "cupcap" "\226\169\134" -let _ = Hashtbl.replace macro2utf8 "nLl" "\226\139\152\204\184" -let _ = Hashtbl.replace macro2utf8 "lozf" "\226\167\171" -let _ = Hashtbl.replace macro2utf8 "ShortLeftArrow" "\226\134\144\239\184\128" -let _ = Hashtbl.replace macro2utf8 "nLt" "\226\137\170\204\184" -let _ = Hashtbl.replace macro2utf8 "lesdotor" "\226\170\131" -let _ = Hashtbl.replace macro2utf8 "Fcy" "\208\164" -let _ = Hashtbl.replace macro2utf8 "scnsim" "\226\139\169" -let _ = Hashtbl.replace macro2utf8 "VerticalLine" "|" -let _ = Hashtbl.replace macro2utf8 "nwArr" "\226\135\150" -let _ = Hashtbl.replace macro2utf8 "LeftTeeArrow" "\226\134\164" -let _ = Hashtbl.replace macro2utf8 "iprod" "\226\168\188" -let _ = Hashtbl.replace macro2utf8 "lsh" "\226\134\176" -let _ = Hashtbl.replace macro2utf8 "Congruent" "\226\137\161" -let _ = Hashtbl.replace macro2utf8 "NotLeftTriangle" "\226\139\170" -let _ = Hashtbl.replace macro2utf8 "rdldhar" "\226\165\169" -let _ = Hashtbl.replace macro2utf8 "varpropto" "\226\136\157" -let _ = Hashtbl.replace macro2utf8 "nvlArr" "\226\135\141" -let _ = Hashtbl.replace macro2utf8 "arg" "arg" -let _ = Hashtbl.replace macro2utf8 "lhard" "\226\134\189" -let _ = Hashtbl.replace macro2utf8 "surd" "????" -let _ = Hashtbl.replace macro2utf8 "napos" "\197\137" -let _ = Hashtbl.replace macro2utf8 "lparlt" "\226\166\147" -let _ = Hashtbl.replace macro2utf8 "hslash" "\226\132\143" -let _ = Hashtbl.replace macro2utf8 "Gopf" "\240\157\148\190" -let _ = Hashtbl.replace macro2utf8 "SHcy" "\208\168" -let _ = Hashtbl.replace macro2utf8 "triangle" "\226\150\181" -let _ = Hashtbl.replace macro2utf8 "Qfr" "\240\157\148\148" -let _ = Hashtbl.replace macro2utf8 "DiacriticalAcute" "\194\180" -let _ = Hashtbl.replace macro2utf8 "tbrk" "\226\142\180" -let _ = Hashtbl.replace macro2utf8 "Implies" "\226\135\146" -let _ = Hashtbl.replace macro2utf8 "comp" "\226\136\129" -let _ = Hashtbl.replace macro2utf8 "ddarr" "\226\135\138" -let _ = Hashtbl.replace macro2utf8 "Colone" "\226\169\180" -let _ = Hashtbl.replace macro2utf8 "smashp" "\226\168\179" -let _ = Hashtbl.replace macro2utf8 "ccups" "\226\169\140" -let _ = Hashtbl.replace macro2utf8 "triangleq" "\226\137\156" -let _ = Hashtbl.replace macro2utf8 "NotSquareSubsetEqual" "\226\139\162" -let _ = Hashtbl.replace macro2utf8 "Nopf" "\226\132\149" -let _ = Hashtbl.replace macro2utf8 "ZHcy" "\208\150" -let _ = Hashtbl.replace macro2utf8 "map" "\226\134\166" -let _ = Hashtbl.replace macro2utf8 "lharu" "\226\134\188" -let _ = Hashtbl.replace macro2utf8 "glE" "\226\170\146" -let _ = Hashtbl.replace macro2utf8 "cong" "\226\137\133" -let _ = Hashtbl.replace macro2utf8 "Ecaron" "\196\154" -let _ = Hashtbl.replace macro2utf8 "Uring" "\197\174" -let _ = Hashtbl.replace macro2utf8 "blacktriangleright" "\226\150\184" -let _ = Hashtbl.replace macro2utf8 "ntilde" "\195\177" -let _ = Hashtbl.replace macro2utf8 "max" "max" -let _ = Hashtbl.replace macro2utf8 "loarr" "\226\135\189" -let _ = Hashtbl.replace macro2utf8 "LeftArrow" "\226\134\144" -let _ = Hashtbl.replace macro2utf8 "Gdot" "\196\160" -let _ = Hashtbl.replace macro2utf8 "Uopf" "\240\157\149\140" -let _ = Hashtbl.replace macro2utf8 "bigsqcup" "\226\138\148" -let _ = Hashtbl.replace macro2utf8 "wedgeq" "\226\137\153" -let _ = Hashtbl.replace macro2utf8 "RoundImplies" "\226\165\176" -let _ = Hashtbl.replace macro2utf8 "prap" "\226\137\190" -let _ = Hashtbl.replace macro2utf8 "gescc" "\226\170\169" -let _ = Hashtbl.replace macro2utf8 "realine" "\226\132\155" -let _ = Hashtbl.replace macro2utf8 "ast" "*" -let _ = Hashtbl.replace macro2utf8 "subedot" "\226\171\131" -let _ = Hashtbl.replace macro2utf8 "LeftTeeVector" "\226\165\154" -let _ = Hashtbl.replace macro2utf8 "female" "\226\153\128" -let _ = Hashtbl.replace macro2utf8 "circlearrowleft" "\226\134\186" -let _ = Hashtbl.replace macro2utf8 "Ffr" "\240\157\148\137" -let _ = Hashtbl.replace macro2utf8 "VDash" "\226\138\171" -let _ = Hashtbl.replace macro2utf8 "jsercy" "\209\152" -let _ = Hashtbl.replace macro2utf8 "Proportional" "\226\136\157" -let _ = Hashtbl.replace macro2utf8 "OverBracket" "\226\142\180" -let _ = Hashtbl.replace macro2utf8 "gla" "\226\170\165" -let _ = Hashtbl.replace macro2utf8 "NotElement" "\226\136\137" -let _ = Hashtbl.replace macro2utf8 "theta" "\206\184" -let _ = Hashtbl.replace macro2utf8 "kcedil" "\196\183" -let _ = Hashtbl.replace macro2utf8 "smeparsl" "\226\167\164" -let _ = Hashtbl.replace macro2utf8 "rarrb" "\226\135\165" -let _ = Hashtbl.replace macro2utf8 "rarrc" "\226\164\179" -let _ = Hashtbl.replace macro2utf8 "ograve" "\195\178" -let _ = Hashtbl.replace macro2utf8 "glj" "\226\170\164" -let _ = Hashtbl.replace macro2utf8 "infty" "\226\136\158" -let _ = Hashtbl.replace macro2utf8 "gnE" "\226\137\169" -let _ = Hashtbl.replace macro2utf8 "copf" "\240\157\149\148" -let _ = Hashtbl.replace macro2utf8 "LeftArrowRightArrow" "\226\135\134" -let _ = Hashtbl.replace macro2utf8 "cwconint" "\226\136\178" -let _ = Hashtbl.replace macro2utf8 "Ascr" "\240\157\146\156" -let _ = Hashtbl.replace macro2utf8 "NegativeThinSpace" "\226\128\137\239\184\128" -let _ = Hashtbl.replace macro2utf8 "varsubsetneq" "\226\138\138\239\184\128" -let _ = Hashtbl.replace macro2utf8 "trisb" "\226\167\141" -let _ = Hashtbl.replace macro2utf8 "rightharpoonup" "\226\135\128" -let _ = Hashtbl.replace macro2utf8 "imagline" "\226\132\144" -let _ = Hashtbl.replace macro2utf8 "mcy" "\208\188" -let _ = Hashtbl.replace macro2utf8 "Cacute" "\196\134" -let _ = Hashtbl.replace macro2utf8 "bumpeq" "\226\137\143" -let _ = Hashtbl.replace macro2utf8 "jopf" "\240\157\149\155" -let _ = Hashtbl.replace macro2utf8 "shchcy" "\209\137" -let _ = Hashtbl.replace macro2utf8 "rarrw" "\226\134\157" -let _ = Hashtbl.replace macro2utf8 "uuarr" "\226\135\136" -let _ = Hashtbl.replace macro2utf8 "doteq" "\226\137\144" -let _ = Hashtbl.replace macro2utf8 "cudarrl" "\226\164\184" -let _ = Hashtbl.replace macro2utf8 "varsigma" "\207\130" -let _ = Hashtbl.replace macro2utf8 "Hscr" "\226\132\139" -let _ = Hashtbl.replace macro2utf8 "DownArrowUpArrow" "\226\135\181" -let _ = Hashtbl.replace macro2utf8 "Ecirc" "\195\138" -let _ = Hashtbl.replace macro2utf8 "DD" "\226\133\133" -let _ = Hashtbl.replace macro2utf8 "copy" "\194\169" -let _ = Hashtbl.replace macro2utf8 "SquareIntersection" "\226\138\147" -let _ = Hashtbl.replace macro2utf8 "RightUpVector" "\226\134\190" -let _ = Hashtbl.replace macro2utf8 "NotSucceedsSlantEqual" "\226\139\161" -let _ = Hashtbl.replace macro2utf8 "cudarrr" "\226\164\181" -let _ = Hashtbl.replace macro2utf8 "verbar" "|" -let _ = Hashtbl.replace macro2utf8 "ncaron" "\197\136" -let _ = Hashtbl.replace macro2utf8 "prurel" "\226\138\176" -let _ = Hashtbl.replace macro2utf8 "nearr" "\226\134\151" -let _ = Hashtbl.replace macro2utf8 "cdot" "\196\139" -let _ = Hashtbl.replace macro2utf8 "qopf" "\240\157\149\162" -let _ = Hashtbl.replace macro2utf8 "SucceedsSlantEqual" "\226\137\189" -let _ = Hashtbl.replace macro2utf8 "Oscr" "\240\157\146\170" -let _ = Hashtbl.replace macro2utf8 "xfr" "\240\157\148\181" -let _ = Hashtbl.replace macro2utf8 "gne" "\226\137\169" -let _ = Hashtbl.replace macro2utf8 "Ccedil" "\195\135" -let _ = Hashtbl.replace macro2utf8 "nlarr" "\226\134\154" -let _ = Hashtbl.replace macro2utf8 "inodot" "\196\177" -let _ = Hashtbl.replace macro2utf8 "prec" "\226\137\186" -let _ = Hashtbl.replace macro2utf8 "percnt" "%" -let _ = Hashtbl.replace macro2utf8 "Exists" "\226\136\131" -let _ = Hashtbl.replace macro2utf8 "bcy" "\208\177" -let _ = Hashtbl.replace macro2utf8 "xopf" "\240\157\149\169" -let _ = Hashtbl.replace macro2utf8 "nsimeq" "\226\137\132" -let _ = Hashtbl.replace macro2utf8 "nrtri" "\226\139\171" -let _ = Hashtbl.replace macro2utf8 "barvee" "\226\138\189" -let _ = Hashtbl.replace macro2utf8 "Vscr" "\240\157\146\177" -let _ = Hashtbl.replace macro2utf8 "Zcaron" "\197\189" -let _ = Hashtbl.replace macro2utf8 "ReverseElement" "\226\136\139" -let _ = Hashtbl.replace macro2utf8 "npolint" "\226\168\148" -let _ = Hashtbl.replace macro2utf8 "NotGreaterTilde" "\226\137\181" -let _ = Hashtbl.replace macro2utf8 "lmoustache" "\226\142\176" -let _ = Hashtbl.replace macro2utf8 "forkv" "\226\171\153" -let _ = Hashtbl.replace macro2utf8 "rmoustache" "\226\142\177" -let _ = Hashtbl.replace macro2utf8 "DownLeftVectorBar" "\226\165\150" -let _ = Hashtbl.replace macro2utf8 "cosh" "cosh" -let _ = Hashtbl.replace macro2utf8 "mfr" "\240\157\148\170" -let _ = Hashtbl.replace macro2utf8 "LessGreater" "\226\137\182" -let _ = Hashtbl.replace macro2utf8 "zeetrf" "\226\132\168" -let _ = Hashtbl.replace macro2utf8 "DiacriticalDot" "\203\153" -let _ = Hashtbl.replace macro2utf8 "Poincareplane" "\226\132\140" -let _ = Hashtbl.replace macro2utf8 "curlyeqsucc" "\226\139\159" -let _ = Hashtbl.replace macro2utf8 "Equal" "\226\169\181" -let _ = Hashtbl.replace macro2utf8 "divides" "\226\136\163" -let _ = Hashtbl.replace macro2utf8 "scpolint" "\226\168\147" -let _ = Hashtbl.replace macro2utf8 "ngsim" "\226\137\181" -let _ = Hashtbl.replace macro2utf8 "larrbfs" "\226\164\159" -let _ = Hashtbl.replace macro2utf8 "HilbertSpace" "\226\132\139" -let _ = Hashtbl.replace macro2utf8 "otilde" "\195\181" -let _ = Hashtbl.replace macro2utf8 "larrb" "\226\135\164" -let _ = Hashtbl.replace macro2utf8 "wcirc" "\197\181" -let _ = Hashtbl.replace macro2utf8 "dscr" "\240\157\146\185" -let _ = Hashtbl.replace macro2utf8 "phmmat" "\226\132\179" -let _ = Hashtbl.replace macro2utf8 "lacute" "\196\186" -let _ = Hashtbl.replace macro2utf8 "tstrok" "\197\167" -let _ = Hashtbl.replace macro2utf8 "NotDoubleVerticalBar" "\226\136\166" -let _ = Hashtbl.replace macro2utf8 "lagran" "\226\132\146" -let _ = Hashtbl.replace macro2utf8 "NotRightTriangle" "\226\139\171" -let _ = Hashtbl.replace macro2utf8 "dscy" "\209\149" -let _ = Hashtbl.replace macro2utf8 "rightrightarrows" "\226\135\137" -let _ = Hashtbl.replace macro2utf8 "seArr" "\226\135\152" -let _ = Hashtbl.replace macro2utf8 "RightTriangleBar" "\226\167\144" -let _ = Hashtbl.replace macro2utf8 "coth" "coth" -let _ = Hashtbl.replace macro2utf8 "swarrow" "\226\134\153" -let _ = Hashtbl.replace macro2utf8 "semi" ";" -let _ = Hashtbl.replace macro2utf8 "kscr" "\240\157\147\128" -let _ = Hashtbl.replace macro2utf8 "NotLessEqual" "\226\137\176\226\131\165" -let _ = Hashtbl.replace macro2utf8 "cularr" "\226\134\182" -let _ = Hashtbl.replace macro2utf8 "blacklozenge" "\226\167\171" -let _ = Hashtbl.replace macro2utf8 "realpart" "\226\132\156" -let _ = Hashtbl.replace macro2utf8 "LeftTriangleEqual" "\226\138\180" -let _ = Hashtbl.replace macro2utf8 "bfr" "\240\157\148\159" -let _ = Hashtbl.replace macro2utf8 "Uuml" "\195\156" -let _ = Hashtbl.replace macro2utf8 "longleftrightarrow" "????" -let _ = Hashtbl.replace macro2utf8 "lcedil" "\196\188" -let _ = Hashtbl.replace macro2utf8 "complement" "\226\136\129" -let _ = Hashtbl.replace macro2utf8 "rscr" "\240\157\147\135" -let _ = Hashtbl.replace macro2utf8 "mho" "\226\132\167" -let _ = Hashtbl.replace macro2utf8 "mcomma" "\226\168\169" -let _ = Hashtbl.replace macro2utf8 "wedbar" "\226\169\159" -let _ = Hashtbl.replace macro2utf8 "NotVerticalBar" "\226\136\164" -let _ = Hashtbl.replace macro2utf8 "Lcy" "\208\155" -let _ = Hashtbl.replace macro2utf8 "tprime" "\226\128\180" -let _ = Hashtbl.replace macro2utf8 "precneqq" "\226\170\181" -let _ = Hashtbl.replace macro2utf8 "Downarrow" "\226\135\147" -let _ = Hashtbl.replace macro2utf8 "rsh" "\226\134\177" -let _ = Hashtbl.replace macro2utf8 "mid" "\226\136\163" -let _ = Hashtbl.replace macro2utf8 "blank" "\226\144\163" -let _ = Hashtbl.replace macro2utf8 "square" "\226\150\161" -let _ = Hashtbl.replace macro2utf8 "squarf" "\226\150\170" -let _ = Hashtbl.replace macro2utf8 "fflig" "\239\172\128" -let _ = Hashtbl.replace macro2utf8 "downdownarrows" "\226\135\138" -let _ = Hashtbl.replace macro2utf8 "yscr" "\240\157\147\142" -let _ = Hashtbl.replace macro2utf8 "subdot" "\226\170\189" -let _ = Hashtbl.replace macro2utf8 "ShortRightArrow" "\226\134\146\239\184\128" -let _ = Hashtbl.replace macro2utf8 "NotCongruent" "\226\137\162" -let _ = Hashtbl.replace macro2utf8 "Gg" "\226\139\153" -let _ = Hashtbl.replace macro2utf8 "Lstrok" "\197\129" -let _ = Hashtbl.replace macro2utf8 "min" "max" -let _ = Hashtbl.replace macro2utf8 "Laplacetrf" "\226\132\146" -let _ = Hashtbl.replace macro2utf8 "rarrap" "\226\165\181" -let _ = Hashtbl.replace macro2utf8 "NotLessSlantEqual" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "DoubleRightArrow" "\226\135\146" -let _ = Hashtbl.replace macro2utf8 "Wfr" "\240\157\148\154" -let _ = Hashtbl.replace macro2utf8 "subrarr" "\226\165\185" -let _ = Hashtbl.replace macro2utf8 "numsp" "\226\128\135" -let _ = Hashtbl.replace macro2utf8 "khcy" "\209\133" -let _ = Hashtbl.replace macro2utf8 "oint" "\226\136\174" -let _ = Hashtbl.replace macro2utf8 "vprop" "\226\136\157" -let _ = Hashtbl.replace macro2utf8 "hardcy" "\209\138" -let _ = Hashtbl.replace macro2utf8 "boxminus" "\226\138\159" -let _ = Hashtbl.replace macro2utf8 "GreaterLess" "\226\137\183" -let _ = Hashtbl.replace macro2utf8 "thetav" "\207\145" -let _ = Hashtbl.replace macro2utf8 "scE" "\226\137\190" -let _ = Hashtbl.replace macro2utf8 "Gt" "\226\137\171" -let _ = Hashtbl.replace macro2utf8 "Acy" "\208\144" -let _ = Hashtbl.replace macro2utf8 "backcong" "\226\137\140" -let _ = Hashtbl.replace macro2utf8 "gtquest" "\226\169\188" -let _ = Hashtbl.replace macro2utf8 "awint" "\226\168\145" -let _ = Hashtbl.replace macro2utf8 "profsurf" "\226\140\147" -let _ = Hashtbl.replace macro2utf8 "capdot" "\226\169\128" -let _ = Hashtbl.replace macro2utf8 "supdot" "\226\170\190" -let _ = Hashtbl.replace macro2utf8 "oelig" "\197\147" -let _ = Hashtbl.replace macro2utf8 "doteqdot" "\226\137\145" -let _ = Hashtbl.replace macro2utf8 "rharul" "\226\165\172" -let _ = Hashtbl.replace macro2utf8 "cylcty" "\226\140\173" -let _ = Hashtbl.replace macro2utf8 "epsi" "\206\181" -let _ = Hashtbl.replace macro2utf8 "eqcirc" "\226\137\150" -let _ = Hashtbl.replace macro2utf8 "nLeftarrow" "\226\135\141" -let _ = Hashtbl.replace macro2utf8 "rtrie" "\226\138\181" -let _ = Hashtbl.replace macro2utf8 "para" "\194\182" -let _ = Hashtbl.replace macro2utf8 "Lfr" "\240\157\148\143" -let _ = Hashtbl.replace macro2utf8 "rtrif" "\226\150\184" -let _ = Hashtbl.replace macro2utf8 "NotReverseElement" "\226\136\140" -let _ = Hashtbl.replace macro2utf8 "emptyv" "\226\136\133" -let _ = Hashtbl.replace macro2utf8 "nldr" "\226\128\165" -let _ = Hashtbl.replace macro2utf8 "leqq" "\226\137\166" -let _ = Hashtbl.replace macro2utf8 "CapitalDifferentialD" "\226\133\133" -let _ = Hashtbl.replace macro2utf8 "supsetneqq" "\226\138\139" -let _ = Hashtbl.replace macro2utf8 "boxDL" "\226\149\151" -let _ = Hashtbl.replace macro2utf8 "Im" "\226\132\145" -let _ = Hashtbl.replace macro2utf8 "sce" "\226\137\189" -let _ = Hashtbl.replace macro2utf8 "prsim" "\226\137\190" -let _ = Hashtbl.replace macro2utf8 "diams" "\226\153\166" -let _ = Hashtbl.replace macro2utf8 "gtreqqless" "\226\139\155" -let _ = Hashtbl.replace macro2utf8 "boxDR" "\226\149\148" -let _ = Hashtbl.replace macro2utf8 "vartriangleleft" "\226\138\178" -let _ = Hashtbl.replace macro2utf8 "SupersetEqual" "\226\138\135" -let _ = Hashtbl.replace macro2utf8 "Omega" "\206\169" -let _ = Hashtbl.replace macro2utf8 "nsubseteqq" "\226\138\136" -let _ = Hashtbl.replace macro2utf8 "Subset" "\226\139\144" -let _ = Hashtbl.replace macro2utf8 "ncongdot" "\226\169\173\204\184" -let _ = Hashtbl.replace macro2utf8 "minusb" "\226\138\159" -let _ = Hashtbl.replace macro2utf8 "ltimes" "\226\139\137" -let _ = Hashtbl.replace macro2utf8 "seswar" "\226\164\169" -let _ = Hashtbl.replace macro2utf8 "part" "\226\136\130" -let _ = Hashtbl.replace macro2utf8 "bumpE" "\226\170\174" -let _ = Hashtbl.replace macro2utf8 "minusd" "\226\136\184" -let _ = Hashtbl.replace macro2utf8 "Amacr" "\196\128" -let _ = Hashtbl.replace macro2utf8 "nleq" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "nles" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "NotLess" "\226\137\174" -let _ = Hashtbl.replace macro2utf8 "scy" "\209\129" -let _ = Hashtbl.replace macro2utf8 "iinfin" "\226\167\156" -let _ = Hashtbl.replace macro2utf8 "Afr" "\240\157\148\132" -let _ = Hashtbl.replace macro2utf8 "isinsv" "\226\139\179" -let _ = Hashtbl.replace macro2utf8 "prnE" "\226\170\181" -let _ = Hashtbl.replace macro2utf8 "lesg" "\226\139\154\239\184\128" -let _ = Hashtbl.replace macro2utf8 "cups" "\226\136\170\239\184\128" -let _ = Hashtbl.replace macro2utf8 "thickapprox" "\226\137\136\239\184\128" -let _ = Hashtbl.replace macro2utf8 "RightTeeVector" "\226\165\155" -let _ = Hashtbl.replace macro2utf8 "LowerLeftArrow" "\226\134\153" -let _ = Hashtbl.replace macro2utf8 "utdot" "\226\139\176" -let _ = Hashtbl.replace macro2utf8 "homtht" "\226\136\187" -let _ = Hashtbl.replace macro2utf8 "ddotseq" "\226\169\183" -let _ = Hashtbl.replace macro2utf8 "bowtie" "\226\139\136" -let _ = Hashtbl.replace macro2utf8 "succnsim" "\226\139\169" -let _ = Hashtbl.replace macro2utf8 "boxDl" "\226\149\150" -let _ = Hashtbl.replace macro2utf8 "quot" "\"" -let _ = Hashtbl.replace macro2utf8 "lvnE" "\226\137\168\239\184\128" -let _ = Hashtbl.replace macro2utf8 "CircleDot" "\226\138\153" -let _ = Hashtbl.replace macro2utf8 "lsime" "\226\170\141" -let _ = Hashtbl.replace macro2utf8 "Yacute" "\195\157" -let _ = Hashtbl.replace macro2utf8 "esdot" "\226\137\144" -let _ = Hashtbl.replace macro2utf8 "Supset" "\226\139\145" -let _ = Hashtbl.replace macro2utf8 "lsimg" "\226\170\143" -let _ = Hashtbl.replace macro2utf8 "eDot" "\226\137\145" -let _ = Hashtbl.replace macro2utf8 "sec" "sec" -let _ = Hashtbl.replace macro2utf8 "boxDr" "\226\149\147" -let _ = Hashtbl.replace macro2utf8 "plus" "+" -let _ = Hashtbl.replace macro2utf8 "ddagger" "\226\128\161" -let _ = Hashtbl.replace macro2utf8 "Vdashl" "\226\171\166" -let _ = Hashtbl.replace macro2utf8 "equest" "\226\137\159" -let _ = Hashtbl.replace macro2utf8 "quest" "?" -let _ = Hashtbl.replace macro2utf8 "divideontimes" "\226\139\135" -let _ = Hashtbl.replace macro2utf8 "nsmid" "\226\136\164\239\184\128" -let _ = Hashtbl.replace macro2utf8 "fnof" "\198\146" -let _ = Hashtbl.replace macro2utf8 "bumpe" "\226\137\143" -let _ = Hashtbl.replace macro2utf8 "lhblk" "\226\150\132" -let _ = Hashtbl.replace macro2utf8 "prnap" "\226\139\168" -let _ = Hashtbl.replace macro2utf8 "compfn" "\226\136\152" -let _ = Hashtbl.replace macro2utf8 "nsucceq" "\226\170\176\204\184" -let _ = Hashtbl.replace macro2utf8 "RightArrowLeftArrow" "\226\135\132" -let _ = Hashtbl.replace macro2utf8 "sharp" "\226\153\175" -let _ = Hashtbl.replace macro2utf8 "CHcy" "\208\167" -let _ = Hashtbl.replace macro2utf8 "dwangle" "\226\166\166" -let _ = Hashtbl.replace macro2utf8 "angrtvbd" "\226\166\157" -let _ = Hashtbl.replace macro2utf8 "period" "." -let _ = Hashtbl.replace macro2utf8 "phone" "\226\152\142" -let _ = Hashtbl.replace macro2utf8 "Eacute" "\195\137" -let _ = Hashtbl.replace macro2utf8 "dzigrarr" "\239\150\162" -let _ = Hashtbl.replace macro2utf8 "Ll" "\226\139\152" -let _ = Hashtbl.replace macro2utf8 "succapprox" "\226\137\191" -let _ = Hashtbl.replace macro2utf8 "rarrfs" "\226\164\158" -let _ = Hashtbl.replace macro2utf8 "dbkarow" "\226\164\143" -let _ = Hashtbl.replace macro2utf8 "zeta" "\206\182" -let _ = Hashtbl.replace macro2utf8 "Lt" "\226\137\170" -let _ = Hashtbl.replace macro2utf8 "triminus" "\226\168\186" -let _ = Hashtbl.replace macro2utf8 "odiv" "\226\168\184" -let _ = Hashtbl.replace macro2utf8 "ltrie" "\226\138\180" -let _ = Hashtbl.replace macro2utf8 "Dagger" "\226\128\161" -let _ = Hashtbl.replace macro2utf8 "ltrif" "\226\151\130" -let _ = Hashtbl.replace macro2utf8 "boxHD" "\226\149\166" -let _ = Hashtbl.replace macro2utf8 "timesb" "\226\138\160" -let _ = Hashtbl.replace macro2utf8 "check" "\226\156\147" -let _ = Hashtbl.replace macro2utf8 "urcorn" "\226\140\157" -let _ = Hashtbl.replace macro2utf8 "timesd" "\226\168\176" -let _ = Hashtbl.replace macro2utf8 "tshcy" "\209\155" -let _ = Hashtbl.replace macro2utf8 "sfr" "\240\157\148\176" -let _ = Hashtbl.replace macro2utf8 "lmoust" "\226\142\176" -let _ = Hashtbl.replace macro2utf8 "ruluhar" "\226\165\168" -let _ = Hashtbl.replace macro2utf8 "bne" "=\226\131\165" -let _ = Hashtbl.replace macro2utf8 "prod" "\226\136\143" -let _ = Hashtbl.replace macro2utf8 "Eopf" "\240\157\148\188" -let _ = Hashtbl.replace macro2utf8 "scsim" "\226\137\191" -let _ = Hashtbl.replace macro2utf8 "GreaterEqualLess" "\226\139\155" -let _ = Hashtbl.replace macro2utf8 "Igrave" "\195\140" -let _ = Hashtbl.replace macro2utf8 "Longrightarrow" "\226\135\146" -let _ = Hashtbl.replace macro2utf8 "bigcap" "\226\139\130" -let _ = Hashtbl.replace macro2utf8 "boxHU" "\226\149\169" -let _ = Hashtbl.replace macro2utf8 "uring" "\197\175" -let _ = Hashtbl.replace macro2utf8 "equivDD" "\226\169\184" -let _ = Hashtbl.replace macro2utf8 "prop" "\226\136\157" -let _ = Hashtbl.replace macro2utf8 "Lopf" "\240\157\149\131" -let _ = Hashtbl.replace macro2utf8 "ldrushar" "\226\165\139" -let _ = Hashtbl.replace macro2utf8 "rarrhk" "\226\134\170" -let _ = Hashtbl.replace macro2utf8 "Leftarrow" "\226\135\144" -let _ = Hashtbl.replace macro2utf8 "lltri" "\226\151\186" -let _ = Hashtbl.replace macro2utf8 "NestedGreaterGreater" "\226\137\171" -let _ = Hashtbl.replace macro2utf8 "GreaterFullEqual" "\226\137\167" -let _ = Hashtbl.replace macro2utf8 "robrk" "\227\128\155" -let _ = Hashtbl.replace macro2utf8 "larrsim" "\226\165\179" -let _ = Hashtbl.replace macro2utf8 "boxHd" "\226\149\164" -let _ = Hashtbl.replace macro2utf8 "vDash" "\226\138\168" -let _ = Hashtbl.replace macro2utf8 "hfr" "\240\157\148\165" -let _ = Hashtbl.replace macro2utf8 "Edot" "\196\150" -let _ = Hashtbl.replace macro2utf8 "Vvdash" "\226\138\170" -let _ = Hashtbl.replace macro2utf8 "Sopf" "\240\157\149\138" -let _ = Hashtbl.replace macro2utf8 "upuparrows" "\226\135\136" -let _ = Hashtbl.replace macro2utf8 "RightUpTeeVector" "\226\165\156" -let _ = Hashtbl.replace macro2utf8 "DownLeftVector" "\226\134\189" -let _ = Hashtbl.replace macro2utf8 "xhArr" "\239\149\187" -let _ = Hashtbl.replace macro2utf8 "triplus" "\226\168\185" -let _ = Hashtbl.replace macro2utf8 "bot" "\226\138\165" -let _ = Hashtbl.replace macro2utf8 "Rcy" "\208\160" -let _ = Hashtbl.replace macro2utf8 "eDDot" "\226\169\183" -let _ = Hashtbl.replace macro2utf8 "subseteqq" "\226\138\134" -let _ = Hashtbl.replace macro2utf8 "cirfnint" "\226\168\144" -let _ = Hashtbl.replace macro2utf8 "spadesuit" "\226\153\160" -let _ = Hashtbl.replace macro2utf8 "nacute" "\197\132" -let _ = Hashtbl.replace macro2utf8 "Zopf" "\226\132\164" -let _ = Hashtbl.replace macro2utf8 "upharpoonleft" "\226\134\191" -let _ = Hashtbl.replace macro2utf8 "shy" "\194\173" -let _ = Hashtbl.replace macro2utf8 "nparsl" "\226\136\165\239\184\128\226\131\165" -let _ = Hashtbl.replace macro2utf8 "boxHu" "\226\149\167" -let _ = Hashtbl.replace macro2utf8 "ThickSpace" "\226\128\137\226\128\138\226\128\138" -let _ = Hashtbl.replace macro2utf8 "Or" "\226\169\148" -let _ = Hashtbl.replace macro2utf8 "raemptyv" "\226\166\179" -let _ = Hashtbl.replace macro2utf8 "Aogon" "\196\132" -let _ = Hashtbl.replace macro2utf8 "IEcy" "\208\149" -let _ = Hashtbl.replace macro2utf8 "sim" "\226\136\188" -let _ = Hashtbl.replace macro2utf8 "sin" "sin" -let _ = Hashtbl.replace macro2utf8 "copysr" "\226\132\151" -let _ = Hashtbl.replace macro2utf8 "scnap" "\226\139\169" -let _ = Hashtbl.replace macro2utf8 "rdquo" "\226\128\157" -let _ = Hashtbl.replace macro2utf8 "aopf" "\240\157\149\146" -let _ = Hashtbl.replace macro2utf8 "Pi" "\206\160" -let _ = Hashtbl.replace macro2utf8 "Udblac" "\197\176" -let _ = Hashtbl.replace macro2utf8 "expectation" "\226\132\176" -let _ = Hashtbl.replace macro2utf8 "Zacute" "\197\185" -let _ = Hashtbl.replace macro2utf8 "urtri" "\226\151\185" -let _ = Hashtbl.replace macro2utf8 "NotTildeEqual" "\226\137\132" -let _ = Hashtbl.replace macro2utf8 "ncedil" "\197\134" -let _ = Hashtbl.replace macro2utf8 "Gamma" "\206\147" -let _ = Hashtbl.replace macro2utf8 "ecirc" "\195\170" -let _ = Hashtbl.replace macro2utf8 "dsol" "\226\167\182" -let _ = Hashtbl.replace macro2utf8 "Gcy" "\208\147" -let _ = Hashtbl.replace macro2utf8 "Pr" "Pr" -let _ = Hashtbl.replace macro2utf8 "Zdot" "\197\187" -let _ = Hashtbl.replace macro2utf8 "mnplus" "\226\136\147" -let _ = Hashtbl.replace macro2utf8 "hopf" "\240\157\149\153" -let _ = Hashtbl.replace macro2utf8 "blacktriangledown" "\226\150\190" -let _ = Hashtbl.replace macro2utf8 "LeftCeiling" "\226\140\136" -let _ = Hashtbl.replace macro2utf8 "ulcorn" "\226\140\156" -let _ = Hashtbl.replace macro2utf8 "searrow" "\226\134\152" -let _ = Hashtbl.replace macro2utf8 "GreaterGreater" "\226\170\162" -let _ = Hashtbl.replace macro2utf8 "Fscr" "\226\132\177" -let _ = Hashtbl.replace macro2utf8 "cupcup" "\226\169\138" -let _ = Hashtbl.replace macro2utf8 "NotEqual" "\226\137\160" -let _ = Hashtbl.replace macro2utf8 "sext" "\226\156\182" -let _ = Hashtbl.replace macro2utf8 "CirclePlus" "\226\138\149" -let _ = Hashtbl.replace macro2utf8 "erarr" "\226\165\177" -let _ = Hashtbl.replace macro2utf8 "dArr" "\226\135\147" -let _ = Hashtbl.replace macro2utf8 "PrecedesSlantEqual" "\226\137\188" -let _ = Hashtbl.replace macro2utf8 "Itilde" "\196\168" -let _ = Hashtbl.replace macro2utf8 "gesdoto" "\226\170\130" -let _ = Hashtbl.replace macro2utf8 "Rang" "\227\128\139" -let _ = Hashtbl.replace macro2utf8 "nwarhk" "\226\164\163" -let _ = Hashtbl.replace macro2utf8 "minusdu" "\226\168\170" -let _ = Hashtbl.replace macro2utf8 "oopf" "\240\157\149\160" -let _ = Hashtbl.replace macro2utf8 "Mscr" "\226\132\179" -let _ = Hashtbl.replace macro2utf8 "Rfr" "\226\132\156" -let _ = Hashtbl.replace macro2utf8 "langle" "\226\140\169" -let _ = Hashtbl.replace macro2utf8 "And" "\226\169\147" -let _ = Hashtbl.replace macro2utf8 "bprime" "\226\128\181" -let _ = Hashtbl.replace macro2utf8 "nLeftrightarrow" "\226\135\142" -let _ = Hashtbl.replace macro2utf8 "Re" "\226\132\156" -let _ = Hashtbl.replace macro2utf8 "OpenCurlyQuote" "\226\128\152" -let _ = Hashtbl.replace macro2utf8 "vopf" "\240\157\149\167" -let _ = Hashtbl.replace macro2utf8 "ulcorner" "\226\140\156" -let _ = Hashtbl.replace macro2utf8 "nap" "\226\137\137" -let _ = Hashtbl.replace macro2utf8 "Tscr" "\240\157\146\175" -let _ = Hashtbl.replace macro2utf8 "gtreqless" "\226\139\155" -let _ = Hashtbl.replace macro2utf8 "rarrlp" "\226\134\172" -let _ = Hashtbl.replace macro2utf8 "Lambda" "\206\155" -let _ = Hashtbl.replace macro2utf8 "lobrk" "\227\128\154" -let _ = Hashtbl.replace macro2utf8 "rbrace" "}" -let _ = Hashtbl.replace macro2utf8 "rArr" "\226\135\146" -let _ = Hashtbl.replace macro2utf8 "coloneq" "\226\137\148" -let _ = Hashtbl.replace macro2utf8 "UpArrow" "\226\134\145" -let _ = Hashtbl.replace macro2utf8 "odot" "\226\138\153" -let _ = Hashtbl.replace macro2utf8 "LeftDownTeeVector" "\226\165\161" -let _ = Hashtbl.replace macro2utf8 "complexes" "\226\132\130" -let _ = Hashtbl.replace macro2utf8 "rbrack" "]" -let _ = Hashtbl.replace macro2utf8 "DownTeeArrow" "\226\134\167" -let _ = Hashtbl.replace macro2utf8 "sqcap" "\226\138\147" -let _ = Hashtbl.replace macro2utf8 "Sc" "\226\170\188" -let _ = Hashtbl.replace macro2utf8 "ycy" "\209\139" -let _ = Hashtbl.replace macro2utf8 "Prime" "\226\128\179" -let _ = Hashtbl.replace macro2utf8 "Gfr" "\240\157\148\138" -let _ = Hashtbl.replace macro2utf8 "trianglerighteq" "\226\138\181" -let _ = Hashtbl.replace macro2utf8 "rangd" "\226\166\146" -let _ = Hashtbl.replace macro2utf8 "gtrdot" "\226\139\151" -let _ = Hashtbl.replace macro2utf8 "range" "\226\166\165" -let _ = Hashtbl.replace macro2utf8 "rsqb" "]" -let _ = Hashtbl.replace macro2utf8 "Euml" "\195\139" -let _ = Hashtbl.replace macro2utf8 "Therefore" "\226\136\180" -let _ = Hashtbl.replace macro2utf8 "nesim" "\226\137\130\204\184" -let _ = Hashtbl.replace macro2utf8 "order" "\226\132\180" -let _ = Hashtbl.replace macro2utf8 "vsupnE" "\226\138\139\239\184\128" -let _ = Hashtbl.replace macro2utf8 "awconint" "\226\136\179" -let _ = Hashtbl.replace macro2utf8 "bscr" "\240\157\146\183" -let _ = Hashtbl.replace macro2utf8 "lesseqqgtr" "\226\139\154" -let _ = Hashtbl.replace macro2utf8 "cap" "\226\136\169" -let _ = Hashtbl.replace macro2utf8 "ldquo" "\226\128\156" -let _ = Hashtbl.replace macro2utf8 "nsubseteq" "\226\138\136" -let _ = Hashtbl.replace macro2utf8 "rhov" "\207\177" -let _ = Hashtbl.replace macro2utf8 "xvee" "\226\139\129" -let _ = Hashtbl.replace macro2utf8 "olarr" "\226\134\186" -let _ = Hashtbl.replace macro2utf8 "nang" "\226\136\160\204\184" -let _ = Hashtbl.replace macro2utf8 "uwangle" "\226\166\167" -let _ = Hashtbl.replace macro2utf8 "nlsim" "\226\137\180" -let _ = Hashtbl.replace macro2utf8 "smt" "\226\170\170" -let _ = Hashtbl.replace macro2utf8 "nVdash" "\226\138\174" -let _ = Hashtbl.replace macro2utf8 "napE" "\226\169\176\204\184" -let _ = Hashtbl.replace macro2utf8 "ngeq" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "iscr" "\240\157\146\190" -let _ = Hashtbl.replace macro2utf8 "GJcy" "\208\131" -let _ = Hashtbl.replace macro2utf8 "nges" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "exist" "\226\136\131" -let _ = Hashtbl.replace macro2utf8 "cent" "\194\162" -let _ = Hashtbl.replace macro2utf8 "oacute" "\195\179" -let _ = Hashtbl.replace macro2utf8 "Darr" "\226\134\161" -let _ = Hashtbl.replace macro2utf8 "yen" "\194\165" -let _ = Hashtbl.replace macro2utf8 "bigcirc" "\226\151\175" -let _ = Hashtbl.replace macro2utf8 "ncy" "\208\189" -let _ = Hashtbl.replace macro2utf8 "midast" "*" -let _ = Hashtbl.replace macro2utf8 "UpperRightArrow" "\226\134\151" -let _ = Hashtbl.replace macro2utf8 "precnapprox" "\226\139\168" -let _ = Hashtbl.replace macro2utf8 "OElig" "\197\146" -let _ = Hashtbl.replace macro2utf8 "hybull" "\226\129\131" -let _ = Hashtbl.replace macro2utf8 "cupbrcap" "\226\169\136" -let _ = Hashtbl.replace macro2utf8 "rationals" "\226\132\154" -let _ = Hashtbl.replace macro2utf8 "VerticalTilde" "\226\137\128" -let _ = Hashtbl.replace macro2utf8 "pscr" "\240\157\147\133" -let _ = Hashtbl.replace macro2utf8 "NJcy" "\208\138" -let _ = Hashtbl.replace macro2utf8 "NotSucceedsTilde" "\226\137\191\204\184" -let _ = Hashtbl.replace macro2utf8 "vsupne" "\226\138\139\239\184\128" -let _ = Hashtbl.replace macro2utf8 "Updownarrow" "\226\135\149" -let _ = Hashtbl.replace macro2utf8 "Lsh" "\226\134\176" -let _ = Hashtbl.replace macro2utf8 "rAarr" "\226\135\155" -let _ = Hashtbl.replace macro2utf8 "precapprox" "\226\137\190" -let _ = Hashtbl.replace macro2utf8 "rsquor" "\226\128\153" -let _ = Hashtbl.replace macro2utf8 "pound" "\194\163" -let _ = Hashtbl.replace macro2utf8 "lbrksld" "\226\166\143" -let _ = Hashtbl.replace macro2utf8 "gesdot" "\226\170\128" -let _ = Hashtbl.replace macro2utf8 "Element" "\226\136\136" -let _ = Hashtbl.replace macro2utf8 "xcirc" "\226\151\175" -let _ = Hashtbl.replace macro2utf8 "wscr" "\240\157\147\140" -let _ = Hashtbl.replace macro2utf8 "toea" "\226\164\168" -let _ = Hashtbl.replace macro2utf8 "setmn" "\226\136\150" -let _ = Hashtbl.replace macro2utf8 "neg" "\194\172" -let _ = Hashtbl.replace macro2utf8 "sol" "/" -let _ = Hashtbl.replace macro2utf8 "yfr" "\240\157\148\182" -let _ = Hashtbl.replace macro2utf8 "DoubleDownArrow" "\226\135\147" -let _ = Hashtbl.replace macro2utf8 "Rarr" "\226\134\160" -let _ = Hashtbl.replace macro2utf8 "ngE" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "Upsi" "\207\146" -let _ = Hashtbl.replace macro2utf8 "opar" "\226\166\183" -let _ = Hashtbl.replace macro2utf8 "rarrpl" "\226\165\133" -let _ = Hashtbl.replace macro2utf8 "auml" "\195\164" -let _ = Hashtbl.replace macro2utf8 "bmod" "mod" -let _ = Hashtbl.replace macro2utf8 "SquareSuperset" "\226\138\144" -let _ = Hashtbl.replace macro2utf8 "neq" "\226\137\160" -let _ = Hashtbl.replace macro2utf8 "circleddash" "\226\138\157" -let _ = Hashtbl.replace macro2utf8 "xrarr" "\239\149\183" -let _ = Hashtbl.replace macro2utf8 "barwed" "\226\138\188" -let _ = Hashtbl.replace macro2utf8 "lbrkslu" "\226\166\141" -let _ = Hashtbl.replace macro2utf8 "planckh" "\226\132\142" -let _ = Hashtbl.replace macro2utf8 "ldrdhar" "\226\165\167" -let _ = Hashtbl.replace macro2utf8 "circledcirc" "\226\138\154" -let _ = Hashtbl.replace macro2utf8 "ctdot" "\226\139\175" -let _ = Hashtbl.replace macro2utf8 "fallingdotseq" "\226\137\146" -let _ = Hashtbl.replace macro2utf8 "Map" "\226\164\133" -let _ = Hashtbl.replace macro2utf8 "VerticalBar" "\226\136\163" -let _ = Hashtbl.replace macro2utf8 "succeq" "\226\137\189" -let _ = Hashtbl.replace macro2utf8 "tint" "\226\136\173" -let _ = Hashtbl.replace macro2utf8 "imof" "\226\138\183" -let _ = Hashtbl.replace macro2utf8 "diam" "\226\139\132" -let _ = Hashtbl.replace macro2utf8 "twixt" "\226\137\172" -let _ = Hashtbl.replace macro2utf8 "NoBreak" "\239\187\191" -let _ = Hashtbl.replace macro2utf8 "langd" "\226\166\145" -let _ = Hashtbl.replace macro2utf8 "Bernoullis" "\226\132\172" -let _ = Hashtbl.replace macro2utf8 "rcaron" "\197\153" -let _ = Hashtbl.replace macro2utf8 "hom" "hom" -let _ = Hashtbl.replace macro2utf8 "nfr" "\240\157\148\171" -let _ = Hashtbl.replace macro2utf8 "backsimeq" "\226\139\141" -let _ = Hashtbl.replace macro2utf8 "target" "\226\140\150" -let _ = Hashtbl.replace macro2utf8 "ouml" "\195\182" -let _ = Hashtbl.replace macro2utf8 "nge" "\226\137\177\226\131\165" -let _ = Hashtbl.replace macro2utf8 "LeftTriangleBar" "\226\167\143" -let _ = Hashtbl.replace macro2utf8 "subplus" "\226\170\191" -let _ = Hashtbl.replace macro2utf8 "parsim" "\226\171\179" -let _ = Hashtbl.replace macro2utf8 "Gcedil" "\196\162" -let _ = Hashtbl.replace macro2utf8 "bnequiv" "\226\137\161\226\131\165" -let _ = Hashtbl.replace macro2utf8 "ubreve" "\197\173" -let _ = Hashtbl.replace macro2utf8 "iexcl" "\194\161" -let _ = Hashtbl.replace macro2utf8 "Xi" "\206\158" -let _ = Hashtbl.replace macro2utf8 "omega" "\207\137" -let _ = Hashtbl.replace macro2utf8 "elsdot" "\226\170\151" -let _ = Hashtbl.replace macro2utf8 "propto" "\226\136\157" -let _ = Hashtbl.replace macro2utf8 "squ" "\226\150\161" -let _ = Hashtbl.replace macro2utf8 "Ycirc" "\197\182" -let _ = Hashtbl.replace macro2utf8 "amacr" "\196\129" -let _ = Hashtbl.replace macro2utf8 "curlyeqprec" "\226\139\158" -let _ = Hashtbl.replace macro2utf8 "ngt" "\226\137\175" -let _ = Hashtbl.replace macro2utf8 "plusdo" "\226\136\148" -let _ = Hashtbl.replace macro2utf8 "ngeqslant" "\226\137\177" -let _ = Hashtbl.replace macro2utf8 "LongRightArrow" "\239\149\183" -let _ = Hashtbl.replace macro2utf8 "LeftUpVector" "\226\134\191" -let _ = Hashtbl.replace macro2utf8 "asymp" "\226\137\141" -let _ = Hashtbl.replace macro2utf8 "imped" "\240\157\149\131" -let _ = Hashtbl.replace macro2utf8 "tritime" "\226\168\187" -let _ = Hashtbl.replace macro2utf8 "rpargt" "\226\166\148" -let _ = Hashtbl.replace macro2utf8 "DDotrahd" "\226\164\145" -let _ = Hashtbl.replace macro2utf8 "prnsim" "\226\139\168" -let _ = Hashtbl.replace macro2utf8 "plusdu" "\226\168\165" -let _ = Hashtbl.replace macro2utf8 "cfr" "\240\157\148\160" -let _ = Hashtbl.replace macro2utf8 "abreve" "\196\131" -let _ = Hashtbl.replace macro2utf8 "suphsol" "\226\138\131/" -let _ = Hashtbl.replace macro2utf8 "NegativeThickSpace" "\226\128\133\239\184\128" -let _ = Hashtbl.replace macro2utf8 "Mcy" "\208\156" -let _ = Hashtbl.replace macro2utf8 "uarr" "\226\134\145" -let _ = Hashtbl.replace macro2utf8 "LeftRightVector" "\226\165\142" -let _ = Hashtbl.replace macro2utf8 "lAarr" "\226\135\154" -let _ = Hashtbl.replace macro2utf8 "bsim" "\226\136\189" -let _ = Hashtbl.replace macro2utf8 "simrarr" "\226\165\178" -let _ = Hashtbl.replace macro2utf8 "otimes" "\226\138\151" -let _ = Hashtbl.replace macro2utf8 "NotSucceeds" "\226\138\129" -let _ = Hashtbl.replace macro2utf8 "Cross" "\226\168\175" -let _ = Hashtbl.replace macro2utf8 "downarrow" "\226\134\147" -let _ = Hashtbl.replace macro2utf8 "blacktriangle" "\226\150\180" -let _ = Hashtbl.replace macro2utf8 "TripleDot" "\226\131\155" -let _ = Hashtbl.replace macro2utf8 "smallsetminus" "\226\136\150\239\184\128" -let _ = Hashtbl.replace macro2utf8 "supedot" "\226\171\132" -let _ = Hashtbl.replace macro2utf8 "NotPrecedesSlantEqual" "\226\139\160" -let _ = Hashtbl.replace macro2utf8 "neArr" "\226\135\151" -let _ = Hashtbl.replace macro2utf8 "rarrtl" "\226\134\163" -let _ = Hashtbl.replace macro2utf8 "isin" "\226\136\136" -let _ = Hashtbl.replace macro2utf8 "rrarr" "\226\135\137" -let _ = Hashtbl.replace macro2utf8 "Upsilon" "\207\146" -let _ = Hashtbl.replace macro2utf8 "sqsub" "\226\138\143" -let _ = Hashtbl.replace macro2utf8 "boxUL" "\226\149\157" -let _ = Hashtbl.replace macro2utf8 "LessTilde" "\226\137\178" -let _ = Hashtbl.replace macro2utf8 "Xfr" "\240\157\148\155" -let _ = Hashtbl.replace macro2utf8 "nis" "\226\139\188" -let _ = Hashtbl.replace macro2utf8 "chi" "\207\135" -let _ = Hashtbl.replace macro2utf8 "DownRightVector" "\226\135\129" -let _ = Hashtbl.replace macro2utf8 "niv" "\226\136\139" -let _ = Hashtbl.replace macro2utf8 "boxUR" "\226\149\154" -let _ = Hashtbl.replace macro2utf8 "nlArr" "\226\135\141" -let _ = Hashtbl.replace macro2utf8 "Bcy" "\208\145" -let _ = Hashtbl.replace macro2utf8 "tan" "tan" -let _ = Hashtbl.replace macro2utf8 "EmptyVerySmallSquare" "\239\150\156" -let _ = Hashtbl.replace macro2utf8 "dstrok" "\196\145" -let _ = Hashtbl.replace macro2utf8 "rfisht" "\226\165\189" -let _ = Hashtbl.replace macro2utf8 "easter" "\226\137\155" -let _ = Hashtbl.replace macro2utf8 "nlE" "\226\137\176" -let _ = Hashtbl.replace macro2utf8 "Mellintrf" "\226\132\179" -let _ = Hashtbl.replace macro2utf8 "lotimes" "\226\168\180" -let _ = Hashtbl.replace macro2utf8 "sqsup" "\226\138\144" -let _ = Hashtbl.replace macro2utf8 "boxVH" "\226\149\172" -let _ = Hashtbl.replace macro2utf8 "bbrk" "\226\142\181" -let _ = Hashtbl.replace macro2utf8 "tau" "\207\132" -let _ = Hashtbl.replace macro2utf8 "UpTee" "\226\138\165" -let _ = Hashtbl.replace macro2utf8 "NotLeftTriangleBar" "\226\167\143\204\184" -let _ = Hashtbl.replace macro2utf8 "boxVL" "\226\149\163" -let _ = Hashtbl.replace macro2utf8 "Proportion" "\226\136\183" -let _ = Hashtbl.replace macro2utf8 "equiv" "\226\137\161" -let _ = Hashtbl.replace macro2utf8 "blk12" "\226\150\146" -let _ = Hashtbl.replace macro2utf8 "blk14" "\226\150\145" -let _ = Hashtbl.replace macro2utf8 "fpartint" "\226\168\141" -let _ = Hashtbl.replace macro2utf8 "boxVR" "\226\149\160" -let _ = Hashtbl.replace macro2utf8 "starf" "\226\152\133" -let _ = Hashtbl.replace macro2utf8 "risingdotseq" "\226\137\147" -let _ = Hashtbl.replace macro2utf8 "Equilibrium" "\226\135\140" -let _ = Hashtbl.replace macro2utf8 "ijlig" "\196\179" -let _ = Hashtbl.replace macro2utf8 "yicy" "\209\151" -let _ = Hashtbl.replace macro2utf8 "sum" "\226\136\145" -let _ = Hashtbl.replace macro2utf8 "cir" "\226\151\139" -let _ = Hashtbl.replace macro2utf8 "telrec" "\226\140\149" -let _ = Hashtbl.replace macro2utf8 "Mfr" "\240\157\148\144" -let _ = Hashtbl.replace macro2utf8 "dHar" "\226\165\165" -let _ = Hashtbl.replace macro2utf8 "boxUl" "\226\149\156" -let _ = Hashtbl.replace macro2utf8 "apid" "\226\137\139" -let _ = Hashtbl.replace macro2utf8 "nleftarrow" "\226\134\154" -let _ = Hashtbl.replace macro2utf8 "curarrm" "\226\164\188" -let _ = Hashtbl.replace macro2utf8 "Scirc" "\197\156" -let _ = Hashtbl.replace macro2utf8 "Copf" "\226\132\130" -let _ = Hashtbl.replace macro2utf8 "RightTriangleEqual" "\226\138\181" -let _ = Hashtbl.replace macro2utf8 "boxUr" "\226\149\153" -let _ = Hashtbl.replace macro2utf8 "loplus" "\226\168\173" -let _ = Hashtbl.replace macro2utf8 "varsupsetneq" "\226\138\139\239\184\128" -let _ = Hashtbl.replace macro2utf8 "scaron" "\197\161" -let _ = Hashtbl.replace macro2utf8 "Diamond" "\226\139\132" -let _ = Hashtbl.replace macro2utf8 "lowast" "\226\136\151" -let _ = Hashtbl.replace macro2utf8 "nle" "\226\137\176\226\131\165" -let _ = Hashtbl.replace macro2utf8 "phiv" "\207\149" -let _ = Hashtbl.replace macro2utf8 "gesdotol" "\226\170\132" -let _ = Hashtbl.replace macro2utf8 "boxVh" "\226\149\171" -let _ = Hashtbl.replace macro2utf8 "nleftrightarrow" "\226\134\174" -let _ = Hashtbl.replace macro2utf8 "Jopf" "\240\157\149\129" -let _ = Hashtbl.replace macro2utf8 "boxVl" "\226\149\162" -let _ = Hashtbl.replace macro2utf8 "nearhk" "\226\164\164" -let _ = Hashtbl.replace macro2utf8 "vBarv" "\226\171\169" -let _ = Hashtbl.replace macro2utf8 "rHar" "\226\165\164" -let _ = Hashtbl.replace macro2utf8 "boxVr" "\226\149\159" -let _ = Hashtbl.replace macro2utf8 "lessdot" "\226\139\150" -let _ = Hashtbl.replace macro2utf8 "LeftDoubleBracket" "\227\128\154" -let _ = Hashtbl.replace macro2utf8 "Delta" "\206\148" -let _ = Hashtbl.replace macro2utf8 "limsup" "limsup" -let _ = Hashtbl.replace macro2utf8 "tcy" "\209\130" -let _ = Hashtbl.replace macro2utf8 "nlt" "\226\137\174" -let _ = Hashtbl.replace macro2utf8 "Cdot" "\196\138" -let _ = Hashtbl.replace macro2utf8 "blk34" "\226\150\147" -let _ = Hashtbl.replace macro2utf8 "Bfr" "\240\157\148\133" -let _ = Hashtbl.replace macro2utf8 "lowbar" "_" -let _ = Hashtbl.replace macro2utf8 "lneqq" "\226\137\168" -let _ = Hashtbl.replace macro2utf8 "TildeEqual" "\226\137\131" -let _ = Hashtbl.replace macro2utf8 "shortmid" "\226\136\163\239\184\128" -let _ = Hashtbl.replace macro2utf8 "Qopf" "\226\132\154" -let _ = Hashtbl.replace macro2utf8 "drcorn" "\226\140\159" -let _ = Hashtbl.replace macro2utf8 "ZeroWidthSpace" "\226\128\139" -let _ = Hashtbl.replace macro2utf8 "aogon" "\196\133" -let _ = Hashtbl.replace macro2utf8 "Rsh" "\226\134\177" -let _ = Hashtbl.replace macro2utf8 "lrarr" "\226\135\134" -let _ = Hashtbl.replace macro2utf8 "cupdot" "\226\138\141" -let _ = Hashtbl.replace macro2utf8 "Xopf" "\240\157\149\143" -let _ = Hashtbl.replace macro2utf8 "Backslash" "\226\136\150" -let _ = Hashtbl.replace macro2utf8 "Union" "\226\139\131" -let _ = Hashtbl.replace macro2utf8 "ratio" "\226\136\182" -let _ = Hashtbl.replace macro2utf8 "duarr" "\226\135\181" -let _ = Hashtbl.replace macro2utf8 "lates" "\226\170\173\239\184\128" -let _ = Hashtbl.replace macro2utf8 "suphsub" "\226\171\151" -let _ = Hashtbl.replace macro2utf8 "squf" "\226\150\170" -let _ = Hashtbl.replace macro2utf8 "gamma" "\206\179" -let _ = Hashtbl.replace macro2utf8 "lrhard" "\226\165\173" -let _ = Hashtbl.replace macro2utf8 "intprod" "\226\168\188" -let _ = Hashtbl.replace macro2utf8 "ReverseUpEquilibrium" "\226\165\175" -let _ = Hashtbl.replace macro2utf8 "icy" "\208\184" -let _ = Hashtbl.replace macro2utf8 "quatint" "\226\168\150" -let _ = Hashtbl.replace macro2utf8 "nbump" "\226\137\142\204\184" -let _ = Hashtbl.replace macro2utf8 "downharpoonleft" "\226\135\131" -let _ = Hashtbl.replace macro2utf8 "otimesas" "\226\168\182" -let _ = Hashtbl.replace macro2utf8 "nvHarr" "\226\135\142" -let _ = Hashtbl.replace macro2utf8 "ContourIntegral" "\226\136\174" -let _ = Hashtbl.replace macro2utf8 "bsol" "\\" -let _ = Hashtbl.replace macro2utf8 "DoubleUpDownArrow" "\226\135\149" -let _ = Hashtbl.replace macro2utf8 "disin" "\226\139\178" -let _ = Hashtbl.replace macro2utf8 "Breve" "\203\152" -let _ = Hashtbl.replace macro2utf8 "YAcy" "\208\175" -let _ = Hashtbl.replace macro2utf8 "precsim" "\226\137\190" -let _ = Hashtbl.replace macro2utf8 "NotGreaterGreater" "\226\137\171\204\184\239\184\128" -let _ = Hashtbl.replace macro2utf8 "fopf" "\240\157\149\151" -let _ = Hashtbl.replace macro2utf8 "SquareSupersetEqual" "\226\138\146" -let _ = Hashtbl.replace macro2utf8 "Dscr" "\240\157\146\159" -let _ = Hashtbl.replace macro2utf8 "gsime" "\226\170\142" -let _ = Hashtbl.replace macro2utf8 "PartialD" "\226\136\130" -let _ = Hashtbl.replace macro2utf8 "Umacr" "\197\170" -let _ = Hashtbl.replace macro2utf8 "tfr" "\240\157\148\177" -let _ = Hashtbl.replace macro2utf8 "cularrp" "\226\164\189" -let _ = Hashtbl.replace macro2utf8 "UnderBracket" "\226\142\181" -let _ = Hashtbl.replace macro2utf8 "ugrave" "\195\185" -let _ = Hashtbl.replace macro2utf8 "mopf" "\240\157\149\158" -let _ = Hashtbl.replace macro2utf8 "gsiml" "\226\170\144" -let _ = Hashtbl.replace macro2utf8 "iquest" "\194\191" -let _ = Hashtbl.replace macro2utf8 "nmid" "\226\136\164" -let _ = Hashtbl.replace macro2utf8 "leftarrowtail" "\226\134\162" -let _ = Hashtbl.replace macro2utf8 "not" "\194\172" -let _ = Hashtbl.replace macro2utf8 "Kscr" "\240\157\146\166" -let _ = Hashtbl.replace macro2utf8 "xsqcup" "\226\138\148" -let _ = Hashtbl.replace macro2utf8 "triangleleft" "\226\151\131" -let _ = Hashtbl.replace macro2utf8 "amalg" "\226\168\191" -let _ = Hashtbl.replace macro2utf8 "prcue" "\226\137\188" -let _ = Hashtbl.replace macro2utf8 "ac" "\226\164\143" -let _ = Hashtbl.replace macro2utf8 "nharr" "\226\134\174" -let _ = Hashtbl.replace macro2utf8 "dzcy" "\209\159" -let _ = Hashtbl.replace macro2utf8 "topf" "\240\157\149\165" -let _ = Hashtbl.replace macro2utf8 "iff" "\226\135\148" -let _ = Hashtbl.replace macro2utf8 "af" "\226\129\161" -let _ = Hashtbl.replace macro2utf8 "Uparrow" "\226\135\145" -let _ = Hashtbl.replace macro2utf8 "Iacute" "\195\141" -let _ = Hashtbl.replace macro2utf8 "Rscr" "\226\132\155" -let _ = Hashtbl.replace macro2utf8 "vrtri" "\226\138\179" -let _ = Hashtbl.replace macro2utf8 "multimap" "\226\138\184" -let _ = Hashtbl.replace macro2utf8 "Hat" "\204\130" -let _ = Hashtbl.replace macro2utf8 "rtriltri" "\226\167\142" -let _ = Hashtbl.replace macro2utf8 "npr" "\226\138\128" -let _ = Hashtbl.replace macro2utf8 "agrave" "\195\160" -let _ = Hashtbl.replace macro2utf8 "UnderBar" "\204\178" -let _ = Hashtbl.replace macro2utf8 "prime" "\226\128\178" -let _ = Hashtbl.replace macro2utf8 "plusmn" "\194\177" -let _ = Hashtbl.replace macro2utf8 "eplus" "\226\169\177" -let _ = Hashtbl.replace macro2utf8 "ap" "\226\137\136" -let _ = Hashtbl.replace macro2utf8 "dlcorn" "\226\140\158" -let _ = Hashtbl.replace macro2utf8 "backsim" "\226\136\189" -let _ = Hashtbl.replace macro2utf8 "ifr" "\240\157\148\166" -let _ = Hashtbl.replace macro2utf8 "bigcup" "\226\139\131" -let _ = Hashtbl.replace macro2utf8 "tcaron" "\197\165" -let _ = Hashtbl.replace macro2utf8 "sqcaps" "\226\138\147\239\184\128" -let _ = Hashtbl.replace macro2utf8 "equals" "=" -let _ = Hashtbl.replace macro2utf8 "curlywedge" "\226\139\143" -let _ = Hashtbl.replace macro2utf8 "Yscr" "\240\157\146\180" -let _ = Hashtbl.replace macro2utf8 "longrightarrow" "????" -let _ = Hashtbl.replace macro2utf8 "fork" "\226\139\148" -let _ = Hashtbl.replace macro2utf8 "cos" "cos" -let _ = Hashtbl.replace macro2utf8 "cot" "cot" -let _ = Hashtbl.replace macro2utf8 "ImaginaryI" "\226\133\136" -let _ = Hashtbl.replace macro2utf8 "Scy" "\208\161" -let _ = Hashtbl.replace macro2utf8 "mapsto" "\226\134\166" -let _ = Hashtbl.replace macro2utf8 "tdot" "\226\131\155" -let _ = Hashtbl.replace macro2utf8 "vellip" "\226\139\174" -let _ = Hashtbl.replace macro2utf8 "sqsupseteq" "\226\138\146" -let _ = Hashtbl.replace macro2utf8 "nvdash" "\226\138\172" -let _ = Hashtbl.replace macro2utf8 "NotSuperset" "\226\138\133" -let _ = Hashtbl.replace macro2utf8 "DoubleUpArrow" "\226\135\145" -let _ = Hashtbl.replace macro2utf8 "land" "\226\136\167" -let _ = Hashtbl.replace macro2utf8 "topfork" "\226\171\154" -let _ = Hashtbl.replace macro2utf8 "llhard" "\226\165\171" -let _ = Hashtbl.replace macro2utf8 "apos" "'" -let _ = Hashtbl.replace macro2utf8 "oslash" "\195\184" -let _ = Hashtbl.replace macro2utf8 "lang" "\226\140\169" -let _ = Hashtbl.replace macro2utf8 "bernou" "\226\132\172" -let _ = Hashtbl.replace macro2utf8 "varrho" "\207\177" -let _ = Hashtbl.replace macro2utf8 "rcub" "}" -let _ = Hashtbl.replace macro2utf8 "Cedilla" "\194\184" -let _ = Hashtbl.replace macro2utf8 "ApplyFunction" "\226\129\161" -let _ = Hashtbl.replace macro2utf8 "nsce" "\226\170\176\204\184" -let _ = Hashtbl.replace macro2utf8 "gscr" "\226\132\138" -let _ = Hashtbl.replace macro2utf8 "imagpart" "\226\132\145" -let _ = Hashtbl.replace macro2utf8 "ngtr" "\226\137\175" -let _ = Hashtbl.replace macro2utf8 "nsc" "\226\138\129" -let _ = Hashtbl.replace macro2utf8 "Barv" "\226\171\167" -let _ = Hashtbl.replace macro2utf8 "tosa" "\226\164\169" -let _ = Hashtbl.replace macro2utf8 "nwnear" "\226\164\167" -let _ = Hashtbl.replace macro2utf8 "ltlarr" "\226\165\182" -let _ = Hashtbl.replace macro2utf8 "PrecedesEqual" "\226\170\175" -let _ = Hashtbl.replace macro2utf8 "lessapprox" "\226\137\178" -let _ = Hashtbl.replace macro2utf8 "Lcaron" "\196\189" -let _ = Hashtbl.replace utf82macro "\204\130" "Hat" -let _ = Hashtbl.replace utf82macro "\t" "Tab" -let _ = Hashtbl.replace utf82macro "\203\152" "Breve" -let _ = Hashtbl.replace utf82macro "\n" "NewLine" -let _ = Hashtbl.replace utf82macro "\203\153" "dot" -let _ = Hashtbl.replace utf82macro "\203\154" "ring" -let _ = Hashtbl.replace utf82macro "\203\155" "ogon" -let _ = Hashtbl.replace utf82macro "\203\156" "tilde" -let _ = Hashtbl.replace utf82macro "\203\157" "DiacriticalDoubleAcute" -let _ = Hashtbl.replace utf82macro "\226\137\171\204\184" "nGt" -let _ = Hashtbl.replace utf82macro "\204\145" "DownBreve" -let _ = Hashtbl.replace utf82macro "csc" "csc" -let _ = Hashtbl.replace utf82macro "\239\187\191" "NoBreak" -let _ = Hashtbl.replace utf82macro "!" "excl" -let _ = Hashtbl.replace utf82macro "\"" "quot" -let _ = Hashtbl.replace utf82macro "#" "num" -let _ = Hashtbl.replace utf82macro "$" "dollar" -let _ = Hashtbl.replace utf82macro "%" "percnt" -let _ = Hashtbl.replace utf82macro "&" "amp" -let _ = Hashtbl.replace utf82macro "'" "apos" -let _ = Hashtbl.replace utf82macro "(" "lpar" -let _ = Hashtbl.replace utf82macro ")" "rpar" -let _ = Hashtbl.replace utf82macro "\226\139\155\239\184\128" "gesl" -let _ = Hashtbl.replace utf82macro "*" "ast" -let _ = Hashtbl.replace utf82macro "+" "plus" -let _ = Hashtbl.replace utf82macro "\226\167\144\204\184" "NotRightTriangleBar" -let _ = Hashtbl.replace utf82macro "," "comma" -let _ = Hashtbl.replace utf82macro "." "period" -let _ = Hashtbl.replace utf82macro "/" "sol" -let _ = Hashtbl.replace utf82macro "\204\178" "UnderBar" -let _ = Hashtbl.replace utf82macro ":" "colon" -let _ = Hashtbl.replace utf82macro ";" "semi" -let _ = Hashtbl.replace utf82macro "<" "lt" -let _ = Hashtbl.replace utf82macro "\207\128" "pi" -let _ = Hashtbl.replace utf82macro "\206\147" "Gamma" -let _ = Hashtbl.replace utf82macro "=" "equals" -let _ = Hashtbl.replace utf82macro "\207\129" "rho" -let _ = Hashtbl.replace utf82macro ">" "gt" -let _ = Hashtbl.replace utf82macro "\206\148" "Delta" -let _ = Hashtbl.replace utf82macro "\207\130" "varsigma" -let _ = Hashtbl.replace utf82macro "?" "quest" -let _ = Hashtbl.replace utf82macro "\207\131" "sigma" -let _ = Hashtbl.replace utf82macro "@" "commat" -let _ = Hashtbl.replace utf82macro "\207\132" "tau" -let _ = Hashtbl.replace utf82macro "\207\133" "upsilon" -let _ = Hashtbl.replace utf82macro "\206\152" "Theta" -let _ = Hashtbl.replace utf82macro "\207\134" "varphi" -let _ = Hashtbl.replace utf82macro "\207\135" "chi" -let _ = Hashtbl.replace utf82macro "\207\136" "psi" -let _ = Hashtbl.replace utf82macro "\206\155" "Lambda" -let _ = Hashtbl.replace utf82macro "\207\137" "omega" -let _ = Hashtbl.replace utf82macro "\206\158" "Xi" -let _ = Hashtbl.replace utf82macro "\206\160" "Pi" -let _ = Hashtbl.replace utf82macro "\206\163" "Sigma" -let _ = Hashtbl.replace utf82macro "\207\145" "vartheta" -let _ = Hashtbl.replace utf82macro "\207\146" "Upsilon" -let _ = Hashtbl.replace utf82macro "\206\166" "Phi" -let _ = Hashtbl.replace utf82macro "\208\129" "IOcy" -let _ = Hashtbl.replace utf82macro "\206\168" "Psi" -let _ = Hashtbl.replace utf82macro "\207\149" "phi" -let _ = Hashtbl.replace utf82macro "\208\130" "DJcy" -let _ = Hashtbl.replace utf82macro "\207\150" "varpi" -let _ = Hashtbl.replace utf82macro "\206\169" "Omega" -let _ = Hashtbl.replace utf82macro "\208\131" "GJcy" -let _ = Hashtbl.replace utf82macro "\208\132" "Jukcy" -let _ = Hashtbl.replace utf82macro "\208\133" "DScy" -let _ = Hashtbl.replace utf82macro "\208\134" "Iukcy" -let _ = Hashtbl.replace utf82macro "\208\135" "YIcy" -let _ = Hashtbl.replace utf82macro "\208\136" "Jsercy" -let _ = Hashtbl.replace utf82macro "\208\137" "LJcy" -let _ = Hashtbl.replace utf82macro "\207\156" "Gammad" -let _ = Hashtbl.replace utf82macro "\208\138" "NJcy" -let _ = Hashtbl.replace utf82macro "\208\139" "TSHcy" -let _ = Hashtbl.replace utf82macro "[" "lbrack" -let _ = Hashtbl.replace utf82macro "\206\177" "alpha" -let _ = Hashtbl.replace utf82macro "\208\140" "KJcy" -let _ = Hashtbl.replace utf82macro "\\" "backslash" -let _ = Hashtbl.replace utf82macro "\206\178" "beta" -let _ = Hashtbl.replace utf82macro "]" "rbrack" -let _ = Hashtbl.replace utf82macro "\206\179" "gamma" -let _ = Hashtbl.replace utf82macro "\208\142" "Ubrcy" -let _ = Hashtbl.replace utf82macro "\206\180" "delta" -let _ = Hashtbl.replace utf82macro "^" "circ" -let _ = Hashtbl.replace utf82macro "_" "lowbar" -let _ = Hashtbl.replace utf82macro "\206\181" "varepsilon" -let _ = Hashtbl.replace utf82macro "\208\143" "DZcy" -let _ = Hashtbl.replace utf82macro "\206\182" "zeta" -let _ = Hashtbl.replace utf82macro "`" "grave" -let _ = Hashtbl.replace utf82macro "\208\144" "Acy" -let _ = Hashtbl.replace utf82macro "inf" "inf" -let _ = Hashtbl.replace utf82macro "\206\183" "eta" -let _ = Hashtbl.replace utf82macro "\208\145" "Bcy" -let _ = Hashtbl.replace utf82macro "\208\146" "Vcy" -let _ = Hashtbl.replace utf82macro "\206\184" "theta" -let _ = Hashtbl.replace utf82macro "\209\128" "rcy" -let _ = Hashtbl.replace utf82macro "\226\139\172\204\184" "nvltrie" -let _ = Hashtbl.replace utf82macro "\206\185" "iota" -let _ = Hashtbl.replace utf82macro "\208\147" "Gcy" -let _ = Hashtbl.replace utf82macro "\209\129" "scy" -let _ = Hashtbl.replace utf82macro "\206\186" "kappa" -let _ = Hashtbl.replace utf82macro "\208\148" "Dcy" -let _ = Hashtbl.replace utf82macro "\209\130" "tcy" -let _ = Hashtbl.replace utf82macro "\226\164\179\204\184" "nrarrc" -let _ = Hashtbl.replace utf82macro "\206\187" "lambda" -let _ = Hashtbl.replace utf82macro "\208\149" "IEcy" -let _ = Hashtbl.replace utf82macro "\208\150" "ZHcy" -let _ = Hashtbl.replace utf82macro "\209\131" "ucy" -let _ = Hashtbl.replace utf82macro "\206\188" "mu" -let _ = Hashtbl.replace utf82macro "\208\151" "Zcy" -let _ = Hashtbl.replace utf82macro "\206\189" "nu" -let _ = Hashtbl.replace utf82macro "\209\132" "fcy" -let _ = Hashtbl.replace utf82macro "\206\190" "xi" -let _ = Hashtbl.replace utf82macro "\209\133" "khcy" -let _ = Hashtbl.replace utf82macro "\208\152" "Icy" -let _ = Hashtbl.replace utf82macro "\206\191" "o" -let _ = Hashtbl.replace utf82macro "\209\134" "tscy" -let _ = Hashtbl.replace utf82macro "\208\153" "Jcy" -let _ = Hashtbl.replace utf82macro "\208\154" "Kcy" -let _ = Hashtbl.replace utf82macro "\209\135" "chcy" -let _ = Hashtbl.replace utf82macro "\209\136" "shcy" -let _ = Hashtbl.replace utf82macro "\208\155" "Lcy" -let _ = Hashtbl.replace utf82macro "\209\137" "shchcy" -let _ = Hashtbl.replace utf82macro "\208\156" "Mcy" -let _ = Hashtbl.replace utf82macro "\208\157" "Ncy" -let _ = Hashtbl.replace utf82macro "\207\176" "varkappa" -let _ = Hashtbl.replace utf82macro "\209\138" "hardcy" -let _ = Hashtbl.replace utf82macro "\209\139" "ycy" -let _ = Hashtbl.replace utf82macro "\207\177" "varrho" -let _ = Hashtbl.replace utf82macro "\208\158" "Ocy" -let _ = Hashtbl.replace utf82macro "\209\140" "softcy" -let _ = Hashtbl.replace utf82macro "\208\159" "Pcy" -let _ = Hashtbl.replace utf82macro "\208\160" "Rcy" -let _ = Hashtbl.replace utf82macro "\209\141" "ecy" -let _ = Hashtbl.replace utf82macro "\209\142" "yucy" -let _ = Hashtbl.replace utf82macro "\208\161" "Scy" -let _ = Hashtbl.replace utf82macro "\207\181" "epsilon" -let _ = Hashtbl.replace utf82macro "\209\143" "yacy" -let _ = Hashtbl.replace utf82macro "\208\162" "Tcy" -let _ = Hashtbl.replace utf82macro "\208\163" "Ucy" -let _ = Hashtbl.replace utf82macro "\207\182" "bepsi" -let _ = Hashtbl.replace utf82macro "\209\145" "iocy" -let _ = Hashtbl.replace utf82macro "\208\164" "Fcy" -let _ = Hashtbl.replace utf82macro "\208\165" "KHcy" -let _ = Hashtbl.replace utf82macro "\209\146" "djcy" -let _ = Hashtbl.replace utf82macro "\208\166" "TScy" -let _ = Hashtbl.replace utf82macro "\209\147" "gjcy" -let _ = Hashtbl.replace utf82macro "\209\148" "jukcy" -let _ = Hashtbl.replace utf82macro "\208\167" "CHcy" -let _ = Hashtbl.replace utf82macro "????" "longmapsto" -let _ = Hashtbl.replace utf82macro "\208\168" "SHcy" -let _ = Hashtbl.replace utf82macro "\209\149" "dscy" -let _ = Hashtbl.replace utf82macro "\208\169" "SHCHcy" -let _ = Hashtbl.replace utf82macro "\209\150" "iukcy" -let _ = Hashtbl.replace utf82macro "deg" "deg" -let _ = Hashtbl.replace utf82macro "\209\151" "yicy" -let _ = Hashtbl.replace utf82macro "\208\170" "HARDcy" -let _ = Hashtbl.replace utf82macro "\208\171" "Ycy" -let _ = Hashtbl.replace utf82macro "{" "{" -let _ = Hashtbl.replace utf82macro "\209\152" "jsercy" -let _ = Hashtbl.replace utf82macro "|" "vert" -let _ = Hashtbl.replace utf82macro "\208\172" "SOFTcy" -let _ = Hashtbl.replace utf82macro "\209\153" "ljcy" -let _ = Hashtbl.replace utf82macro "liminf" "liminf" -let _ = Hashtbl.replace utf82macro "}" "}" -let _ = Hashtbl.replace utf82macro "\209\154" "njcy" -let _ = Hashtbl.replace utf82macro "\208\173" "Ecy" -let _ = Hashtbl.replace utf82macro "\208\174" "YUcy" -let _ = Hashtbl.replace utf82macro "\209\155" "tshcy" -let _ = Hashtbl.replace utf82macro "\208\175" "YAcy" -let _ = Hashtbl.replace utf82macro "\209\156" "kjcy" -let _ = Hashtbl.replace utf82macro "\208\176" "acy" -let _ = Hashtbl.replace utf82macro "\209\158" "ubrcy" -let _ = Hashtbl.replace utf82macro "\208\177" "bcy" -let _ = Hashtbl.replace utf82macro "\208\178" "vcy" -let _ = Hashtbl.replace utf82macro "\209\159" "dzcy" -let _ = Hashtbl.replace utf82macro "\208\179" "gcy" -let _ = Hashtbl.replace utf82macro "\208\180" "dcy" -let _ = Hashtbl.replace utf82macro "\208\181" "iecy" -let _ = Hashtbl.replace utf82macro "\208\182" "zhcy" -let _ = Hashtbl.replace utf82macro "det" "det" -let _ = Hashtbl.replace utf82macro "\208\183" "zcy" -let _ = Hashtbl.replace utf82macro "\208\184" "icy" -let _ = Hashtbl.replace utf82macro "\208\185" "jcy" -let _ = Hashtbl.replace utf82macro "\208\186" "kcy" -let _ = Hashtbl.replace utf82macro "\208\187" "lcy" -let _ = Hashtbl.replace utf82macro "\208\188" "mcy" -let _ = Hashtbl.replace utf82macro "\226\146\161\204\184" "NotNestedLessLess" -let _ = Hashtbl.replace utf82macro "\208\189" "ncy" -let _ = Hashtbl.replace utf82macro "\208\190" "ocy" -let _ = Hashtbl.replace utf82macro "\208\191" "pcy" -let _ = Hashtbl.replace utf82macro "\226\128\130" "ensp" -let _ = Hashtbl.replace utf82macro "\226\128\131" "emsp" -let _ = Hashtbl.replace utf82macro "\226\128\132" "emsp13" -let _ = Hashtbl.replace utf82macro "\226\128\133" "emsp14" -let _ = Hashtbl.replace utf82macro "\226\128\135" "numsp" -let _ = Hashtbl.replace utf82macro "\226\128\136" "puncsp" -let _ = Hashtbl.replace utf82macro "lg" "lg" -let _ = Hashtbl.replace utf82macro "\226\128\137" "ThinSpace" -let _ = Hashtbl.replace utf82macro "\226\128\138" "VeryThinSpace" -let _ = Hashtbl.replace utf82macro "\226\128\139" "ZeroWidthSpace" -let _ = Hashtbl.replace utf82macro "ln" "ln" -let _ = Hashtbl.replace utf82macro "\226\128\144" "hyphen" -let _ = Hashtbl.replace utf82macro "\226\128\147" "ndash" -let _ = Hashtbl.replace utf82macro "\226\128\148" "mdash" -let _ = Hashtbl.replace utf82macro "\226\129\129" "caret" -let _ = Hashtbl.replace utf82macro "\226\128\149" "horbar" -let _ = Hashtbl.replace utf82macro "\226\128\150" "Vert" -let _ = Hashtbl.replace utf82macro "\226\129\131" "hybull" -let _ = Hashtbl.replace utf82macro "\226\128\152" "OpenCurlyQuote" -let _ = Hashtbl.replace utf82macro "\226\128\153" "rsquor" -let _ = Hashtbl.replace utf82macro "\226\170\176\204\184" "nsucceq" -let _ = Hashtbl.replace utf82macro "\226\128\154" "lsquor" -let _ = Hashtbl.replace utf82macro "\226\128\156" "OpenCurlyDoubleQuote" -let _ = Hashtbl.replace utf82macro "\226\128\157" "rdquor" -let _ = Hashtbl.replace utf82macro "\226\128\158" "ldquor" -let _ = Hashtbl.replace utf82macro "\226\128\160" "dagger" -let _ = Hashtbl.replace utf82macro "\226\128\161" "ddagger" -let _ = Hashtbl.replace utf82macro "\226\136\133\239\184\128" "emptyset" -let _ = Hashtbl.replace utf82macro "\226\128\162" "bullet" -let _ = Hashtbl.replace utf82macro "\226\129\143" "bsemi" -let _ = Hashtbl.replace utf82macro "\226\128\165" "nldr" -let _ = Hashtbl.replace utf82macro "\226\128\166" "ldots" -let _ = Hashtbl.replace utf82macro "\226\129\151" "qprime" -let _ = Hashtbl.replace utf82macro "\226\128\176" "permil" -let _ = Hashtbl.replace utf82macro "\226\128\177" "pertenk" -let _ = Hashtbl.replace utf82macro "\226\128\178" "prime" -let _ = Hashtbl.replace utf82macro "\226\129\159" "MediumSpace" -let _ = Hashtbl.replace utf82macro "\226\128\179" "Prime" -let _ = Hashtbl.replace utf82macro "\226\128\180" "tprime" -let _ = Hashtbl.replace utf82macro "\226\129\161" "ApplyFunction" -let _ = Hashtbl.replace utf82macro "\226\129\162" "it" -let _ = Hashtbl.replace utf82macro "\226\128\181" "bprime" -let _ = Hashtbl.replace utf82macro "dim" "dim" -let _ = Hashtbl.replace utf82macro "\226\132\130" "Copf" -let _ = Hashtbl.replace utf82macro "\226\132\133" "incare" -let _ = Hashtbl.replace utf82macro "\226\131\155" "TripleDot" -let _ = Hashtbl.replace utf82macro "\226\169\173\204\184" "ncongdot" -let _ = Hashtbl.replace utf82macro "\226\131\156" "DotDot" -let _ = Hashtbl.replace utf82macro "\226\132\138" "gscr" -let _ = Hashtbl.replace utf82macro "\226\132\139" "Hscr" -let _ = Hashtbl.replace utf82macro "\226\132\140" "Poincareplane" -let _ = Hashtbl.replace utf82macro "\226\132\141" "quaternions" -let _ = Hashtbl.replace utf82macro "\226\132\142" "planckh" -let _ = Hashtbl.replace utf82macro "\226\132\143" "plankv" -let _ = Hashtbl.replace utf82macro "\226\132\144" "Iscr" -let _ = Hashtbl.replace utf82macro "\226\132\145" "Im" -let _ = Hashtbl.replace utf82macro "\226\132\146" "Lscr" -let _ = Hashtbl.replace utf82macro "\226\132\147" "ell" -let _ = Hashtbl.replace utf82macro "\226\132\149" "Nopf" -let _ = Hashtbl.replace utf82macro "\226\132\150" "numero" -let _ = Hashtbl.replace utf82macro "\226\132\151" "copysr" -let _ = Hashtbl.replace utf82macro "\226\132\152" "wp" -let _ = Hashtbl.replace utf82macro "\226\133\133" "DD" -let _ = Hashtbl.replace utf82macro "\226\132\153" "primes" -let _ = Hashtbl.replace utf82macro "\226\133\134" "DifferentialD" -let _ = Hashtbl.replace utf82macro "\226\132\154" "rationals" -let _ = Hashtbl.replace utf82macro "\226\133\135" "ExponentialE" -let _ = Hashtbl.replace utf82macro "\226\132\155" "Rscr" -let _ = Hashtbl.replace utf82macro "\226\133\136" "ImaginaryI" -let _ = Hashtbl.replace utf82macro "\226\132\156" "Re" -let _ = Hashtbl.replace utf82macro "\226\132\157" "Ropf" -let _ = Hashtbl.replace utf82macro "\226\132\158" "rx" -let _ = Hashtbl.replace utf82macro "\226\132\162" "trade" -let _ = Hashtbl.replace utf82macro "\226\132\164" "Zopf" -let _ = Hashtbl.replace utf82macro "\226\132\166" "ohm" -let _ = Hashtbl.replace utf82macro "\226\133\147" "frac13" -let _ = Hashtbl.replace utf82macro "\226\132\167" "mho" -let _ = Hashtbl.replace utf82macro "\226\133\148" "frac23" -let _ = Hashtbl.replace utf82macro "\226\132\168" "Zfr" -let _ = Hashtbl.replace utf82macro "\226\133\149" "frac15" -let _ = Hashtbl.replace utf82macro "\226\132\169" "iiota" -let _ = Hashtbl.replace utf82macro "\226\133\150" "frac25" -let _ = Hashtbl.replace utf82macro "\226\133\151" "frac35" -let _ = Hashtbl.replace utf82macro "\226\133\152" "frac45" -let _ = Hashtbl.replace utf82macro "\226\132\171" "angst" -let _ = Hashtbl.replace utf82macro "\226\133\153" "frac16" -let _ = Hashtbl.replace utf82macro "\226\132\172" "Bscr" -let _ = Hashtbl.replace utf82macro "\226\129\159\239\184\128" "NegativeMediumSpace" -let _ = Hashtbl.replace utf82macro "\226\133\154" "frac56" -let _ = Hashtbl.replace utf82macro "\226\132\173" "Cfr" -let _ = Hashtbl.replace utf82macro "\226\133\155" "frac18" -let _ = Hashtbl.replace utf82macro "\226\133\156" "frac38" -let _ = Hashtbl.replace utf82macro "\226\132\175" "escr" -let _ = Hashtbl.replace utf82macro "\226\133\157" "frac58" -let _ = Hashtbl.replace utf82macro "\226\132\176" "expectation" -let _ = Hashtbl.replace utf82macro "\226\133\158" "frac78" -let _ = Hashtbl.replace utf82macro "\226\132\177" "Fscr" -let _ = Hashtbl.replace utf82macro "\226\132\179" "phmmat" -let _ = Hashtbl.replace utf82macro "\226\132\180" "oscr" -let _ = Hashtbl.replace utf82macro "\226\132\181" "aleph" -let _ = Hashtbl.replace utf82macro "\226\134\144" "gets" -let _ = Hashtbl.replace utf82macro "\226\132\182" "beth" -let _ = Hashtbl.replace utf82macro "\226\134\145" "uparrow" -let _ = Hashtbl.replace utf82macro "\226\132\183" "gimel" -let _ = Hashtbl.replace utf82macro "\226\134\146" "to" -let _ = Hashtbl.replace utf82macro "\226\132\184" "daleth" -let _ = Hashtbl.replace utf82macro "\226\135\128" "RightVector" -let _ = Hashtbl.replace utf82macro "\226\134\147" "downarrow" -let _ = Hashtbl.replace utf82macro "\226\134\148" "leftrightarrow" -let _ = Hashtbl.replace utf82macro "\226\135\129" "rightharpoondown" -let _ = Hashtbl.replace utf82macro "\226\134\149" "updownarrow" -let _ = Hashtbl.replace utf82macro "\226\135\130" "RightDownVector" -let _ = Hashtbl.replace utf82macro "\226\134\150" "nwarrow" -let _ = Hashtbl.replace utf82macro "\226\135\131" "LeftDownVector" -let _ = Hashtbl.replace utf82macro "\226\135\132" "rlarr" -let _ = Hashtbl.replace utf82macro "\226\134\151" "nearrow" -let _ = Hashtbl.replace utf82macro "\226\135\133" "UpArrowDownArrow" -let _ = Hashtbl.replace utf82macro "\226\134\152" "searrow" -let _ = Hashtbl.replace utf82macro "\226\134\153" "swarrow" -let _ = Hashtbl.replace utf82macro "\226\135\134" "lrarr" -let _ = Hashtbl.replace utf82macro "\226\134\154" "nleftarrow" -let _ = Hashtbl.replace utf82macro "\226\135\135" "llarr" -let _ = Hashtbl.replace utf82macro "\226\135\136" "uuarr" -let _ = Hashtbl.replace utf82macro "\226\134\155" "nrightarrow" -let _ = Hashtbl.replace utf82macro "\226\135\137" "rrarr" -let _ = Hashtbl.replace utf82macro "\226\134\157" "rightsquigarrow" -let _ = Hashtbl.replace utf82macro "\226\135\138" "downdownarrows" -let _ = Hashtbl.replace utf82macro "\226\135\139" "ReverseEquilibrium" -let _ = Hashtbl.replace utf82macro "\226\134\158" "twoheadleftarrow" -let _ = Hashtbl.replace utf82macro "\226\134\159" "Uarr" -let _ = Hashtbl.replace utf82macro "\226\135\140" "rlhar" -let _ = Hashtbl.replace utf82macro "\226\134\160" "twoheadrightarrow" -let _ = Hashtbl.replace utf82macro "\226\135\141" "nvlArr" -let _ = Hashtbl.replace utf82macro "\226\135\142" "nvHarr" -let _ = Hashtbl.replace utf82macro "\226\134\161" "Darr" -let _ = Hashtbl.replace utf82macro "\226\135\143" "nvrArr" -let _ = Hashtbl.replace utf82macro "\226\134\162" "leftarrowtail" -let _ = Hashtbl.replace utf82macro "\226\134\163" "rightarrowtail" -let _ = Hashtbl.replace utf82macro "\226\135\144" "Leftarrow" -let _ = Hashtbl.replace utf82macro "\226\134\164" "mapstoleft" -let _ = Hashtbl.replace utf82macro "\226\135\145" "Uparrow" -let _ = Hashtbl.replace utf82macro "\226\134\165" "UpTeeArrow" -let _ = Hashtbl.replace utf82macro "\226\135\146" "Longrightarrow" -let _ = Hashtbl.replace utf82macro "\226\134\166" "mapsto" -let _ = Hashtbl.replace utf82macro "\226\136\128" "forall" -let _ = Hashtbl.replace utf82macro "\226\135\147" "Downarrow" -let _ = Hashtbl.replace utf82macro "\226\134\167" "mapstodown" -let _ = Hashtbl.replace utf82macro "\226\135\148" "Leftrightarrow" -let _ = Hashtbl.replace utf82macro "\226\136\129" "complement" -let _ = Hashtbl.replace utf82macro "\226\136\130" "partial" -let _ = Hashtbl.replace utf82macro "\226\135\149" "vArr" -let _ = Hashtbl.replace utf82macro "\226\135\150" "nwArr" -let _ = Hashtbl.replace utf82macro "\226\134\169" "hookleftarrow" -let _ = Hashtbl.replace utf82macro "\226\136\131" "exists" -let _ = Hashtbl.replace utf82macro "\226\136\132" "NotExists" -let _ = Hashtbl.replace utf82macro "\226\135\151" "neArr" -let _ = Hashtbl.replace utf82macro "\226\134\170" "hookrightarrow" -let _ = Hashtbl.replace utf82macro "\226\135\152" "seArr" -let _ = Hashtbl.replace utf82macro "\226\134\171" "looparrowleft" -let _ = Hashtbl.replace utf82macro "\226\136\133" "varnothing" -let _ = Hashtbl.replace utf82macro "\226\135\153" "swArr" -let _ = Hashtbl.replace utf82macro "\226\134\172" "rarrlp" -let _ = Hashtbl.replace utf82macro "\226\135\154" "Lleftarrow" -let _ = Hashtbl.replace utf82macro "\226\134\173" "leftrightsquigarrow" -let _ = Hashtbl.replace utf82macro "\226\136\135" "nabla" -let _ = Hashtbl.replace utf82macro "\226\135\155" "Rrightarrow" -let _ = Hashtbl.replace utf82macro "\226\134\174" "nleftrightarrow" -let _ = Hashtbl.replace utf82macro "\226\136\136" "in" -let _ = Hashtbl.replace utf82macro "\226\136\137" "notin" -let _ = Hashtbl.replace utf82macro "\226\135\157" "zigrarr" -let _ = Hashtbl.replace utf82macro "\226\134\176" "Lsh" -let _ = Hashtbl.replace utf82macro "\226\134\177" "Rsh" -let _ = Hashtbl.replace utf82macro "\226\136\139" "owns" -let _ = Hashtbl.replace utf82macro "\226\136\140" "NotReverseElement" -let _ = Hashtbl.replace utf82macro "\226\134\178" "ldsh" -let _ = Hashtbl.replace utf82macro "\226\134\179" "rdsh" -let _ = Hashtbl.replace utf82macro "\226\136\143" "prod" -let _ = Hashtbl.replace utf82macro "\226\134\182" "curvearrowleft" -let _ = Hashtbl.replace utf82macro "\226\136\144" "coprod" -let _ = Hashtbl.replace utf82macro "\226\136\145" "sum" -let _ = Hashtbl.replace utf82macro "\226\135\164" "LeftArrowBar" -let _ = Hashtbl.replace utf82macro "\226\134\183" "curvearrowright" -let _ = Hashtbl.replace utf82macro "\226\135\165" "RightArrowBar" -let _ = Hashtbl.replace utf82macro "\226\136\146" "minus" -let _ = Hashtbl.replace utf82macro "\226\137\128" "wr" -let _ = Hashtbl.replace utf82macro "\226\136\147" "mp" -let _ = Hashtbl.replace utf82macro "\226\137\129" "nsim" -let _ = Hashtbl.replace utf82macro "\226\136\148" "plusdo" -let _ = Hashtbl.replace utf82macro "\226\134\186" "olarr" -let _ = Hashtbl.replace utf82macro "\226\137\130" "esim" -let _ = Hashtbl.replace utf82macro "\226\134\187" "orarr" -let _ = Hashtbl.replace utf82macro "\226\137\131" "simeq" -let _ = Hashtbl.replace utf82macro "\226\134\188" "lharu" -let _ = Hashtbl.replace utf82macro "\226\136\150" "setminus" -let _ = Hashtbl.replace utf82macro "\226\137\132" "nsimeq" -let _ = Hashtbl.replace utf82macro "\226\136\151" "lowast" -let _ = Hashtbl.replace utf82macro "\226\134\189" "lhard" -let _ = Hashtbl.replace utf82macro "\226\134\190" "upharpoonright" -let _ = Hashtbl.replace utf82macro "\226\137\133" "cong" -let _ = Hashtbl.replace utf82macro "\226\136\152" "circ" -let _ = Hashtbl.replace utf82macro "\226\137\134" "simne" -let _ = Hashtbl.replace utf82macro "\226\134\191" "upharpoonleft" -let _ = Hashtbl.replace utf82macro "\226\136\154" "Sqrt" -let _ = Hashtbl.replace utf82macro "\226\137\135" "NotTildeFullEqual" -let _ = Hashtbl.replace utf82macro "\226\137\136" "approx" -let _ = Hashtbl.replace utf82macro "\226\137\137" "NotTildeTilde" -let _ = Hashtbl.replace utf82macro "\226\136\157" "propto" -let _ = Hashtbl.replace utf82macro "\226\137\138" "approxeq" -let _ = Hashtbl.replace utf82macro "\226\136\158" "infty" -let _ = Hashtbl.replace utf82macro "\226\137\139" "apid" -let _ = Hashtbl.replace utf82macro "\226\137\140" "bcong" -let _ = Hashtbl.replace utf82macro "\226\136\159" "angrt" -let _ = Hashtbl.replace utf82macro "\226\137\141" "asymp" -let _ = Hashtbl.replace utf82macro "\226\136\160" "angle" -let _ = Hashtbl.replace utf82macro "\226\137\142" "HumpDownHump" -let _ = Hashtbl.replace utf82macro "\226\136\161" "measuredangle" -let _ = Hashtbl.replace utf82macro "\226\135\181" "duarr" -let _ = Hashtbl.replace utf82macro "\226\137\143" "HumpEqual" -let _ = Hashtbl.replace utf82macro "\226\136\162" "angsph" -let _ = Hashtbl.replace utf82macro "\226\136\163" "divides" -let _ = Hashtbl.replace utf82macro "\226\137\144" "doteq" -let _ = Hashtbl.replace utf82macro "\226\136\164" "ndivides" -let _ = Hashtbl.replace utf82macro "\226\137\145" "eDot" -let _ = Hashtbl.replace utf82macro "\226\137\146" "fallingdotseq" -let _ = Hashtbl.replace utf82macro "\226\136\165" "parallel" -let _ = Hashtbl.replace utf82macro "\226\138\128" "nprec" -let _ = Hashtbl.replace utf82macro "\226\136\166" "nparallel" -let _ = Hashtbl.replace utf82macro "\226\137\147" "risingdotseq" -let _ = Hashtbl.replace utf82macro "\226\138\129" "nsucc" -let _ = Hashtbl.replace utf82macro "\226\137\148" "coloneq" -let _ = Hashtbl.replace utf82macro "\226\136\167" "land" -let _ = Hashtbl.replace utf82macro "\226\138\130" "subset" -let _ = Hashtbl.replace utf82macro "\226\136\168" "lor" -let _ = Hashtbl.replace utf82macro "\226\137\149" "eqcolon" -let _ = Hashtbl.replace utf82macro "????;" "longleftarrow" -let _ = Hashtbl.replace utf82macro "\226\138\131" "supset" -let _ = Hashtbl.replace utf82macro "\226\137\150" "eqcirc" -let _ = Hashtbl.replace utf82macro "\226\136\169" "cap" -let _ = Hashtbl.replace utf82macro "\226\138\132" "vnsub" -let _ = Hashtbl.replace utf82macro "\226\135\189" "loarr" -let _ = Hashtbl.replace utf82macro "\226\136\170" "cup" -let _ = Hashtbl.replace utf82macro "\226\137\151" "cire" -let _ = Hashtbl.replace utf82macro "\226\135\190" "roarr" -let _ = Hashtbl.replace utf82macro "\226\138\133" "vnsup" -let _ = Hashtbl.replace utf82macro "\226\136\171" "int" -let _ = Hashtbl.replace utf82macro "\226\137\153" "wedgeq" -let _ = Hashtbl.replace utf82macro "\226\138\134" "subseteq" -let _ = Hashtbl.replace utf82macro "\226\136\172" "Int" -let _ = Hashtbl.replace utf82macro "\226\135\191" "hoarr" -let _ = Hashtbl.replace utf82macro "\226\137\154" "veeeq" -let _ = Hashtbl.replace utf82macro "\226\138\135" "supseteq" -let _ = Hashtbl.replace utf82macro "\226\136\173" "tint" -let _ = Hashtbl.replace utf82macro "\226\138\136" "nsubseteqq" -let _ = Hashtbl.replace utf82macro "\226\137\155" "easter" -let _ = Hashtbl.replace utf82macro "\226\136\174" "oint" -let _ = Hashtbl.replace utf82macro "\226\137\156" "trie" -let _ = Hashtbl.replace utf82macro "\226\138\137" "nsupseteqq" -let _ = Hashtbl.replace utf82macro "\226\136\175" "DoubleContourIntegral" -let _ = Hashtbl.replace utf82macro "\226\137\157" "def" -let _ = Hashtbl.replace utf82macro "\226\138\138" "subsetneqq" -let _ = Hashtbl.replace utf82macro "\226\136\176" "Cconint" -let _ = Hashtbl.replace utf82macro "\226\138\139" "supsetneqq" -let _ = Hashtbl.replace utf82macro "\226\136\177" "cwint" -let _ = Hashtbl.replace utf82macro "\226\137\159" "questeq" -let _ = Hashtbl.replace utf82macro "\226\136\178" "cwconint" -let _ = Hashtbl.replace utf82macro "\226\137\160" "neq" -let _ = Hashtbl.replace utf82macro "\226\138\141" "cupdot" -let _ = Hashtbl.replace utf82macro "\226\136\179" "CounterClockwiseContourIntegral" -let _ = Hashtbl.replace utf82macro "\226\136\180" "Therefore" -let _ = Hashtbl.replace utf82macro "\226\137\161" "equiv" -let _ = Hashtbl.replace utf82macro "\226\138\142" "uplus" -let _ = Hashtbl.replace utf82macro "\226\138\143" "SquareSubset" -let _ = Hashtbl.replace utf82macro "\226\137\162" "NotCongruent" -let _ = Hashtbl.replace utf82macro "\226\136\181" "Because" -let _ = Hashtbl.replace utf82macro "\226\138\144" "SquareSuperset" -let _ = Hashtbl.replace utf82macro "\226\136\182" "ratio" -let _ = Hashtbl.replace utf82macro "\226\138\145" "SquareSubsetEqual" -let _ = Hashtbl.replace utf82macro "\226\137\164" "leq" -let _ = Hashtbl.replace utf82macro "\226\136\183" "Proportion" -let _ = Hashtbl.replace utf82macro "\226\138\146" "sqsupseteq" -let _ = Hashtbl.replace utf82macro "\226\137\165" "geq" -let _ = Hashtbl.replace utf82macro "\226\136\184" "minusd" -let _ = Hashtbl.replace utf82macro "\226\138\147" "sqcap" -let _ = Hashtbl.replace utf82macro "\226\137\166" "LessFullEqual" -let _ = Hashtbl.replace utf82macro "\226\139\128" "bigwedge" -let _ = Hashtbl.replace utf82macro "\226\136\186" "mDDot" -let _ = Hashtbl.replace utf82macro "\226\137\167" "GreaterFullEqual" -let _ = Hashtbl.replace utf82macro "\226\139\129" "bigvee" -let _ = Hashtbl.replace utf82macro "\226\138\148" "sqcup" -let _ = Hashtbl.replace utf82macro "\226\137\168" "lneqq" -let _ = Hashtbl.replace utf82macro "\226\136\187" "homtht" -let _ = Hashtbl.replace utf82macro "\226\138\149" "oplus" -let _ = Hashtbl.replace utf82macro "\226\139\130" "bigcap" -let _ = Hashtbl.replace utf82macro "\226\136\188" "sim" -let _ = Hashtbl.replace utf82macro "\226\137\169" "gneqq" -let _ = Hashtbl.replace utf82macro "\226\138\150" "ominus" -let _ = Hashtbl.replace utf82macro "\226\139\131" "bigcup" -let _ = Hashtbl.replace utf82macro "\226\137\170" "ll" -let _ = Hashtbl.replace utf82macro "\226\139\132" "diamond" -let _ = Hashtbl.replace utf82macro "\226\138\151" "otimes" -let _ = Hashtbl.replace utf82macro "\226\136\189" "bsim" -let _ = Hashtbl.replace utf82macro "\226\139\133" "sdot" -let _ = Hashtbl.replace utf82macro "\226\138\152" "osol" -let _ = Hashtbl.replace utf82macro "\226\136\130\204\184" "npart" -let _ = Hashtbl.replace utf82macro "\226\136\190" "mstpos" -let _ = Hashtbl.replace utf82macro "\226\137\171" "gg" -let _ = Hashtbl.replace utf82macro "\226\139\134" "star" -let _ = Hashtbl.replace utf82macro "\226\138\153" "odot" -let _ = Hashtbl.replace utf82macro "\226\137\172" "twixt" -let _ = Hashtbl.replace utf82macro "\226\136\191" "acd" -let _ = Hashtbl.replace utf82macro "\226\137\173" "NotCupCap" -let _ = Hashtbl.replace utf82macro "\226\139\135" "divonx" -let _ = Hashtbl.replace utf82macro "\226\138\154" "ocir" -let _ = Hashtbl.replace utf82macro "\226\137\174" "nvlt" -let _ = Hashtbl.replace utf82macro "\226\138\155" "oast" -let _ = Hashtbl.replace utf82macro "\226\139\136" "bowtie" -let _ = Hashtbl.replace utf82macro "\226\137\175" "nvgt" -let _ = Hashtbl.replace utf82macro "\226\139\137" "ltimes" -let _ = Hashtbl.replace utf82macro "\226\139\138" "rtimes" -let _ = Hashtbl.replace utf82macro "\226\137\176" "nleq" -let _ = Hashtbl.replace utf82macro "\226\138\157" "odash" -let _ = Hashtbl.replace utf82macro "\226\137\177" "ngeq" -let _ = Hashtbl.replace utf82macro "\226\139\139" "lthree" -let _ = Hashtbl.replace utf82macro "\226\138\158" "plusb" -let _ = Hashtbl.replace utf82macro "\226\139\140" "rthree" -let _ = Hashtbl.replace utf82macro "\226\137\178" "lsim" -let _ = Hashtbl.replace utf82macro "\226\138\159" "minusb" -let _ = Hashtbl.replace utf82macro "\226\137\179" "gtrsim" -let _ = Hashtbl.replace utf82macro "\226\138\160" "timesb" -let _ = Hashtbl.replace utf82macro "\226\139\141" "bsime" -let _ = Hashtbl.replace utf82macro "\226\137\180" "NotLessTilde" -let _ = Hashtbl.replace utf82macro "\226\138\161" "sdotb" -let _ = Hashtbl.replace utf82macro "\226\139\142" "cuvee" -let _ = Hashtbl.replace utf82macro "\226\138\162" "vdash" -let _ = Hashtbl.replace utf82macro "\226\137\181" "NotGreaterTilde" -let _ = Hashtbl.replace utf82macro "\226\139\143" "cuwed" -let _ = Hashtbl.replace utf82macro "\226\139\144" "Subset" -let _ = Hashtbl.replace utf82macro "\226\137\182" "lg" -let _ = Hashtbl.replace utf82macro "\226\138\163" "dashv" -let _ = Hashtbl.replace utf82macro "\226\139\145" "Supset" -let _ = Hashtbl.replace utf82macro "\226\137\183" "gtrless" -let _ = Hashtbl.replace utf82macro "\226\138\164" "top" -let _ = Hashtbl.replace utf82macro "\226\137\184" "ntlg" -let _ = Hashtbl.replace utf82macro "\226\139\146" "Cap" -let _ = Hashtbl.replace utf82macro "\226\138\165" "perp" -let _ = Hashtbl.replace utf82macro "\226\137\185" "ntgl" -let _ = Hashtbl.replace utf82macro "\226\139\147" "Cup" -let _ = Hashtbl.replace utf82macro "\226\137\186" "prec" -let _ = Hashtbl.replace utf82macro "\226\138\167" "models" -let _ = Hashtbl.replace utf82macro "\226\139\148" "pitchfork" -let _ = Hashtbl.replace utf82macro "\226\137\187" "succ" -let _ = Hashtbl.replace utf82macro "\226\139\149" "epar" -let _ = Hashtbl.replace utf82macro "\226\138\168" "vDash" -let _ = Hashtbl.replace utf82macro "\226\138\169" "Vdash" -let _ = Hashtbl.replace utf82macro "\226\137\188" "PrecedesSlantEqual" -let _ = Hashtbl.replace utf82macro "\226\139\150" "ltdot" -let _ = Hashtbl.replace utf82macro "\226\138\170" "Vvdash" -let _ = Hashtbl.replace utf82macro "\226\137\189" "succeq" -let _ = Hashtbl.replace utf82macro "\226\139\151" "gtrdot" -let _ = Hashtbl.replace utf82macro "\226\138\171" "VDash" -let _ = Hashtbl.replace utf82macro "\226\137\190" "scE" -let _ = Hashtbl.replace utf82macro "\226\139\152" "Ll" -let _ = Hashtbl.replace utf82macro "\226\137\191" "succsim" -let _ = Hashtbl.replace utf82macro "\226\138\172" "nvdash" -let _ = Hashtbl.replace utf82macro "\226\139\153" "ggg" -let _ = Hashtbl.replace utf82macro "\226\140\134" "doublebarwedge" -let _ = Hashtbl.replace utf82macro "\226\138\173" "nvDash" -let _ = Hashtbl.replace utf82macro "\226\139\154" "LessEqualGreater" -let _ = Hashtbl.replace utf82macro "\226\138\174" "nVdash" -let _ = Hashtbl.replace utf82macro "\226\140\136" "lceil" -let _ = Hashtbl.replace utf82macro "\226\139\155" "gtreqqless" -let _ = Hashtbl.replace utf82macro "\226\140\137" "rceil" -let _ = Hashtbl.replace utf82macro "\226\138\175" "nVDash" -let _ = Hashtbl.replace utf82macro "\226\139\156" "eqslantless" -let _ = Hashtbl.replace utf82macro "\226\138\176" "prurel" -let _ = Hashtbl.replace utf82macro "\226\140\138" "lfloor" -let _ = Hashtbl.replace utf82macro "\226\139\157" "eqslantgtr" -let _ = Hashtbl.replace utf82macro "\226\140\139" "rfloor" -let _ = Hashtbl.replace utf82macro "\226\139\158" "curlyeqprec" -let _ = Hashtbl.replace utf82macro "\226\138\178" "vltri" -let _ = Hashtbl.replace utf82macro "\226\140\140" "drcrop" -let _ = Hashtbl.replace utf82macro "\226\139\159" "curlyeqsucc" -let _ = Hashtbl.replace utf82macro "\226\138\179" "vrtri" -let _ = Hashtbl.replace utf82macro "\226\139\160" "nprcue" -let _ = Hashtbl.replace utf82macro "\226\140\141" "dlcrop" -let _ = Hashtbl.replace utf82macro "\226\140\142" "urcrop" -let _ = Hashtbl.replace utf82macro "\226\139\161" "nsccue" -let _ = Hashtbl.replace utf82macro "\226\138\180" "trianglelefteq" -let _ = Hashtbl.replace utf82macro "\226\140\143" "ulcrop" -let _ = Hashtbl.replace utf82macro "\226\138\181" "trianglerighteq" -let _ = Hashtbl.replace utf82macro "\226\134\157\204\184" "nrarrw" -let _ = Hashtbl.replace utf82macro "\226\139\162" "nsqsube" -let _ = Hashtbl.replace utf82macro "\226\138\182" "origof" -let _ = Hashtbl.replace utf82macro "\226\139\163" "nsqsupe" -let _ = Hashtbl.replace utf82macro "\226\140\144" "bnot" -let _ = Hashtbl.replace utf82macro "\226\138\183" "imof" -let _ = Hashtbl.replace utf82macro "\226\140\146" "profline" -let _ = Hashtbl.replace utf82macro "\226\138\184" "mumap" -let _ = Hashtbl.replace utf82macro "\226\140\147" "profsurf" -let _ = Hashtbl.replace utf82macro "\226\139\166" "lnsim" -let _ = Hashtbl.replace utf82macro "\226\138\185" "hercon" -let _ = Hashtbl.replace utf82macro "\226\138\186" "intercal" -let _ = Hashtbl.replace utf82macro "\226\139\167" "gnsim" -let _ = Hashtbl.replace utf82macro "\226\138\187" "veebar" -let _ = Hashtbl.replace utf82macro "\226\140\149" "telrec" -let _ = Hashtbl.replace utf82macro "\226\139\168" "prnsim" -let _ = Hashtbl.replace utf82macro "\226\140\150" "target" -let _ = Hashtbl.replace utf82macro "\226\139\169" "succnsim" -let _ = Hashtbl.replace utf82macro "\226\138\188" "barwedge" -let _ = Hashtbl.replace utf82macro "\226\139\170" "ntriangleleft" -let _ = Hashtbl.replace utf82macro "\226\138\189" "barvee" -let _ = Hashtbl.replace utf82macro "\226\138\190" "vangrt" -let _ = Hashtbl.replace utf82macro "\226\139\171" "ntriangleright" -let _ = Hashtbl.replace utf82macro "\226\139\172" "ntrianglelefteq" -let _ = Hashtbl.replace utf82macro "\226\138\191" "lrtri" -let _ = Hashtbl.replace utf82macro "\226\139\173" "ntrianglerighteq" -let _ = Hashtbl.replace utf82macro "\226\139\174" "vdots" -let _ = Hashtbl.replace utf82macro "\226\140\156" "ulcorner" -let _ = Hashtbl.replace utf82macro "\226\139\175" "cdots" -let _ = Hashtbl.replace utf82macro "\226\139\176" "utdot" -let _ = Hashtbl.replace utf82macro "\226\140\157" "urcorner" -let _ = Hashtbl.replace utf82macro "\226\139\177" "ddots" -let _ = Hashtbl.replace utf82macro "\226\140\158" "llcorner" -let _ = Hashtbl.replace utf82macro "\226\140\159" "lrcorner" -let _ = Hashtbl.replace utf82macro "\226\139\178" "disin" -let _ = Hashtbl.replace utf82macro "\226\139\179" "isinsv" -let _ = Hashtbl.replace utf82macro "\226\139\180" "isins" -let _ = Hashtbl.replace utf82macro "\226\139\181" "isindot" -let _ = Hashtbl.replace utf82macro "\226\140\162" "frown" -let _ = Hashtbl.replace utf82macro "\226\140\163" "smile" -let _ = Hashtbl.replace utf82macro "\226\139\182" "notinvc" -let _ = Hashtbl.replace utf82macro "\226\139\183" "notinvb" -let _ = Hashtbl.replace utf82macro "\226\139\185" "isinE" -let _ = Hashtbl.replace utf82macro "\226\139\186" "nisd" -let _ = Hashtbl.replace utf82macro "\226\139\187" "xnis" -let _ = Hashtbl.replace utf82macro "\226\139\188" "nis" -let _ = Hashtbl.replace utf82macro "\226\140\169" "langle" -let _ = Hashtbl.replace utf82macro "\226\140\170" "rangle" -let _ = Hashtbl.replace utf82macro "\226\139\189" "notnivc" -let _ = Hashtbl.replace utf82macro "\226\139\190" "notnivb" -let _ = Hashtbl.replace utf82macro "\226\140\173" "cylcty" -let _ = Hashtbl.replace utf82macro "\226\140\174" "profalar" -let _ = Hashtbl.replace utf82macro "\226\166\157\239\184\128" "angrtvb" -let _ = Hashtbl.replace utf82macro "\226\140\182" "topbot" -let _ = Hashtbl.replace utf82macro "\226\140\189" "ovbar" -let _ = Hashtbl.replace utf82macro "\226\140\191" "solbar" -let _ = Hashtbl.replace utf82macro "\226\141\188" "angzarr" -let _ = Hashtbl.replace utf82macro "\226\139\173\204\184" "nvrtrie" -let _ = Hashtbl.replace utf82macro "\226\142\176" "lmoustache" -let _ = Hashtbl.replace utf82macro "\226\142\177" "rmoustache" -let _ = Hashtbl.replace utf82macro "\226\142\180" "tbrk" -let _ = Hashtbl.replace utf82macro "\226\142\181" "UnderBracket" -let _ = Hashtbl.replace utf82macro "\226\137\139\204\184" "napid" -let _ = Hashtbl.replace utf82macro "\226\144\163" "blank" -let _ = Hashtbl.replace utf82macro "\226\138\131/" "suphsol" -let _ = Hashtbl.replace utf82macro "\226\146\162\204\184" "NotNestedGreaterGreater" -let _ = Hashtbl.replace utf82macro "\226\147\136" "oS" -let _ = Hashtbl.replace utf82macro "\227\128\138" "Lang" -let _ = Hashtbl.replace utf82macro "\227\128\139" "Rang" -let _ = Hashtbl.replace utf82macro "\226\148\128" "HorizontalLine" -let _ = Hashtbl.replace utf82macro "\226\136\166\239\184\128" "nspar" -let _ = Hashtbl.replace utf82macro "\227\128\148" "lbbrk" -let _ = Hashtbl.replace utf82macro "\227\128\149" "rbbrk" -let _ = Hashtbl.replace utf82macro "\226\148\130" "boxv" -let _ = Hashtbl.replace utf82macro "\227\128\152" "lopar" -let _ = Hashtbl.replace utf82macro "\227\128\153" "ropar" -let _ = Hashtbl.replace utf82macro "\227\128\154" "lobrk" -let _ = Hashtbl.replace utf82macro "\227\128\155" "robrk" -let _ = Hashtbl.replace utf82macro "\226\148\140" "boxdr" -let _ = Hashtbl.replace utf82macro "\226\148\144" "boxdl" -let _ = Hashtbl.replace utf82macro "\226\148\148" "boxur" -let _ = Hashtbl.replace utf82macro "\226\148\152" "boxul" -let _ = Hashtbl.replace utf82macro "\226\148\156" "boxvr" -let _ = Hashtbl.replace utf82macro "\226\149\144" "boxH" -let _ = Hashtbl.replace utf82macro "\226\148\164" "boxvl" -let _ = Hashtbl.replace utf82macro "\226\149\145" "boxV" -let _ = Hashtbl.replace utf82macro "\226\149\146" "boxdR" -let _ = Hashtbl.replace utf82macro "\226\150\128" "uhblk" -let _ = Hashtbl.replace utf82macro "\226\149\147" "boxDr" -let _ = Hashtbl.replace utf82macro "\226\149\148" "boxDR" -let _ = Hashtbl.replace utf82macro "\226\137\168\239\184\128" "lvnE" -let _ = Hashtbl.replace utf82macro "\226\149\149" "boxdL" -let _ = Hashtbl.replace utf82macro "\226\149\150" "boxDl" -let _ = Hashtbl.replace utf82macro "\226\150\132" "lhblk" -let _ = Hashtbl.replace utf82macro "\226\149\151" "boxDL" -let _ = Hashtbl.replace utf82macro "\226\149\152" "boxuR" -let _ = Hashtbl.replace utf82macro "\226\149\153" "boxUr" -let _ = Hashtbl.replace utf82macro "\226\148\172" "boxhd" -let _ = Hashtbl.replace utf82macro "\226\149\154" "boxUR" -let _ = Hashtbl.replace utf82macro "\226\149\155" "boxuL" -let _ = Hashtbl.replace utf82macro "\226\150\136" "block" -let _ = Hashtbl.replace utf82macro "\226\149\156" "boxUl" -let _ = Hashtbl.replace utf82macro "\226\149\157" "boxUL" -let _ = Hashtbl.replace utf82macro "\226\149\158" "boxvR" -let _ = Hashtbl.replace utf82macro "\226\149\159" "boxVr" -let _ = Hashtbl.replace utf82macro "\226\149\160" "boxVR" -let _ = Hashtbl.replace utf82macro "\226\149\161" "boxvL" -let _ = Hashtbl.replace utf82macro "\226\148\180" "boxhu" -let _ = Hashtbl.replace utf82macro "\226\149\162" "boxVl" -let _ = Hashtbl.replace utf82macro "\226\149\163" "boxVL" -let _ = Hashtbl.replace utf82macro "\226\149\164" "boxHd" -let _ = Hashtbl.replace utf82macro "\226\150\145" "blk14" -let _ = Hashtbl.replace utf82macro "\226\149\165" "boxhD" -let _ = Hashtbl.replace utf82macro "\226\150\146" "blk12" -let _ = Hashtbl.replace utf82macro "\226\149\166" "boxHD" -let _ = Hashtbl.replace utf82macro "\226\150\147" "blk34" -let _ = Hashtbl.replace utf82macro "\226\149\167" "boxHu" -let _ = Hashtbl.replace utf82macro "\226\149\168" "boxhU" -let _ = Hashtbl.replace utf82macro "\226\151\130" "ltrif" -let _ = Hashtbl.replace utf82macro "\226\151\131" "triangleleft" -let _ = Hashtbl.replace utf82macro "\226\148\188" "boxvh" -let _ = Hashtbl.replace utf82macro "\226\149\169" "boxHU" -let _ = Hashtbl.replace utf82macro "\226\149\170" "boxvH" -let _ = Hashtbl.replace utf82macro "\226\149\171" "boxVh" -let _ = Hashtbl.replace utf82macro "\226\149\172" "boxVH" -let _ = Hashtbl.replace utf82macro "\226\151\138" "lozenge" -let _ = Hashtbl.replace utf82macro "\226\151\139" "cir" -let _ = Hashtbl.replace utf82macro "\226\170\172\239\184\128" "smtes" -let _ = Hashtbl.replace utf82macro "\226\150\161" "Square" -let _ = Hashtbl.replace utf82macro "\226\140\132\239\184\128" "ShortDownArrow" -let _ = Hashtbl.replace utf82macro "\226\150\170" "squf" -let _ = Hashtbl.replace utf82macro "\226\152\133" "starf" -let _ = Hashtbl.replace utf82macro "\226\150\173" "rect" -let _ = Hashtbl.replace utf82macro "\226\150\174" "marker" -let _ = Hashtbl.replace utf82macro "\226\150\179" "bigtriangleup" -let _ = Hashtbl.replace utf82macro "\226\152\142" "phone" -let _ = Hashtbl.replace utf82macro "\226\150\180" "utrif" -let _ = Hashtbl.replace utf82macro "\226\150\181" "triangle" -let _ = Hashtbl.replace utf82macro "\226\150\184" "rtrif" -let _ = Hashtbl.replace utf82macro "\226\150\185" "triangleright" -let _ = Hashtbl.replace utf82macro "\226\153\128" "female" -let _ = Hashtbl.replace utf82macro "\226\153\130" "male" -let _ = Hashtbl.replace utf82macro "\226\150\189" "bigtriangledown" -let _ = Hashtbl.replace utf82macro "\226\150\190" "dtrif" -let _ = Hashtbl.replace utf82macro "\226\151\172" "tridot" -let _ = Hashtbl.replace utf82macro "\226\128\137\226\128\138\226\128\138" "ThickSpace" -let _ = Hashtbl.replace utf82macro "\226\150\191" "triangledown" -let _ = Hashtbl.replace utf82macro "\226\151\175" "bigcirc" -let _ = Hashtbl.replace utf82macro "\226\137\177\226\131\165" "NotGreaterEqual" -let _ = Hashtbl.replace utf82macro "\226\151\184" "ultri" -let _ = Hashtbl.replace utf82macro "=\226\131\165" "bne" -let _ = Hashtbl.replace utf82macro "\226\151\185" "urtri" -let _ = Hashtbl.replace utf82macro "\226\151\186" "lltri" -let _ = Hashtbl.replace utf82macro "\226\151\189" "EmptySmallSquare" -let _ = Hashtbl.replace utf82macro "\226\151\190" "FilledSmallSquare" -let _ = Hashtbl.replace utf82macro "\226\153\160" "spadesuit" -let _ = Hashtbl.replace utf82macro "\226\153\161" "heartsuit" -let _ = Hashtbl.replace utf82macro "\226\153\162" "diamondsuit" -let _ = Hashtbl.replace utf82macro "\226\153\163" "clubsuit" -let _ = Hashtbl.replace utf82macro "\226\153\166" "diams" -let _ = Hashtbl.replace utf82macro "ker" "ker" -let _ = Hashtbl.replace utf82macro "\226\153\170" "sung" -let _ = Hashtbl.replace utf82macro "\226\153\173" "flat" -let _ = Hashtbl.replace utf82macro "\226\153\174" "natural" -let _ = Hashtbl.replace utf82macro "\226\153\175" "sharp" -let _ = Hashtbl.replace utf82macro "\226\156\147" "checkmark" -let _ = Hashtbl.replace utf82macro "\226\156\151" "cross" -let _ = Hashtbl.replace utf82macro "\226\134\146\239\184\128" "srarr" -let _ = Hashtbl.replace utf82macro "\226\156\160" "maltese" -let _ = Hashtbl.replace utf82macro "\226\157\152" "VerticalSeparator" -let _ = Hashtbl.replace utf82macro "\226\156\182" "sext" -let _ = Hashtbl.replace utf82macro "\226\138\143\204\184" "NotSquareSubset" -let _ = Hashtbl.replace utf82macro "\226\136\150\239\184\128" "ssetmn" -let _ = Hashtbl.replace utf82macro "\226\136\164\239\184\128" "nsmid" -let _ = Hashtbl.replace utf82macro "\226\164\133" "Map" -let _ = Hashtbl.replace utf82macro "\226\164\140" "lbarr" -let _ = Hashtbl.replace utf82macro "\226\164\141" "rbarr" -let _ = Hashtbl.replace utf82macro "\226\164\142" "lBarr" -let _ = Hashtbl.replace utf82macro "\226\164\143" "rBarr" -let _ = Hashtbl.replace utf82macro "\226\164\144" "RBarr" -let _ = Hashtbl.replace utf82macro "\226\164\145" "DDotrahd" -let _ = Hashtbl.replace utf82macro "\226\164\146" "UpArrowBar" -let _ = Hashtbl.replace utf82macro "\226\138\147\239\184\128" "sqcaps" -let _ = Hashtbl.replace utf82macro "\226\164\147" "DownArrowBar" -let _ = Hashtbl.replace utf82macro "\226\164\150" "Rarrtl" -let _ = Hashtbl.replace utf82macro "exp" "exp" -let _ = Hashtbl.replace utf82macro "\226\165\133" "rarrpl" -let _ = Hashtbl.replace utf82macro "tanh" "tanh" -let _ = Hashtbl.replace utf82macro "\226\164\153" "latail" -let _ = Hashtbl.replace utf82macro "\226\164\155" "lAtail" -let _ = Hashtbl.replace utf82macro "\226\165\136" "harrcir" -let _ = Hashtbl.replace utf82macro "arcsin" "arcsin" -let _ = Hashtbl.replace utf82macro "\226\165\137" "Uarrocir" -let _ = Hashtbl.replace utf82macro "\226\164\156" "rAtail" -let _ = Hashtbl.replace utf82macro "\226\137\129\204\184" "nvsim" -let _ = Hashtbl.replace utf82macro "\226\165\138" "lurdshar" -let _ = Hashtbl.replace utf82macro "\226\164\157" "larrfs" -let _ = Hashtbl.replace utf82macro "\226\164\158" "rarrfs" -let _ = Hashtbl.replace utf82macro "\226\165\139" "ldrushar" -let _ = Hashtbl.replace utf82macro "\226\164\159" "larrbfs" -let _ = Hashtbl.replace utf82macro "\226\164\160" "rarrbfs" -let _ = Hashtbl.replace utf82macro "\226\165\142" "LeftRightVector" -let _ = Hashtbl.replace utf82macro "\226\165\143" "RightUpDownVector" -let _ = Hashtbl.replace utf82macro "\226\164\163" "nwarhk" -let _ = Hashtbl.replace utf82macro "\226\165\144" "DownLeftRightVector" -let _ = Hashtbl.replace utf82macro "\226\164\164" "nearhk" -let _ = Hashtbl.replace utf82macro "\226\165\145" "LeftUpDownVector" -let _ = Hashtbl.replace utf82macro "\226\165\146" "LeftVectorBar" -let _ = Hashtbl.replace utf82macro "\226\164\165" "searhk" -let _ = Hashtbl.replace utf82macro "\226\165\147" "RightVectorBar" -let _ = Hashtbl.replace utf82macro "\226\164\166" "swarhk" -let _ = Hashtbl.replace utf82macro "\226\165\148" "RightUpVectorBar" -let _ = Hashtbl.replace utf82macro "\226\164\167" "nwnear" -let _ = Hashtbl.replace utf82macro "\226\165\149" "RightDownVectorBar" -let _ = Hashtbl.replace utf82macro "\226\164\168" "toea" -let _ = Hashtbl.replace utf82macro "\226\164\169" "tosa" -let _ = Hashtbl.replace utf82macro "\226\165\150" "DownLeftVectorBar" -let _ = Hashtbl.replace utf82macro "\226\164\170" "swnwar" -let _ = Hashtbl.replace utf82macro "\226\165\151" "DownRightVectorBar" -let _ = Hashtbl.replace utf82macro "\226\165\152" "LeftUpVectorBar" -let _ = Hashtbl.replace utf82macro "\226\165\153" "LeftDownVectorBar" -let _ = Hashtbl.replace utf82macro "\226\165\154" "LeftTeeVector" -let _ = Hashtbl.replace utf82macro "\226\165\155" "RightTeeVector" -let _ = Hashtbl.replace utf82macro "\226\165\156" "RightUpTeeVector" -let _ = Hashtbl.replace utf82macro "\226\165\157" "RightDownTeeVector" -let _ = Hashtbl.replace utf82macro "\226\139\152\204\184" "nLl" -let _ = Hashtbl.replace utf82macro "\226\166\139" "lbrke" -let _ = Hashtbl.replace utf82macro "\226\165\158" "DownLeftTeeVector" -let _ = Hashtbl.replace utf82macro "\226\166\140" "rbrke" -let _ = Hashtbl.replace utf82macro "\226\165\159" "DownRightTeeVector" -let _ = Hashtbl.replace utf82macro "\226\164\179" "rarrc" -let _ = Hashtbl.replace utf82macro "\226\165\160" "LeftUpTeeVector" -let _ = Hashtbl.replace utf82macro "\226\166\141" "lbrkslu" -let _ = Hashtbl.replace utf82macro "\226\166\142" "rbrksld" -let _ = Hashtbl.replace utf82macro "\226\165\161" "LeftDownTeeVector" -let _ = Hashtbl.replace utf82macro "\226\165\162" "lHar" -let _ = Hashtbl.replace utf82macro "\226\166\143" "lbrksld" -let _ = Hashtbl.replace utf82macro "\226\164\181" "cudarrr" -let _ = Hashtbl.replace utf82macro "sinh" "sinh" -let _ = Hashtbl.replace utf82macro "\226\165\163" "uHar" -let _ = Hashtbl.replace utf82macro "\226\166\144" "rbrkslu" -let _ = Hashtbl.replace utf82macro "\226\164\182" "ldca" -let _ = Hashtbl.replace utf82macro "\226\165\164" "rHar" -let _ = Hashtbl.replace utf82macro "\226\164\183" "rdca" -let _ = Hashtbl.replace utf82macro "\226\166\145" "langd" -let _ = Hashtbl.replace utf82macro "\226\166\146" "rangd" -let _ = Hashtbl.replace utf82macro "\226\165\165" "dHar" -let _ = Hashtbl.replace utf82macro "\226\164\184" "cudarrl" -let _ = Hashtbl.replace utf82macro "\226\167\128" "olt" -let _ = Hashtbl.replace utf82macro "\226\136\137\204\184" "notinva" -let _ = Hashtbl.replace utf82macro "\226\165\166" "luruhar" -let _ = Hashtbl.replace utf82macro "\226\166\147" "lparlt" -let _ = Hashtbl.replace utf82macro "\226\164\185" "larrpl" -let _ = Hashtbl.replace utf82macro "\226\166\148" "rpargt" -let _ = Hashtbl.replace utf82macro "\226\167\129" "ogt" -let _ = Hashtbl.replace utf82macro "\226\165\167" "ldrdhar" -let _ = Hashtbl.replace utf82macro "\226\165\168" "ruluhar" -let _ = Hashtbl.replace utf82macro "\226\166\149" "gtlPar" -let _ = Hashtbl.replace utf82macro "\226\167\130" "cirscir" -let _ = Hashtbl.replace utf82macro "\226\165\169" "rdldhar" -let _ = Hashtbl.replace utf82macro "\226\166\150" "ltrPar" -let _ = Hashtbl.replace utf82macro "\226\164\188" "curarrm" -let _ = Hashtbl.replace utf82macro "\226\167\131" "cirE" -let _ = Hashtbl.replace utf82macro "\226\137\161\226\131\165" "bnequiv" -let _ = Hashtbl.replace utf82macro "\226\167\132" "solb" -let _ = Hashtbl.replace utf82macro "\226\165\170" "lharul" -let _ = Hashtbl.replace utf82macro "\226\164\189" "cularrp" -let _ = Hashtbl.replace utf82macro "\226\165\171" "llhard" -let _ = Hashtbl.replace utf82macro "\226\167\133" "bsolb" -let _ = Hashtbl.replace utf82macro "\226\165\172" "rharul" -let _ = Hashtbl.replace utf82macro "\226\166\154" "vzigzag" -let _ = Hashtbl.replace utf82macro "\226\165\173" "lrhard" -let _ = Hashtbl.replace utf82macro "\226\165\174" "UpEquilibrium" -let _ = Hashtbl.replace utf82macro "\226\165\175" "ReverseUpEquilibrium" -let _ = Hashtbl.replace utf82macro "\226\167\137" "boxbox" -let _ = Hashtbl.replace utf82macro "\226\165\176" "RoundImplies" -let _ = Hashtbl.replace utf82macro "\226\166\157" "angrtvbd" -let _ = Hashtbl.replace utf82macro "\226\165\177" "erarr" -let _ = Hashtbl.replace utf82macro "\226\165\178" "simrarr" -let _ = Hashtbl.replace utf82macro "\226\167\141" "trisb" -let _ = Hashtbl.replace utf82macro "\226\165\179" "larrsim" -let _ = Hashtbl.replace utf82macro "\226\167\142" "rtriltri" -let _ = Hashtbl.replace utf82macro "\226\165\180" "rarrsim" -let _ = Hashtbl.replace utf82macro "\226\165\181" "rarrap" -let _ = Hashtbl.replace utf82macro "\226\167\143" "LeftTriangleBar" -let _ = Hashtbl.replace utf82macro "\226\167\144" "RightTriangleBar" -let _ = Hashtbl.replace utf82macro "\226\165\182" "ltlarr" -let _ = Hashtbl.replace utf82macro "\226\166\164" "ange" -let _ = Hashtbl.replace utf82macro "\226\166\165" "range" -let _ = Hashtbl.replace utf82macro "\226\165\184" "gtrarr" -let _ = Hashtbl.replace utf82macro "\226\165\185" "subrarr" -let _ = Hashtbl.replace utf82macro "\226\166\166" "dwangle" -let _ = Hashtbl.replace utf82macro "\226\166\167" "uwangle" -let _ = Hashtbl.replace utf82macro "\226\165\187" "suplarr" -let _ = Hashtbl.replace utf82macro "\226\166\168" "angmsdaa" -let _ = Hashtbl.replace utf82macro "\226\165\188" "lfisht" -let _ = Hashtbl.replace utf82macro "\226\166\169" "angmsdab" -let _ = Hashtbl.replace utf82macro "\226\165\189" "rfisht" -let _ = Hashtbl.replace utf82macro "\226\166\170" "angmsdac" -let _ = Hashtbl.replace utf82macro "\226\165\190" "ufisht" -let _ = Hashtbl.replace utf82macro "\226\166\171" "angmsdad" -let _ = Hashtbl.replace utf82macro "\226\165\191" "dfisht" -let _ = Hashtbl.replace utf82macro "\226\166\172" "angmsdae" -let _ = Hashtbl.replace utf82macro "\226\167\154" "race" -let _ = Hashtbl.replace utf82macro "\226\166\173" "angmsdaf" -let _ = Hashtbl.replace utf82macro "\226\166\174" "angmsdag" -let _ = Hashtbl.replace utf82macro "\226\167\155" "acE" -let _ = Hashtbl.replace utf82macro "\226\167\156" "iinfin" -let _ = Hashtbl.replace utf82macro "\226\166\175" "angmsdah" -let _ = Hashtbl.replace utf82macro "\226\166\176" "bemptyv" -let _ = Hashtbl.replace utf82macro "\226\167\158" "nvinfin" -let _ = Hashtbl.replace utf82macro "\226\166\177" "demptyv" -let _ = Hashtbl.replace utf82macro "\226\168\140" "qint" -let _ = Hashtbl.replace utf82macro "\226\166\178" "cemptyv" -let _ = Hashtbl.replace utf82macro "\226\166\179" "raemptyv" -let _ = Hashtbl.replace utf82macro "\226\168\141" "fpartint" -let _ = Hashtbl.replace utf82macro "\226\166\180" "laemptyv" -let _ = Hashtbl.replace utf82macro "\226\166\181" "ohbar" -let _ = Hashtbl.replace utf82macro "\226\166\182" "omid" -let _ = Hashtbl.replace utf82macro "\226\167\163" "eparsl" -let _ = Hashtbl.replace utf82macro "\226\168\144" "cirfnint" -let _ = Hashtbl.replace utf82macro "\226\167\164" "smeparsl" -let _ = Hashtbl.replace utf82macro "\226\166\183" "opar" -let _ = Hashtbl.replace utf82macro "\226\168\145" "awint" -let _ = Hashtbl.replace utf82macro "\226\168\146" "rppolint" -let _ = Hashtbl.replace utf82macro "\226\167\165" "eqvparsl" -let _ = Hashtbl.replace utf82macro "\226\168\147" "scpolint" -let _ = Hashtbl.replace utf82macro "\226\166\185" "operp" -let _ = Hashtbl.replace utf82macro "\226\169\128" "capdot" -let _ = Hashtbl.replace utf82macro "\226\168\148" "npolint" -let _ = Hashtbl.replace utf82macro "\226\168\149" "pointint" -let _ = Hashtbl.replace utf82macro "\226\166\187" "olcross" -let _ = Hashtbl.replace utf82macro "\226\169\130" "ncup" -let _ = Hashtbl.replace utf82macro "\226\168\150" "quatint" -let _ = Hashtbl.replace utf82macro "\226\166\188" "odsold" -let _ = Hashtbl.replace utf82macro "\226\169\131" "ncap" -let _ = Hashtbl.replace utf82macro "\226\168\151" "intlarhk" -let _ = Hashtbl.replace utf82macro "\226\169\132" "capand" -let _ = Hashtbl.replace utf82macro "\226\166\190" "olcir" -let _ = Hashtbl.replace utf82macro "\226\169\133" "cupor" -let _ = Hashtbl.replace utf82macro "\226\167\171" "lozf" -let _ = Hashtbl.replace utf82macro "\226\166\191" "ofcir" -let _ = Hashtbl.replace utf82macro "\226\169\134" "cupcap" -let _ = Hashtbl.replace utf82macro "\226\169\135" "capcup" -let _ = Hashtbl.replace utf82macro "\226\169\136" "cupbrcap" -let _ = Hashtbl.replace utf82macro "\226\169\137" "capbrcup" -let _ = Hashtbl.replace utf82macro "\226\169\138" "cupcup" -let _ = Hashtbl.replace utf82macro "\226\169\139" "capcap" -let _ = Hashtbl.replace utf82macro "\226\169\140" "ccups" -let _ = Hashtbl.replace utf82macro "\226\169\141" "ccaps" -let _ = Hashtbl.replace utf82macro "\226\167\180" "RuleDelayed" -let _ = Hashtbl.replace utf82macro "\226\168\162" "pluscir" -let _ = Hashtbl.replace utf82macro "\226\168\163" "plusacir" -let _ = Hashtbl.replace utf82macro "\226\167\182" "dsol" -let _ = Hashtbl.replace utf82macro "\226\169\144" "ccupssm" -let _ = Hashtbl.replace utf82macro "\226\168\164" "simplus" -let _ = Hashtbl.replace utf82macro "\226\168\165" "plusdu" -let _ = Hashtbl.replace utf82macro "\226\168\166" "plussim" -let _ = Hashtbl.replace utf82macro "\226\170\128" "gesdot" -let _ = Hashtbl.replace utf82macro "\226\169\147" "And" -let _ = Hashtbl.replace utf82macro "\226\168\167" "plustwo" -let _ = Hashtbl.replace utf82macro "\226\169\148" "Or" -let _ = Hashtbl.replace utf82macro "\226\170\129" "lesdoto" -let _ = Hashtbl.replace utf82macro "\226\170\130" "gesdoto" -let _ = Hashtbl.replace utf82macro "\226\169\149" "andand" -let _ = Hashtbl.replace utf82macro "\226\169\150" "oror" -let _ = Hashtbl.replace utf82macro "\226\168\169" "mcomma" -let _ = Hashtbl.replace utf82macro "\226\170\131" "lesdotor" -let _ = Hashtbl.replace utf82macro "\226\169\151" "orslope" -let _ = Hashtbl.replace utf82macro "\226\168\170" "minusdu" -let _ = Hashtbl.replace utf82macro "\226\170\132" "gesdotol" -let _ = Hashtbl.replace utf82macro "\226\169\152" "andslope" -let _ = Hashtbl.replace utf82macro "\226\168\173" "loplus" -let _ = Hashtbl.replace utf82macro "\226\169\154" "andv" -let _ = Hashtbl.replace utf82macro "\226\168\174" "roplus" -let _ = Hashtbl.replace utf82macro "\226\169\155" "orv" -let _ = Hashtbl.replace utf82macro "\226\170\137" "lnapprox" -let _ = Hashtbl.replace utf82macro "\226\168\175" "Cross" -let _ = Hashtbl.replace utf82macro "\226\169\156" "andd" -let _ = Hashtbl.replace utf82macro "\226\168\176" "timesd" -let _ = Hashtbl.replace utf82macro "\226\169\157" "ord" -let _ = Hashtbl.replace utf82macro "\226\170\138" "gnapprox" -let _ = Hashtbl.replace utf82macro "\226\168\177" "timesbar" -let _ = Hashtbl.replace utf82macro "\226\169\159" "wedbar" -let _ = Hashtbl.replace utf82macro "\226\168\179" "smashp" -let _ = Hashtbl.replace utf82macro "\226\170\141" "lsime" -let _ = Hashtbl.replace utf82macro "j\239\184\128" "jmath" -let _ = Hashtbl.replace utf82macro "\226\168\180" "lotimes" -let _ = Hashtbl.replace utf82macro "\226\170\142" "gsime" -let _ = Hashtbl.replace utf82macro "\226\168\181" "rotimes" -let _ = Hashtbl.replace utf82macro "\226\170\143" "lsimg" -let _ = Hashtbl.replace utf82macro "\226\168\182" "otimesas" -let _ = Hashtbl.replace utf82macro "\226\170\144" "gsiml" -let _ = Hashtbl.replace utf82macro "\226\168\183" "Otimes" -let _ = Hashtbl.replace utf82macro "\226\170\145" "lgE" -let _ = Hashtbl.replace utf82macro "\226\168\184" "odiv" -let _ = Hashtbl.replace utf82macro "\226\170\146" "glE" -let _ = Hashtbl.replace utf82macro "\226\168\185" "triplus" -let _ = Hashtbl.replace utf82macro "\226\171\128" "supplus" -let _ = Hashtbl.replace utf82macro "\226\169\166" "sdote" -let _ = Hashtbl.replace utf82macro "\226\170\147" "lesges" -let _ = Hashtbl.replace utf82macro "\226\168\186" "triminus" -let _ = Hashtbl.replace utf82macro "\226\171\129" "submult" -let _ = Hashtbl.replace utf82macro "\226\170\148" "gesles" -let _ = Hashtbl.replace utf82macro "\226\168\187" "tritime" -let _ = Hashtbl.replace utf82macro "\226\171\130" "supmult" -let _ = Hashtbl.replace utf82macro "\226\171\131" "subedot" -let _ = Hashtbl.replace utf82macro "\226\168\188" "iprod" -let _ = Hashtbl.replace utf82macro "\226\171\132" "supedot" -let _ = Hashtbl.replace utf82macro "\226\169\170" "simdot" -let _ = Hashtbl.replace utf82macro "\226\170\151" "elsdot" -let _ = Hashtbl.replace utf82macro "\226\170\152" "egsdot" -let _ = Hashtbl.replace utf82macro "\226\170\153" "el" -let _ = Hashtbl.replace utf82macro "\226\168\191" "amalg" -let _ = Hashtbl.replace utf82macro "\226\171\135" "subsim" -let _ = Hashtbl.replace utf82macro "\226\170\154" "eg" -let _ = Hashtbl.replace utf82macro "\226\169\173" "congdot" -let _ = Hashtbl.replace utf82macro "\226\171\136" "supsim" -let _ = Hashtbl.replace utf82macro "\226\169\175" "apacir" -let _ = Hashtbl.replace utf82macro "\226\170\157" "siml" -let _ = Hashtbl.replace utf82macro "\226\170\158" "simg" -let _ = Hashtbl.replace utf82macro "\226\169\177" "eplus" -let _ = Hashtbl.replace utf82macro "\226\170\159" "simlE" -let _ = Hashtbl.replace utf82macro "\226\169\178" "pluse" -let _ = Hashtbl.replace utf82macro "\226\170\160" "simgE" -let _ = Hashtbl.replace utf82macro "\226\169\179" "Esim" -let _ = Hashtbl.replace utf82macro "\226\170\161" "LessLess" -let _ = Hashtbl.replace utf82macro "\226\169\180" "Colone" -let _ = Hashtbl.replace utf82macro "\226\170\162" "GreaterGreater" -let _ = Hashtbl.replace utf82macro "\226\169\181" "Equal" -let _ = Hashtbl.replace utf82macro "\226\171\143" "csub" -let _ = Hashtbl.replace utf82macro "\226\171\144" "csup" -let _ = Hashtbl.replace utf82macro "\226\170\164" "glj" -let _ = Hashtbl.replace utf82macro "\226\169\183" "eDDot" -let _ = Hashtbl.replace utf82macro "\226\171\145" "csube" -let _ = Hashtbl.replace utf82macro "\226\170\165" "gla" -let _ = Hashtbl.replace utf82macro "\226\169\184" "equivDD" -let _ = Hashtbl.replace utf82macro "\226\171\146" "csupe" -let _ = Hashtbl.replace utf82macro "\226\171\147" "subsup" -let _ = Hashtbl.replace utf82macro "\226\169\185" "ltcir" -let _ = Hashtbl.replace utf82macro "\226\170\166" "ltcc" -let _ = Hashtbl.replace utf82macro "\226\171\148" "supsub" -let _ = Hashtbl.replace utf82macro "\226\169\186" "gtcir" -let _ = Hashtbl.replace utf82macro "\226\170\167" "gtcc" -let _ = Hashtbl.replace utf82macro "\226\171\149" "subsub" -let _ = Hashtbl.replace utf82macro "\226\169\187" "ltquest" -let _ = Hashtbl.replace utf82macro "\226\170\168" "lescc" -let _ = Hashtbl.replace utf82macro "\226\171\150" "supsup" -let _ = Hashtbl.replace utf82macro "\226\169\188" "gtquest" -let _ = Hashtbl.replace utf82macro "\226\170\169" "gescc" -let _ = Hashtbl.replace utf82macro "\226\171\151" "suphsub" -let _ = Hashtbl.replace utf82macro "\226\170\170" "smt" -let _ = Hashtbl.replace utf82macro "\226\169\189" "LessSlantEqual" -let _ = Hashtbl.replace utf82macro "\226\171\152" "supdsub" -let _ = Hashtbl.replace utf82macro "\226\134\144\239\184\128" "slarr" -let _ = Hashtbl.replace utf82macro "\226\170\171" "lat" -let _ = Hashtbl.replace utf82macro "\226\169\190" "GreaterSlantEqual" -let _ = Hashtbl.replace utf82macro "\226\170\172" "smte" -let _ = Hashtbl.replace utf82macro "\226\169\191" "lesdot" -let _ = Hashtbl.replace utf82macro "\226\171\153" "forkv" -let _ = Hashtbl.replace utf82macro "\226\171\154" "topfork" -let _ = Hashtbl.replace utf82macro "\226\170\173" "late" -let _ = Hashtbl.replace utf82macro "\226\171\155" "mlcp" -let _ = Hashtbl.replace utf82macro "\226\170\174" "bumpE" -let _ = Hashtbl.replace utf82macro "\226\170\175" "preceq" -let _ = Hashtbl.replace utf82macro "\226\170\181" "prnE" -let _ = Hashtbl.replace utf82macro "\226\170\182" "succneqq" -let _ = Hashtbl.replace utf82macro "\226\171\164" "DoubleLeftTee" -let _ = Hashtbl.replace utf82macro "\226\171\166" "Vdashl" -let _ = Hashtbl.replace utf82macro "\226\171\167" "Barv" -let _ = Hashtbl.replace utf82macro "\226\171\168" "vBar" -let _ = Hashtbl.replace utf82macro "\226\170\187" "Pr" -let _ = Hashtbl.replace utf82macro "\226\171\169" "vBarv" -let _ = Hashtbl.replace utf82macro "\226\170\188" "Sc" -let _ = Hashtbl.replace utf82macro "\226\170\189" "subdot" -let _ = Hashtbl.replace utf82macro "\226\171\171" "Vbar" -let _ = Hashtbl.replace utf82macro "\226\170\190" "supdot" -let _ = Hashtbl.replace utf82macro "\226\170\191" "subplus" -let _ = Hashtbl.replace utf82macro "\226\171\172" "Not" -let _ = Hashtbl.replace utf82macro "\226\171\173" "bNot" -let _ = Hashtbl.replace utf82macro "\226\171\174" "rnmid" -let _ = Hashtbl.replace utf82macro "\226\171\175" "cirmid" -let _ = Hashtbl.replace utf82macro "\226\171\176" "midcir" -let _ = Hashtbl.replace utf82macro "\226\171\177" "topcir" -let _ = Hashtbl.replace utf82macro "\226\171\178" "nhpar" -let _ = Hashtbl.replace utf82macro "\226\171\179" "parsim" -let _ = Hashtbl.replace utf82macro "\226\128\137\239\184\128" "NegativeThinSpace" -let _ = Hashtbl.replace utf82macro "arctan" "arctan" -let _ = Hashtbl.replace utf82macro "\226\137\136\239\184\128" "thkap" -let _ = Hashtbl.replace utf82macro "lim" "lim" -let _ = Hashtbl.replace utf82macro "\226\136\169\239\184\128" "caps" -let _ = Hashtbl.replace utf82macro "\226\138\138\239\184\128" "vsubnE" -let _ = Hashtbl.replace utf82macro "\226\137\170\204\184\239\184\128" "NotLessLess" -let _ = Hashtbl.replace utf82macro "\226\138\144\204\184" "NotSquareSuperset" -let _ = Hashtbl.replace utf82macro "gcd" "gcd" -let _ = Hashtbl.replace utf82macro "\226\139\154\239\184\128" "lesg" -let _ = Hashtbl.replace utf82macro "\226\136\160\204\184" "nang" -let _ = Hashtbl.replace utf82macro "log" "log" -let _ = Hashtbl.replace utf82macro "arccos" "arccos" -let _ = Hashtbl.replace utf82macro "\226\137\130\204\184" "NotEqualTilde" -let _ = Hashtbl.replace utf82macro "\226\137\171\204\184\239\184\128" "NotGreaterGreater" -let _ = Hashtbl.replace utf82macro "\226\139\182\239\184\128" "notindot" -let _ = Hashtbl.replace utf82macro "\226\137\191\204\184" "NotSucceedsTilde" -let _ = Hashtbl.replace utf82macro "\226\139\153\204\184" "nGg" -let _ = Hashtbl.replace utf82macro "\239\149\152" "loang" -let _ = Hashtbl.replace utf82macro "\239\149\153" "roang" -let _ = Hashtbl.replace utf82macro "\239\150\155" "FilledVerySmallSquare" -let _ = Hashtbl.replace utf82macro "\239\150\156" "EmptyVerySmallSquare" -let _ = Hashtbl.replace utf82macro "arg" "arg" -let _ = Hashtbl.replace utf82macro "\239\150\162" "dzigrarr" -let _ = Hashtbl.replace utf82macro "\239\149\182" "xlarr" -let _ = Hashtbl.replace utf82macro "\239\149\183" "xrarr" -let _ = Hashtbl.replace utf82macro "\239\149\184" "xharr" -let _ = Hashtbl.replace utf82macro "\239\149\185" "xlArr" -let _ = Hashtbl.replace utf82macro "\239\149\186" "xrArr" -let _ = Hashtbl.replace utf82macro "\239\149\187" "xhArr" -let _ = Hashtbl.replace utf82macro "\239\149\189" "xmap" -let _ = Hashtbl.replace utf82macro "max" "min" -let _ = Hashtbl.replace utf82macro "\226\169\176\204\184" "napE" -let _ = Hashtbl.replace utf82macro "\\\226\138\130" "bsolhsub" -let _ = Hashtbl.replace utf82macro "\226\136\165\239\184\128\226\131\165" "nparsl" -let _ = Hashtbl.replace utf82macro "cosh" "cosh" -let _ = Hashtbl.replace utf82macro "coth" "coth" -let _ = Hashtbl.replace utf82macro "\226\136\188\239\184\128" "thksim" -let _ = Hashtbl.replace utf82macro "\226\137\169\239\184\128" "gvnE" -let _ = Hashtbl.replace utf82macro "\226\170\173\239\184\128" "lates" -let _ = Hashtbl.replace utf82macro "\226\132\143\239\184\128" "hbar" -let _ = Hashtbl.replace utf82macro "sec" "sec" -let _ = Hashtbl.replace utf82macro "\226\137\142\204\184" "NotHumpDownHump" -let _ = Hashtbl.replace utf82macro "mod" "bmod" -let _ = Hashtbl.replace utf82macro "\226\128\133\239\184\128" "NegativeThickSpace" -let _ = Hashtbl.replace utf82macro "sin" "sin" -let _ = Hashtbl.replace utf82macro "Pr" "Pr" -let _ = Hashtbl.replace utf82macro "\226\137\170\204\184" "nLt" -let _ = Hashtbl.replace utf82macro "\226\136\165\239\184\128" "spar" -let _ = Hashtbl.replace utf82macro "\239\172\128" "fflig" -let _ = Hashtbl.replace utf82macro "\239\172\129" "filig" -let _ = Hashtbl.replace utf82macro "\239\172\130" "fllig" -let _ = Hashtbl.replace utf82macro "\239\172\131" "ffilig" -let _ = Hashtbl.replace utf82macro "\239\172\132" "ffllig" -let _ = Hashtbl.replace utf82macro "\226\167\143\204\184" "NotLeftTriangleBar" -let _ = Hashtbl.replace utf82macro "\226\137\160\239\184\128" "nedot" -let _ = Hashtbl.replace utf82macro "\226\138\148\239\184\128" "sqcups" -let _ = Hashtbl.replace utf82macro "\226\140\131\239\184\128" "ShortUpArrow" -let _ = Hashtbl.replace utf82macro "\226\137\137\204\184" "nvap" -let _ = Hashtbl.replace utf82macro "\240\157\147\128" "kscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\130" "mscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\131" "nscr" -let _ = Hashtbl.replace utf82macro "hom" "hom" -let _ = Hashtbl.replace utf82macro "\240\157\147\133" "pscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\134" "qscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\135" "rscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\136" "sscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\137" "tscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\156" "Ascr" -let _ = Hashtbl.replace utf82macro "\240\157\147\138" "uscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\139" "vscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\158" "Cscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\140" "wscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\159" "Dscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\141" "xscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\142" "yscr" -let _ = Hashtbl.replace utf82macro "\240\157\147\143" "zscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\162" "Gscr" -let _ = Hashtbl.replace utf82macro "\226\137\176\226\131\165" "NotLessEqual" -let _ = Hashtbl.replace utf82macro "\240\157\146\165" "Jscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\166" "Kscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\169" "Nscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\170" "Oscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\132" "Afr" -let _ = Hashtbl.replace utf82macro "\240\157\146\171" "Pscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\133" "Bfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\172" "Qscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\135" "Dfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\174" "Sscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\136" "Efr" -let _ = Hashtbl.replace utf82macro "\240\157\146\175" "Tscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\137" "Ffr" -let _ = Hashtbl.replace utf82macro "\240\157\146\176" "Uscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\138" "Gfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\177" "Vscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\178" "Wscr" -let _ = Hashtbl.replace utf82macro "\240\157\146\179" "Xscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\141" "Jfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\180" "Yscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\142" "Kfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\181" "Zscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\143" "Lfr" -let _ = Hashtbl.replace utf82macro "\240\157\148\144" "Mfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\182" "ascr" -let _ = Hashtbl.replace utf82macro "\240\157\148\145" "Nfr" -let _ = Hashtbl.replace utf82macro "\240\157\146\183" "bscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\146" "Ofr" -let _ = Hashtbl.replace utf82macro "\240\157\146\184" "cscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\147" "Pfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\128" "Iopf" -let _ = Hashtbl.replace utf82macro "\240\157\146\185" "dscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\148" "Qfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\129" "Jopf" -let _ = Hashtbl.replace utf82macro "\240\157\149\130" "Kopf" -let _ = Hashtbl.replace utf82macro "\240\157\146\187" "fscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\150" "Sfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\131" "Lopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\151" "Tfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\132" "Mopf" -let _ = Hashtbl.replace utf82macro "\240\157\146\189" "hscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\152" "Ufr" -let _ = Hashtbl.replace utf82macro "\240\157\146\190" "iscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\153" "Vfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\134" "Oopf" -let _ = Hashtbl.replace utf82macro "\240\157\146\191" "jscr" -let _ = Hashtbl.replace utf82macro "\240\157\148\154" "Wfr" -let _ = Hashtbl.replace utf82macro "\240\157\148\155" "Xfr" -let _ = Hashtbl.replace utf82macro "\240\157\148\156" "Yfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\138" "Sopf" -let _ = Hashtbl.replace utf82macro "\240\157\149\139" "Topf" -let _ = Hashtbl.replace utf82macro "\240\157\148\158" "afr" -let _ = Hashtbl.replace utf82macro "\240\157\149\140" "Uopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\159" "bfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\141" "Vopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\160" "cfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\142" "Wopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\161" "dfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\143" "Xopf" -let _ = Hashtbl.replace utf82macro "\226\170\175\204\184" "npreceq" -let _ = Hashtbl.replace utf82macro "\240\157\148\162" "efr" -let _ = Hashtbl.replace utf82macro "\240\157\149\144" "Yopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\163" "ffr" -let _ = Hashtbl.replace utf82macro "\240\157\148\164" "gfr" -let _ = Hashtbl.replace utf82macro "\240\157\148\165" "hfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\146" "aopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\166" "ifr" -let _ = Hashtbl.replace utf82macro "\240\157\149\147" "bopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\167" "jfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\148" "copf" -let _ = Hashtbl.replace utf82macro "\240\157\148\168" "kfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\149" "dopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\169" "lfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\150" "eopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\170" "mfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\151" "fopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\171" "nfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\152" "gopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\172" "ofr" -let _ = Hashtbl.replace utf82macro "\240\157\149\153" "hopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\173" "pfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\154" "iopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\174" "qfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\155" "jopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\175" "rfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\156" "kopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\176" "sfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\157" "lopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\177" "tfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\158" "mopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\178" "ufr" -let _ = Hashtbl.replace utf82macro "\240\157\149\159" "nopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\179" "vfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\160" "oopf" -let _ = Hashtbl.replace utf82macro "tan" "tan" -let _ = Hashtbl.replace utf82macro "\240\157\148\180" "wfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\161" "popf" -let _ = Hashtbl.replace utf82macro "\240\157\148\181" "xfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\162" "qopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\182" "yfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\163" "ropf" -let _ = Hashtbl.replace utf82macro "\240\157\148\183" "zfr" -let _ = Hashtbl.replace utf82macro "\240\157\149\164" "sopf" -let _ = Hashtbl.replace utf82macro "\240\157\149\165" "topf" -let _ = Hashtbl.replace utf82macro "\240\157\148\184" "Aopf" -let _ = Hashtbl.replace utf82macro "\195\128" "Agrave" -let _ = Hashtbl.replace utf82macro "\240\157\149\166" "uopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\185" "Bopf" -let _ = Hashtbl.replace utf82macro "\195\129" "Aacute" -let _ = Hashtbl.replace utf82macro "\240\157\149\167" "vopf" -let _ = Hashtbl.replace utf82macro "\195\130" "Acirc" -let _ = Hashtbl.replace utf82macro "\240\157\149\168" "wopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\187" "Dopf" -let _ = Hashtbl.replace utf82macro "\195\131" "Atilde" -let _ = Hashtbl.replace utf82macro "\240\157\149\169" "xopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\188" "Eopf" -let _ = Hashtbl.replace utf82macro "\195\132" "Auml" -let _ = Hashtbl.replace utf82macro "\240\157\149\170" "yopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\189" "Fopf" -let _ = Hashtbl.replace utf82macro "\195\133" "Aring" -let _ = Hashtbl.replace utf82macro "\240\157\149\171" "zopf" -let _ = Hashtbl.replace utf82macro "\240\157\148\190" "Gopf" -let _ = Hashtbl.replace utf82macro "\195\134" "AElig" -let _ = Hashtbl.replace utf82macro "\195\135" "Ccedil" -let _ = Hashtbl.replace utf82macro "\195\136" "Egrave" -let _ = Hashtbl.replace utf82macro "\195\137" "Eacute" -let _ = Hashtbl.replace utf82macro "\195\138" "Ecirc" -let _ = Hashtbl.replace utf82macro "\195\139" "Euml" -let _ = Hashtbl.replace utf82macro "\195\140" "Igrave" -let _ = Hashtbl.replace utf82macro "\194\160" "NonBreakingSpace" -let _ = Hashtbl.replace utf82macro "\195\141" "Iacute" -let _ = Hashtbl.replace utf82macro "\194\161" "iexcl" -let _ = Hashtbl.replace utf82macro "\195\142" "Icirc" -let _ = Hashtbl.replace utf82macro "\195\143" "Iuml" -let _ = Hashtbl.replace utf82macro "\194\162" "cent" -let _ = Hashtbl.replace utf82macro "\194\163" "pound" -let _ = Hashtbl.replace utf82macro "\195\144" "ETH" -let _ = Hashtbl.replace utf82macro "\195\145" "Ntilde" -let _ = Hashtbl.replace utf82macro "\194\164" "curren" -let _ = Hashtbl.replace utf82macro "\194\165" "yen" -let _ = Hashtbl.replace utf82macro "\195\146" "Ograve" -let _ = Hashtbl.replace utf82macro "\195\147" "Oacute" -let _ = Hashtbl.replace utf82macro "\194\166" "brvbar" -let _ = Hashtbl.replace utf82macro "\196\128" "Amacr" -let _ = Hashtbl.replace utf82macro "\194\167" "sect" -let _ = Hashtbl.replace utf82macro "\195\148" "Ocirc" -let _ = Hashtbl.replace utf82macro "\196\129" "amacr" -let _ = Hashtbl.replace utf82macro "\195\149" "Otilde" -let _ = Hashtbl.replace utf82macro "\194\168" "uml" -let _ = Hashtbl.replace utf82macro "\196\130" "Abreve" -let _ = Hashtbl.replace utf82macro "\195\150" "Ouml" -let _ = Hashtbl.replace utf82macro "\194\169" "copy" -let _ = Hashtbl.replace utf82macro "\196\131" "abreve" -let _ = Hashtbl.replace utf82macro "\195\151" "times" -let _ = Hashtbl.replace utf82macro "\194\170" "ordf" -let _ = Hashtbl.replace utf82macro "\196\132" "Aogon" -let _ = Hashtbl.replace utf82macro "\195\152" "Oslash" -let _ = Hashtbl.replace utf82macro "\194\171" "laquo" -let _ = Hashtbl.replace utf82macro "\196\133" "aogon" -let _ = Hashtbl.replace utf82macro "\195\153" "Ugrave" -let _ = Hashtbl.replace utf82macro "\194\172" "lnot" -let _ = Hashtbl.replace utf82macro "\196\134" "Cacute" -let _ = Hashtbl.replace utf82macro "\195\154" "Uacute" -let _ = Hashtbl.replace utf82macro "\194\173" "shy" -let _ = Hashtbl.replace utf82macro "\196\135" "cacute" -let _ = Hashtbl.replace utf82macro "\195\155" "Ucirc" -let _ = Hashtbl.replace utf82macro "\194\174" "reg" -let _ = Hashtbl.replace utf82macro "\196\136" "Ccirc" -let _ = Hashtbl.replace utf82macro "\195\156" "Uuml" -let _ = Hashtbl.replace utf82macro "\194\175" "OverBar" -let _ = Hashtbl.replace utf82macro "\196\137" "ccirc" -let _ = Hashtbl.replace utf82macro "\195\157" "Yacute" -let _ = Hashtbl.replace utf82macro "\194\176" "deg" -let _ = Hashtbl.replace utf82macro "\196\138" "Cdot" -let _ = Hashtbl.replace utf82macro "\195\158" "THORN" -let _ = Hashtbl.replace utf82macro "\194\177" "pm" -let _ = Hashtbl.replace utf82macro "\196\139" "cdot" -let _ = Hashtbl.replace utf82macro "\195\159" "szlig" -let _ = Hashtbl.replace utf82macro "\194\178" "sup2" -let _ = Hashtbl.replace utf82macro "\196\140" "Ccaron" -let _ = Hashtbl.replace utf82macro "\194\179" "sup3" -let _ = Hashtbl.replace utf82macro "\196\141" "ccaron" -let _ = Hashtbl.replace utf82macro "\195\160" "agrave" -let _ = Hashtbl.replace utf82macro "\196\142" "Dcaron" -let _ = Hashtbl.replace utf82macro "\194\180" "DiacriticalAcute" -let _ = Hashtbl.replace utf82macro "\195\161" "aacute" -let _ = Hashtbl.replace utf82macro "\194\181" "micro" -let _ = Hashtbl.replace utf82macro "\196\143" "dcaron" -let _ = Hashtbl.replace utf82macro "\195\162" "acirc" -let _ = Hashtbl.replace utf82macro "\194\182" "para" -let _ = Hashtbl.replace utf82macro "\196\144" "Dstrok" -let _ = Hashtbl.replace utf82macro "\195\163" "atilde" -let _ = Hashtbl.replace utf82macro "\196\145" "dstrok" -let _ = Hashtbl.replace utf82macro "\194\183" "middot" -let _ = Hashtbl.replace utf82macro "\195\164" "auml" -let _ = Hashtbl.replace utf82macro "\196\146" "Emacr" -let _ = Hashtbl.replace utf82macro "\194\184" "Cedilla" -let _ = Hashtbl.replace utf82macro "\195\165" "aring" -let _ = Hashtbl.replace utf82macro "\194\185" "sup1" -let _ = Hashtbl.replace utf82macro "\197\128" "lmidot" -let _ = Hashtbl.replace utf82macro "\196\147" "emacr" -let _ = Hashtbl.replace utf82macro "\195\166" "aelig" -let _ = Hashtbl.replace utf82macro "\194\186" "ordm" -let _ = Hashtbl.replace utf82macro "\197\129" "Lstrok" -let _ = Hashtbl.replace utf82macro "\195\167" "ccedil" -let _ = Hashtbl.replace utf82macro "\194\187" "raquo" -let _ = Hashtbl.replace utf82macro "\197\130" "lstrok" -let _ = Hashtbl.replace utf82macro "\195\168" "egrave" -let _ = Hashtbl.replace utf82macro "\197\131" "Nacute" -let _ = Hashtbl.replace utf82macro "\194\188" "frac14" -let _ = Hashtbl.replace utf82macro "\196\150" "Edot" -let _ = Hashtbl.replace utf82macro "\195\169" "eacute" -let _ = Hashtbl.replace utf82macro "\197\132" "nacute" -let _ = Hashtbl.replace utf82macro "\194\189" "half" -let _ = Hashtbl.replace utf82macro "\196\151" "edot" -let _ = Hashtbl.replace utf82macro "\195\170" "ecirc" -let _ = Hashtbl.replace utf82macro "\197\133" "Ncedil" -let _ = Hashtbl.replace utf82macro "\194\190" "frac34" -let _ = Hashtbl.replace utf82macro "\195\171" "euml" -let _ = Hashtbl.replace utf82macro "\196\152" "Eogon" -let _ = Hashtbl.replace utf82macro "\197\134" "ncedil" -let _ = Hashtbl.replace utf82macro "\194\191" "iquest" -let _ = Hashtbl.replace utf82macro "\195\172" "igrave" -let _ = Hashtbl.replace utf82macro "\196\153" "eogon" -let _ = Hashtbl.replace utf82macro "limsup" "limsup" -let _ = Hashtbl.replace utf82macro "\197\135" "Ncaron" -let _ = Hashtbl.replace utf82macro "\195\173" "iacute" -let _ = Hashtbl.replace utf82macro "\196\154" "Ecaron" -let _ = Hashtbl.replace utf82macro "\197\136" "ncaron" -let _ = Hashtbl.replace utf82macro "\195\174" "icirc" -let _ = Hashtbl.replace utf82macro "\196\155" "ecaron" -let _ = Hashtbl.replace utf82macro "\197\137" "napos" -let _ = Hashtbl.replace utf82macro "\195\175" "iuml" -let _ = Hashtbl.replace utf82macro "\196\156" "Gcirc" -let _ = Hashtbl.replace utf82macro "\196\157" "gcirc" -let _ = Hashtbl.replace utf82macro "\195\176" "eth" -let _ = Hashtbl.replace utf82macro "\197\138" "ENG" -let _ = Hashtbl.replace utf82macro "\195\177" "ntilde" -let _ = Hashtbl.replace utf82macro "\196\158" "Gbreve" -let _ = Hashtbl.replace utf82macro "\197\139" "eng" -let _ = Hashtbl.replace utf82macro "\197\140" "Omacr" -let _ = Hashtbl.replace utf82macro "\195\178" "ograve" -let _ = Hashtbl.replace utf82macro "\196\159" "gbreve" -let _ = Hashtbl.replace utf82macro "\197\141" "omacr" -let _ = Hashtbl.replace utf82macro "\195\179" "oacute" -let _ = Hashtbl.replace utf82macro "\196\160" "Gdot" -let _ = Hashtbl.replace utf82macro "\195\180" "ocirc" -let _ = Hashtbl.replace utf82macro "\196\161" "gdot" -let _ = Hashtbl.replace utf82macro "\195\181" "otilde" -let _ = Hashtbl.replace utf82macro "\196\162" "Gcedil" -let _ = Hashtbl.replace utf82macro "\195\182" "ouml" -let _ = Hashtbl.replace utf82macro "\197\144" "Odblac" -let _ = Hashtbl.replace utf82macro "\197\145" "odblac" -let _ = Hashtbl.replace utf82macro "\196\164" "Hcirc" -let _ = Hashtbl.replace utf82macro "\195\183" "div" -let _ = Hashtbl.replace utf82macro "\195\184" "oslash" -let _ = Hashtbl.replace utf82macro "\197\146" "OElig" -let _ = Hashtbl.replace utf82macro "\196\165" "hcirc" -let _ = Hashtbl.replace utf82macro "\195\185" "ugrave" -let _ = Hashtbl.replace utf82macro "\197\147" "oelig" -let _ = Hashtbl.replace utf82macro "\196\166" "Hstrok" -let _ = Hashtbl.replace utf82macro "\195\186" "uacute" -let _ = Hashtbl.replace utf82macro "\197\148" "Racute" -let _ = Hashtbl.replace utf82macro "\196\167" "hstrok" -let _ = Hashtbl.replace utf82macro "\195\187" "ucirc" -let _ = Hashtbl.replace utf82macro "\197\149" "racute" -let _ = Hashtbl.replace utf82macro "\196\168" "Itilde" -let _ = Hashtbl.replace utf82macro "\195\188" "uuml" -let _ = Hashtbl.replace utf82macro "\197\150" "Rcedil" -let _ = Hashtbl.replace utf82macro "\196\169" "itilde" -let _ = Hashtbl.replace utf82macro "\195\189" "yacute" -let _ = Hashtbl.replace utf82macro "\197\151" "rcedil" -let _ = Hashtbl.replace utf82macro "\196\170" "Imacr" -let _ = Hashtbl.replace utf82macro "\195\190" "thorn" -let _ = Hashtbl.replace utf82macro "\197\152" "Rcaron" -let _ = Hashtbl.replace utf82macro "\196\171" "imacr" -let _ = Hashtbl.replace utf82macro "\195\191" "yuml" -let _ = Hashtbl.replace utf82macro "\197\153" "rcaron" -let _ = Hashtbl.replace utf82macro "\197\154" "Sacute" -let _ = Hashtbl.replace utf82macro "\197\155" "sacute" -let _ = Hashtbl.replace utf82macro "\196\174" "Iogon" -let _ = Hashtbl.replace utf82macro "\197\156" "Scirc" -let _ = Hashtbl.replace utf82macro "\196\175" "iogon" -let _ = Hashtbl.replace utf82macro "\197\157" "scirc" -let _ = Hashtbl.replace utf82macro "\196\176" "Idot" -let _ = Hashtbl.replace utf82macro "\197\158" "Scedil" -let _ = Hashtbl.replace utf82macro "\196\177" "imath" -let _ = Hashtbl.replace utf82macro "\197\159" "scedil" -let _ = Hashtbl.replace utf82macro "\196\178" "IJlig" -let _ = Hashtbl.replace utf82macro "\197\160" "Scaron" -let _ = Hashtbl.replace utf82macro "\196\179" "ijlig" -let _ = Hashtbl.replace utf82macro "\197\161" "scaron" -let _ = Hashtbl.replace utf82macro "\196\180" "Jcirc" -let _ = Hashtbl.replace utf82macro "\197\162" "Tcedil" -let _ = Hashtbl.replace utf82macro "\196\181" "jcirc" -let _ = Hashtbl.replace utf82macro "\197\163" "tcedil" -let _ = Hashtbl.replace utf82macro "\196\182" "Kcedil" -let _ = Hashtbl.replace utf82macro "\197\164" "Tcaron" -let _ = Hashtbl.replace utf82macro "\226\128\138\239\184\128" "NegativeVeryThinSpace" -let _ = Hashtbl.replace utf82macro "\196\183" "kcedil" -let _ = Hashtbl.replace utf82macro "\197\165" "tcaron" -let _ = Hashtbl.replace utf82macro "\196\184" "kgreen" -let _ = Hashtbl.replace utf82macro "\198\146" "fnof" -let _ = Hashtbl.replace utf82macro "\197\166" "Tstrok" -let _ = Hashtbl.replace utf82macro "\196\185" "Lacute" -let _ = Hashtbl.replace utf82macro "\197\167" "tstrok" -let _ = Hashtbl.replace utf82macro "\196\186" "lacute" -let _ = Hashtbl.replace utf82macro "\197\168" "Utilde" -let _ = Hashtbl.replace utf82macro "\196\187" "Lcedil" -let _ = Hashtbl.replace utf82macro "\197\169" "utilde" -let _ = Hashtbl.replace utf82macro "\226\137\143\204\184" "NotHumpEqual" -let _ = Hashtbl.replace utf82macro "\196\188" "lcedil" -let _ = Hashtbl.replace utf82macro "\197\170" "Umacr" -let _ = Hashtbl.replace utf82macro "\196\189" "Lcaron" -let _ = Hashtbl.replace utf82macro "\197\171" "umacr" -let _ = Hashtbl.replace utf82macro "\196\190" "lcaron" -let _ = Hashtbl.replace utf82macro "\197\172" "Ubreve" -let _ = Hashtbl.replace utf82macro "\196\191" "Lmidot" -let _ = Hashtbl.replace utf82macro "\197\173" "ubreve" -let _ = Hashtbl.replace utf82macro "\197\174" "Uring" -let _ = Hashtbl.replace utf82macro "\197\175" "uring" -let _ = Hashtbl.replace utf82macro "\197\176" "Udblac" -let _ = Hashtbl.replace utf82macro "\197\177" "udblac" -let _ = Hashtbl.replace utf82macro "\197\178" "Uogon" -let _ = Hashtbl.replace utf82macro "\197\179" "uogon" -let _ = Hashtbl.replace utf82macro "\197\180" "Wcirc" -let _ = Hashtbl.replace utf82macro "\197\181" "wcirc" -let _ = Hashtbl.replace utf82macro "\197\182" "Ycirc" -let _ = Hashtbl.replace utf82macro "\197\183" "ycirc" -let _ = Hashtbl.replace utf82macro "\197\184" "Yuml" -let _ = Hashtbl.replace utf82macro "\197\185" "Zacute" -let _ = Hashtbl.replace utf82macro "\197\186" "zacute" -let _ = Hashtbl.replace utf82macro "\197\187" "Zdot" -let _ = Hashtbl.replace utf82macro "\197\188" "zdot" -let _ = Hashtbl.replace utf82macro "\197\189" "Zcaron" -let _ = Hashtbl.replace utf82macro "\197\190" "zcaron" -let _ = Hashtbl.replace utf82macro "\226\136\163\239\184\128" "smid" -let _ = Hashtbl.replace utf82macro "\239\184\181" "OverParenthesis" -let _ = Hashtbl.replace utf82macro "\239\184\182" "UnderParenthesis" -let _ = Hashtbl.replace utf82macro "\239\184\183" "OverBrace" -let _ = Hashtbl.replace utf82macro "\239\184\184" "UnderBrace" -let _ = Hashtbl.replace utf82macro "\199\181" "gacute" -let _ = Hashtbl.replace utf82macro "cos" "cos" -let _ = Hashtbl.replace utf82macro "\226\136\170\239\184\128" "cups" -let _ = Hashtbl.replace utf82macro "cot" "cot" -let _ = Hashtbl.replace utf82macro "\201\155" "varepsilon" -let _ = Hashtbl.replace utf82macro "\226\138\139\239\184\128" "vsupnE" -let _ = Hashtbl.replace utf82macro "\203\135" "Hacek" diff --git a/helm/ocaml/whelp/.depend b/helm/ocaml/whelp/.depend deleted file mode 100644 index 39f37dfa9..000000000 --- a/helm/ocaml/whelp/.depend +++ /dev/null @@ -1,4 +0,0 @@ -whelp.cmo: whelp.cmi -whelp.cmx: whelp.cmi -fwdQueries.cmo: fwdQueries.cmi -fwdQueries.cmx: fwdQueries.cmi diff --git a/helm/ocaml/whelp/Makefile b/helm/ocaml/whelp/Makefile deleted file mode 100644 index 6d8d3958f..000000000 --- a/helm/ocaml/whelp/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -PACKAGE = whelp - -INTERFACE_FILES = \ - whelp.mli \ - fwdQueries.mli \ - $(NULL) - -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/whelp/fwdQueries.ml b/helm/ocaml/whelp/fwdQueries.ml deleted file mode 100644 index 1f4e508fc..000000000 --- a/helm/ocaml/whelp/fwdQueries.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -(* fwd_simpl ****************************************************************) - -let rec filter_map_n f n = function - | [] -> [] - | hd :: tl -> - match f n hd with - | None -> filter_map_n f (succ n) tl - | Some hd -> hd :: filter_map_n f (succ n) tl - -let get_uri t = - let aux = function - | Cic.Appl (hd :: tl) -> Some (CicUtil.uri_of_term hd, tl) - | hd -> Some (CicUtil.uri_of_term hd, []) - in - try aux t with - | Invalid_argument "uri_of_term" -> None - -let get_metadata t = - let f n t = - match get_uri t with - | None -> None - | Some (uri, _) -> Some (n, uri) - in - match get_uri t with - | None -> None - | Some (uri, args) -> Some (uri, filter_map_n f 1 args) - -let debug_metadata = function - | None -> () - | Some (outer, inners) -> - let f (n, uri) = Printf.eprintf "%s: %i %s\n" "fwd" n (UriManager.string_of_uri uri) in - Printf.eprintf "\n%s: %s\n" "fwd" (UriManager.string_of_uri outer); - List.iter f inners; prerr_newline () - -let fwd_simpl ~dbd t = - let map inners row = - match row.(0), row.(1), row.(2) with - | Some source, Some inner, Some index -> - source, - List.mem - (int_of_string index, (UriManager.uri_of_string inner)) inners - | _ -> "", false - in - let rec rank ranks (source, ok) = - match ranks, ok with - | [], false -> [source, 0] - | [], true -> [source, 1] - | (uri, i) :: tl, false when uri = source -> (uri, 0) :: tl - | (uri, 0) :: tl, true when uri = source -> (uri, 0) :: tl - | (uri, i) :: tl, true when uri = source -> (uri, succ i) :: tl - | hd :: tl, _ -> hd :: rank tl (source, ok) - in - let compare (_, x) (_, y) = compare x y in - let filter n (uri, rank) = - if rank > 0 then Some (UriManager.uri_of_string uri) else None - in - let metadata = get_metadata t in debug_metadata metadata; - match metadata with - | None -> [] - | Some (outer, inners) -> - let select = "source, h_inner, h_index" in - let from = "genLemma" in - let where = - Printf.sprintf "h_outer = \"%s\"" - (HMysql.escape (UriManager.string_of_uri outer)) in - let query = Printf.sprintf "SELECT %s FROM %s WHERE %s" select from where in - let result = HMysql.exec dbd query in - let lemmas = HMysql.map ~f:(map inners) result in - let ranked = List.fold_left rank [] lemmas in - let ordered = List.rev (List.fast_sort compare ranked) in - filter_map_n filter 0 ordered - -(* get_decomposables ********************************************************) - -let decomposables ~dbd = - let map row = match row.(0) with - | None -> None - | Some str -> - match CicUtil.term_of_uri (UriManager.uri_of_string str) with - | Cic.MutInd (uri, typeno, _) -> Some (uri, typeno) - | _ -> - raise (UriManager.IllFormedUri str) - in - let select, from = "source", "decomposables" in - let query = Printf.sprintf "SELECT %s FROM %s" select from in - let decomposables = HMysql.map ~f:map (HMysql.exec dbd query) in - filter_map_n (fun _ x -> x) 0 decomposables - diff --git a/helm/ocaml/whelp/fwdQueries.mli b/helm/ocaml/whelp/fwdQueries.mli deleted file mode 100644 index 7f580a541..000000000 --- a/helm/ocaml/whelp/fwdQueries.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val fwd_simpl: dbd:HMysql.dbd -> Cic.term -> UriManager.uri list -val decomposables: dbd:HMysql.dbd -> (UriManager.uri * int) list - diff --git a/helm/ocaml/whelp/whelp.ml b/helm/ocaml/whelp/whelp.ml deleted file mode 100644 index 5e63bcfc4..000000000 --- a/helm/ocaml/whelp/whelp.ml +++ /dev/null @@ -1,215 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let nonvar uri = not (UriManager.uri_is_var uri) - - (** maps a shell like pattern (which uses '*' and '?') to a sql pattern for - * the "like" operator (which uses '%' and '_'). Does not support escaping. *) -let sqlpat_of_shellglob = - let star_RE, qmark_RE, percent_RE, uscore_RE = - Pcre.regexp "\\*", Pcre.regexp "\\?", Pcre.regexp "%", Pcre.regexp "_" - in - fun shellglob -> - Pcre.replace ~rex:star_RE ~templ:"%" - (Pcre.replace ~rex:qmark_RE ~templ:"_" - (Pcre.replace ~rex:percent_RE ~templ:"\\%" - (Pcre.replace ~rex:uscore_RE ~templ:"\\_" - shellglob))) - -let locate ~(dbd:HMysql.dbd) ?(vars = false) pat = - let sql_pat = sqlpat_of_shellglob pat in - let query = - sprintf ("SELECT source FROM %s WHERE value LIKE \"%s\" UNION "^^ - "SELECT source FROM %s WHERE value LIKE \"%s\"") - (MetadataTypes.name_tbl ()) sql_pat - MetadataTypes.library_name_tbl sql_pat - in - let result = HMysql.exec dbd query in - List.filter nonvar - (HMysql.map result - (fun cols -> match cols.(0) with Some s -> UriManager.uri_of_string s | _ -> assert false)) - -let match_term ~(dbd:HMysql.dbd) ty = -(* debug_print (lazy (CicPp.ppterm ty)); *) - let metadata = MetadataExtractor.compute ~body:None ~ty in - let constants_no = - MetadataConstraints.UriManagerSet.cardinal (MetadataConstraints.constants_of ty) - in - let full_card, diff = - if CicUtil.is_meta_closed ty then - Some (MetadataConstraints.Eq constants_no), None - else - let diff_no = - let (hyp_constants, concl_constants) = - (* collect different constants in hypotheses and conclusions *) - List.fold_left - (fun ((hyp, concl) as acc) metadata -> - match (metadata: MetadataTypes.metadata) with - | `Sort _ | `Rel _ -> acc - | `Obj (uri, `InConclusion) | `Obj (uri, `MainConclusion _) - when not (List.mem uri concl) -> (hyp, uri :: concl) - | `Obj (uri, `InHypothesis) | `Obj (uri, `MainHypothesis _) - when not (List.mem uri hyp) -> (uri :: hyp, concl) - | `Obj _ -> acc) - ([], []) - metadata - in - List.length hyp_constants - List.length concl_constants - in - let (concl_metas, hyp_metas) = MetadataExtractor.compute_metas ty in - let diff = - if MetadataExtractor.IntSet.equal concl_metas hyp_metas then - Some (MetadataConstraints.Eq diff_no) - else if MetadataExtractor.IntSet.subset concl_metas hyp_metas then - Some (MetadataConstraints.Gt (diff_no - 1)) - else if MetadataExtractor.IntSet.subset hyp_metas concl_metas then - Some (MetadataConstraints.Lt (diff_no + 1)) - else - None - in - None, diff - in - let constraints = List.map MetadataTypes.constr_of_metadata metadata in - MetadataConstraints.at_least ~dbd ?full_card ?diff constraints - -let fill_with_dummy_constants t = - let rec aux i types = - function - Cic.Lambda (n,s,t) -> - let dummy_uri = - UriManager.uri_of_string ("cic:/dummy_"^(string_of_int i)^".con") in - (aux (i+1) (s::types) - (CicSubstitution.subst (Cic.Const(dummy_uri,[])) t)) - | t -> t,types - in - let t,types = aux 0 [] t in - t, List.rev types - -let instance ~dbd t = - let t',types = fill_with_dummy_constants t in - let metadata = MetadataExtractor.compute ~body:None ~ty:t' in -(* List.iter - (fun x -> - debug_print - (lazy (MetadataPp.pp_constr (MetadataTypes.constr_of_metadata x)))) - metadata; *) - let no_concl = MetadataDb.count_distinct `Conclusion metadata in - let no_hyp = MetadataDb.count_distinct `Hypothesis metadata in - let no_full = MetadataDb.count_distinct `Statement metadata in - let is_dummy = function - | `Obj(s, _) -> (String.sub (UriManager.string_of_uri s) 0 10) <> "cic:/dummy" - | _ -> true - in - let rec look_for_dummy_main = function - | [] -> None - | `Obj(s,`MainConclusion (Some (MetadataTypes.Eq d)))::_ - when (String.sub (UriManager.string_of_uri s) 0 10 = "cic:/dummy") -> - let s = UriManager.string_of_uri s in - let len = String.length s in - let dummy_index = int_of_string (String.sub s 11 (len-15)) in - let dummy_type = List.nth types dummy_index in - Some (d,dummy_type) - | _::l -> look_for_dummy_main l - in - match (look_for_dummy_main metadata) with - | None-> -(* debug_print (lazy "Caso None"); *) - (* no dummy in main position *) - let metadata = List.filter is_dummy metadata in - let constraints = List.map MetadataTypes.constr_of_metadata metadata in - let concl_card = Some (MetadataConstraints.Eq no_concl) in - let full_card = Some (MetadataConstraints.Eq no_full) in - let diff = Some (MetadataConstraints.Eq (no_hyp - no_concl)) in - MetadataConstraints.at_least ~dbd ?concl_card ?full_card ?diff - constraints - | Some (depth, dummy_type) -> -(* debug_print - (lazy (sprintf "Caso Some %d %s" depth (CicPp.ppterm dummy_type))); *) - (* a dummy in main position *) - let metadata_for_dummy_type = - MetadataExtractor.compute ~body:None ~ty:dummy_type in - (* Let us skip this for the moment - let main_of_dummy_type = - look_for_dummy_main metadata_for_dummy_type in *) - let metadata = List.filter is_dummy metadata in - let constraints = List.map MetadataTypes.constr_of_metadata metadata in - let metadata_for_dummy_type = - List.filter is_dummy metadata_for_dummy_type in - let metadata_for_dummy_type, depth' = - (* depth' = the depth of the A -> A -> Prop *) - List.fold_left (fun (acc,dep) c -> - match c with - | `Sort (s,`MainConclusion (Some (MetadataTypes.Eq i))) -> - (`Sort (s,`MainConclusion (Some (MetadataTypes.Ge i))))::acc, i - | `Obj (s,`MainConclusion (Some (MetadataTypes.Eq i))) -> - (`Obj (s,`MainConclusion (Some (MetadataTypes.Ge i))))::acc, i - | `Rel (`MainConclusion (Some (MetadataTypes.Eq i))) -> - (`Rel (`MainConclusion (Some (MetadataTypes.Ge i))))::acc, i - | _ -> (c::acc,dep)) ([],0) metadata_for_dummy_type - in - let constraints_for_dummy_type = - List.map MetadataTypes.constr_of_metadata metadata_for_dummy_type in - (* start with the dummy constant in main conlusion *) - let from = ["refObj as table0"] in - let where = - [sprintf "table0.h_position = \"%s\"" MetadataTypes.mainconcl_pos; - sprintf "table0.h_depth >= %d" depth] in - let (n,from,where) = - List.fold_left - (MetadataConstraints.add_constraint ~start:2) - (2,from,where) constraints in - let concl_card = Some (MetadataConstraints.Eq no_concl) in - let full_card = Some (MetadataConstraints.Eq no_full) in - let diff = Some (MetadataConstraints.Eq (no_hyp - no_concl)) in - let (n,from,where) = - MetadataConstraints.add_all_constr - (n,from,where) concl_card full_card diff in - (* join with the constraints over the type of the constant *) - let where = - (sprintf "table0.h_occurrence = table%d.source" n)::where in - let where = - sprintf "table0.h_depth - table%d.h_depth = %d" - n (depth - depth')::where - in - let (m,from,where) = - List.fold_left - (MetadataConstraints.add_constraint ~start:n) - (n,from,where) constraints_for_dummy_type in - MetadataConstraints.exec ~dbd (m,from,where) - -let elim ~dbd uri = - let constraints = - [`Rel [`MainConclusion None]; - `Sort (Cic.Prop,[`MainHypothesis (Some (MetadataTypes.Ge 1))]); - `Obj (uri,[`MainHypothesis (Some (MetadataTypes.Eq 0))]); - `Obj (uri,[`InHypothesis]); - ] - in - MetadataConstraints.at_least ~rating:`Hits ~dbd constraints - diff --git a/helm/ocaml/whelp/whelp.mli b/helm/ocaml/whelp/whelp.mli deleted file mode 100644 index 9ff03ea20..000000000 --- a/helm/ocaml/whelp/whelp.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2005, 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://helm.cs.unibo.it/ - *) - -val locate: dbd:HMysql.dbd -> ?vars:bool -> string -> UriManager.uri list -val elim: dbd:HMysql.dbd -> UriManager.uri -> UriManager.uri list -val instance: dbd:HMysql.dbd -> Cic.term -> UriManager.uri list -val match_term: dbd:HMysql.dbd -> Cic.term -> UriManager.uri list - diff --git a/helm/ocaml/xml/.depend b/helm/ocaml/xml/.depend deleted file mode 100644 index 5ef59bdc9..000000000 --- a/helm/ocaml/xml/.depend +++ /dev/null @@ -1,4 +0,0 @@ -xml.cmo: xml.cmi -xml.cmx: xml.cmi -xmlPushParser.cmo: xmlPushParser.cmi -xmlPushParser.cmx: xmlPushParser.cmi diff --git a/helm/ocaml/xml/Makefile b/helm/ocaml/xml/Makefile deleted file mode 100644 index 7948435aa..000000000 --- a/helm/ocaml/xml/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -PACKAGE = xml -PREDICATES = - -INTERFACE_FILES = \ - xml.mli \ - xmlPushParser.mli -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/xml/test.ml b/helm/ocaml/xml/test.ml deleted file mode 100644 index 84c042e28..000000000 --- a/helm/ocaml/xml/test.ml +++ /dev/null @@ -1,60 +0,0 @@ -(* $Id$ *) - -(* Parsing test: - * - XmlPushParser version *) -open Printf -open XmlPushParser - -let print s = print_endline s; flush stdout - -let callbacks = - { default_callbacks with - start_element = - Some (fun tag attrs -> - let length = List.length attrs in - print (sprintf "opening %s [%s]" - tag (String.concat ";" (List.map fst attrs)))); - end_element = Some (fun tag -> print ("closing " ^ tag)); - character_data = Some (fun data -> print "character data ..."); - } - -let xml_parser = create_parser callbacks - -let is_gzip f = - try - let len = String.length f in - String.sub f (len - 3) 3 = ".gz" - with Invalid_argument _ -> false - -let _ = - let xml_source = - if is_gzip Sys.argv.(1) then - `Gzip_file Sys.argv.(1) - else - `File Sys.argv.(1) - in - parse xml_parser xml_source - -(* Parsing test: - * - Pure expat version (without XmlPushParser mediation). - * Originally written only to test if XmlPushParser mediation caused overhead. - * That was not the case. *) - -(*let _ =*) -(* let ic = open_in Sys.argv.(1) in*) -(* let expat_parser = Expat.parser_create ~encoding:None in*) -(* Expat.set_start_element_handler expat_parser*) -(* (fun tag attrs ->*) -(* let length = List.length attrs in*) -(* print (sprintf "opening %s [%d attribute%s]"*) -(* tag length (if length = 1 then "" else "s")));*) -(* Expat.set_end_element_handler expat_parser*) -(* (fun tag -> print ("closing " ^ tag));*) -(* Expat.set_character_data_handler expat_parser*) -(* (fun data -> print "character data ...");*) -(* try*) -(* while true do*) -(* Expat.parse expat_parser (input_line ic ^ "\n")*) -(* done*) -(* with End_of_file -> Expat.final expat_parser*) - diff --git a/helm/ocaml/xml/xml.ml b/helm/ocaml/xml/xml.ml deleted file mode 100644 index f8cc41cbe..000000000 --- a/helm/ocaml/xml/xml.ml +++ /dev/null @@ -1,177 +0,0 @@ -(* 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 *) -(* *) -(* A tactic to print Coq objects in XML *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 18/10/2000 *) -(* *) -(* This module defines a pretty-printer and the stream of commands to the pp *) -(* *) -(******************************************************************************) - -(* $Id$ *) - - -(* the type token for XML cdata, empty elements and not-empty elements *) -(* Usage: *) -(* Str cdata *) -(* Empty (prefix, element_name, *) -(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen] *) -(* NEmpty (prefix, element_name, *) -(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen], *) -(* content *) -type token = - Str of string - | Empty of string option * string * (string option * string * string) list - | NEmpty of string option * string * (string option * string * string) list * - token Stream.t -;; - -(* currified versions of the constructors make the code more readable *) -let xml_empty ?prefix name attrs = - [< 'Empty(prefix,name,attrs) >] -let xml_nempty ?prefix name attrs content = - [< 'NEmpty(prefix,name,attrs,content) >] -let xml_cdata str = - [< 'Str str >] - -(** 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 pprefix = - function - None -> "" - | Some p -> p ^ ":" in - let rec pp_r m = - parser - | [< 'Str a ; s >] -> - print_spaces m ; - f (a ^ "\n") ; - pp_r m s - | [< 'Empty(p,n,l) ; s >] -> - print_spaces m ; - f ("<" ^ (pprefix p) ^ n) ; - List.iter (fun (p,n,v) -> f (" " ^ (pprefix p) ^ n ^ "=\"" ^ v ^ "\"")) l; - f "/>\n" ; - pp_r m s - | [< 'NEmpty(p,n,l,c) ; s >] -> - print_spaces m ; - f ("<" ^ (pprefix p) ^ n) ; - List.iter (fun (p,n,v) -> f (" " ^ (pprefix p) ^ n ^ "=\"" ^ v ^ "\"")) l; - f ">\n" ; - pp_r (m+1) c ; - print_spaces m ; - f ("\n") ; - pp_r m s - | [< >] -> () - and print_spaces m = - 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 -;; - -let pp_to_gzipchan strm oc = - pp_gen (fun s -> Gzip.output oc s 0 (String.length s)) strm -;; - -(** 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 ?(gzip=false) strm fn = - if gzip then - match fn with - | Some filename -> - let outchan = Gzip.open_out filename in - (try - pp_to_gzipchan strm outchan; - with e -> - Gzip.close_out outchan; - raise e); - Gzip.close_out outchan - | None -> failwith "Can't sent gzipped output to stdout" - else - match fn with - | Some filename -> - let outchan = open_out filename in - (try - pp_to_outchan strm outchan; - with e -> - close_out outchan; - raise e); - close_out outchan - | None -> pp_to_outchan strm stdout -;; - -let pp = - let profiler = HExtlib.profile "Xml.pp" in - fun ?gzip strm fn -> - profiler.HExtlib.profile (pp ?gzip strm) fn -;; - -let add_xml_declaration stream = - let box_prefix = "b" in - [< - xml_cdata "\n" ; - xml_cdata "\n"; - xml_nempty ~prefix:box_prefix "box" - [ Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ; - Some "xmlns","b","http://helm.cs.unibo.it/2003/BoxML" ; - Some "xmlns","helm","http://www.cs.unibo.it/helm" ; - Some "xmlns","xlink","http://www.w3.org/1999/xlink" - ] stream - >] - - (* 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 s = - let rec aux n pos = - if n = 0 - then String.sub s pos (String.length s - pos) - else aux (n - 1) (String.index_from s pos '\n' + 1) - in - try - aux 4 0 - with Not_found -> s - diff --git a/helm/ocaml/xml/xml.mli b/helm/ocaml/xml/xml.mli deleted file mode 100644 index 4feca7503..000000000 --- a/helm/ocaml/xml/xml.mli +++ /dev/null @@ -1,75 +0,0 @@ -(* 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 *) -(* *) -(* A tactic to print Coq objects in XML *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 18/10/2000 *) -(* *) -(* This module defines a pretty-printer and the stream of commands to the pp *) -(* *) -(******************************************************************************) - -(* Tokens for XML cdata, empty elements and not-empty elements *) -(* Usage: *) -(* Str cdata *) -(* Empty (prefix, element_name, *) -(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen] *) -(* NEmpty (prefix, element_name, *) -(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen], *) -(* content *) -type token = - Str of string - | Empty of string option * string * (string option * string * string) list - | NEmpty of string option * string * (string option * string * string) list * - token Stream.t -;; - -(* currified versions of the token constructors make the code more readable *) -val xml_empty : - ?prefix:string -> string -> (string option * string * string) list -> - token Stream.t -val xml_nempty : - ?prefix:string -> string -> (string option * string * string) list -> - token Stream.t -> token Stream.t -val xml_cdata : string -> token Stream.t - -(* The pretty printer for streams of token *) -(* Usage: *) -(* pp tokens None pretty prints the output on stdout *) -(* pp tokens (Some filename) pretty prints the output on the file filename -* @param gzip if set to true files are gzipped. Defaults to false *) -val pp : ?gzip: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 - -val add_xml_declaration: token Stream.t -> token Stream.t - -val strip_xml_headings: string -> string - diff --git a/helm/ocaml/xml/xmlPushParser.ml b/helm/ocaml/xml/xmlPushParser.ml deleted file mode 100644 index 4f57e1242..000000000 --- a/helm/ocaml/xml/xmlPushParser.ml +++ /dev/null @@ -1,118 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let gzip_bufsize = 10240 - -type callbacks = { - start_element: (string -> (string * string) list -> unit) option; - end_element: (string -> unit) option; - character_data: (string -> unit) option; - processing_instruction: (string -> string -> unit) option; - comment: (string -> unit) option; -} - -let default_callbacks = { - start_element = None; - end_element = None; - character_data = None; - processing_instruction = None; - comment = None; -} - -type xml_source = - [ `Channel of in_channel - | `File of string - | `Gzip_channel of Gzip.in_channel - | `Gzip_file of string - | `String of string - ] - -type position = int * int - -type xml_parser = Expat.expat_parser - -exception Parse_error of string - -let create_parser callbacks = - let expat_parser = Expat.parser_create ~encoding:None in - (match callbacks.start_element with - | Some f -> Expat.set_start_element_handler expat_parser f - | _ -> ()); - (match callbacks.end_element with - | Some f -> Expat.set_end_element_handler expat_parser f - | _ -> ()); - (match callbacks.character_data with - | Some f -> Expat.set_character_data_handler expat_parser f - | _ -> ()); - (match callbacks.processing_instruction with - | Some f -> Expat.set_processing_instruction_handler expat_parser f - | _ -> ()); - (match callbacks.comment with - | Some f -> Expat.set_comment_handler expat_parser f - | _ -> ()); - expat_parser - -let final = Expat.final - -let get_position expat_parser = - (Expat.get_current_line_number expat_parser, - Expat.get_current_column_number expat_parser) - -let parse expat_parser = - let parse_fun = Expat.parse expat_parser in - let rec aux = function - | `Channel ic -> - (try - while true do parse_fun (input_line ic ^ "\n") done - with End_of_file -> final expat_parser) - | `File fname -> - let ic = open_in fname in - aux (`Channel ic); - close_in ic - | `Gzip_channel ic -> - let buf = String.create gzip_bufsize in - (try - while true do - let bytes = Gzip.input ic buf 0 gzip_bufsize in - if bytes = 0 then raise End_of_file; - parse_fun (String.sub buf 0 bytes) - done - with End_of_file -> final expat_parser) - | `Gzip_file fname -> - let ic = Gzip.open_in fname in - aux (`Gzip_channel ic); - Gzip.close_in ic - | `String s -> parse_fun s - in - aux - -let parse expat_parser xml_source = - try - parse expat_parser xml_source - with Expat.Expat_error xml_error -> - raise (Parse_error (Expat.xml_error_to_string xml_error)) - diff --git a/helm/ocaml/xml/xmlPushParser.mli b/helm/ocaml/xml/xmlPushParser.mli deleted file mode 100644 index c13481c91..000000000 --- a/helm/ocaml/xml/xmlPushParser.mli +++ /dev/null @@ -1,78 +0,0 @@ -(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ - *) - -(** {2 XLM push parser generic interface} - * Do not depend on CIC *) - - (** callbacks needed to instantiate a parser *) -type callbacks = { - start_element: - (string -> (string * string) list -> unit) option; (* tag, attr list *) - end_element: (string -> unit) option; (* tag *) - character_data: (string -> unit) option; (* data *) - processing_instruction: - (string -> string -> unit) option; (* target, value *) - comment: (string -> unit) option; (* value *) -} - - (** do nothing callbacks (all set to None) *) -val default_callbacks: callbacks - - (** source from which parse an XML file *) -type xml_source = - [ `Channel of in_channel - | `File of string - | `Gzip_channel of Gzip.in_channel - | `Gzip_file of string - | `String of string - ] - - (** source position in a XML source. - * A position is a pair *) -type position = int * int - -type xml_parser - - (** raised when a parse error occurs, argument is an error message. - * This exception carries no position information, but it should be get using - * get_position below *) -exception Parse_error of string - - (** Create a push parser which invokes the given callbacks *) -val create_parser: callbacks -> xml_parser - - (** Parse XML data from a given source with a given parser - * @raise Parse_error *) -val parse: xml_parser -> xml_source -> unit - - (** Inform the parser that parsing is completed, needed only when source is - * `String, for other sources it is automatically invoked when the end of file - * is reached - * @raise Parse_error *) -val final: xml_parser -> unit - - (** @return current pair *) -val get_position: xml_parser -> position - diff --git a/helm/ocaml/xmldiff/.depend b/helm/ocaml/xmldiff/.depend deleted file mode 100644 index e2832de33..000000000 --- a/helm/ocaml/xmldiff/.depend +++ /dev/null @@ -1,2 +0,0 @@ -xmlDiff.cmo: xmlDiff.cmi -xmlDiff.cmx: xmlDiff.cmi diff --git a/helm/ocaml/xmldiff/Makefile b/helm/ocaml/xmldiff/Makefile deleted file mode 100644 index afffaeefb..000000000 --- a/helm/ocaml/xmldiff/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -PACKAGE = xmldiff -PREDICATES = - -INTERFACE_FILES = xmlDiff.mli -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/helm/ocaml/xmldiff/xmlDiff.ml b/helm/ocaml/xmldiff/xmlDiff.ml deleted file mode 100644 index 6f68438e9..000000000 --- a/helm/ocaml/xmldiff/xmlDiff.ml +++ /dev/null @@ -1,345 +0,0 @@ -(* 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/. - *) - -(* $Id$ *) - -let mathmlns = "http://www.w3.org/1998/Math/MathML";; -let xmldiffns = "http://helm.cs.unibo.it/XmlDiff";; -let helmns = "http://www.cs.unibo.it/helm";; - -let ds_selection = Gdome.domString "selection";; -let ds_2 = Gdome.domString "2";; -let ds_mathmlns = Gdome.domString mathmlns;; -let ds_m_style = Gdome.domString "m:mstyle";; -let ds_mathbackground = Gdome.domString "mathbackground";; -let ds_xmldiffns = Gdome.domString xmldiffns;; -let ds_xmldiff_type = Gdome.domString "xmldiff:type";; -let ds_fake = Gdome.domString "fake";; -let ds_helmns = Gdome.domString helmns;; -let ds_xref = Gdome.domString "xref";; -let ds_type = Gdome.domString "type";; -let ds_yellow = Gdome.domString "yellow";; -let ds_green = Gdome.domString "#00ff00";; -let ds_maction = Gdome.domString "maction";; -let ds_mtr = Gdome.domString "mtr";; -let ds_mtd = Gdome.domString "mtd";; - -type highlighted_nodes = Gdome.node list;; - -let rec make_visible (n: Gdome.node) = - match n#get_parentNode with - None -> () - | Some p -> - match p#get_namespaceURI, p#get_localName with - Some nu, Some ln when - nu#equals ds_mathmlns && ln#equals ds_maction -> - (new Gdome.element_of_node p)#setAttribute - ~name:ds_selection - ~value:ds_2 ; - make_visible p - | _,_ -> make_visible p -;; - -let highlight_node_total_time = ref 0.0;; - -let highlight_node ?(color=ds_yellow) (doc: Gdome.document) (n: Gdome.node) = - let highlight (n: Gdome.node) = - let highlighter = - doc#createElementNS - ~namespaceURI:(Some ds_mathmlns) - ~qualifiedName:ds_m_style - in - highlighter#setAttribute ~name:ds_mathbackground ~value:color ; - highlighter#setAttributeNS - ~namespaceURI:(Some ds_xmldiffns) - ~qualifiedName:ds_xmldiff_type - ~value:ds_fake ; - let parent = - match n#get_parentNode with - None -> assert false - | Some p -> p - in - ignore - (parent#replaceChild ~oldChild:n ~newChild:(highlighter :> Gdome.node)) ; - ignore (highlighter#appendChild n) ; - (highlighter :> Gdome.node) - in - let rec find_mstylable_node n = - match n#get_namespaceURI, n#get_localName with - Some nu, Some ln when - nu#equals ds_mathmlns && - (not (ln#equals ds_mtr)) && (not (ln#equals ds_mtd)) -> n - | Some nu, Some ln when - nu#equals ds_mathmlns && - ln#equals ds_mtr || ln#equals ds_mtd -> - let true_child = - match n#get_firstChild with - None -> assert false - | Some n -> n - in - find_mstylable_node true_child - | _,_ -> - match n#get_parentNode with - None -> assert false - | Some p -> find_mstylable_node p - in - let highlighter = highlight (find_mstylable_node n) in - make_visible highlighter ; - highlighter -;; - -let iter_children ~f (n:Gdome.node) = - let rec aux = - function - None -> () - | Some n -> - let sibling = n#get_nextSibling in - (f n) ; - aux sibling - in - aux n#get_firstChild -;; - -let highlight_nodes ~xrefs (doc:Gdome.document) = - let highlighted = ref [] in - let rec aux (n:Gdome.element) = - let attributeNS = - (n#getAttributeNS ~namespaceURI:ds_helmns - ~localName:ds_xref)#to_string in - if List.mem attributeNS xrefs then - highlighted := - (highlight_node ~color:ds_green doc (n :> Gdome.node)):: - !highlighted ; - iter_children (n :> Gdome.node) - ~f:(function n -> - if n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE then - aux (new Gdome.element_of_node n)) - in - aux doc#get_documentElement ; - !highlighted -;; - -let dim_nodes = - List.iter - (function (n : Gdome.node) -> - assert - (n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE && - ((new Gdome.element_of_node n)#getAttributeNS - ~namespaceURI:ds_xmldiffns - ~localName:ds_type)#equals ds_fake) ; - let true_child = - match n#get_firstChild with - None -> assert false - | Some n -> n in - let p = - match n#get_parentNode with - None -> assert false - | Some n -> n - in - ignore (p#replaceChild ~oldChild:n ~newChild:true_child) - ) -;; - -let update_dom ~(from : Gdome.document) (d : Gdome.document) = - let rec aux (p: Gdome.node) (f: Gdome.node) (t: Gdome.node) = - let replace t1 = - if - t1 = GdomeNodeTypeT.ELEMENT_NODE && - ((new Gdome.element_of_node f)#getAttributeNS - ~namespaceURI:ds_xmldiffns - ~localName:ds_type)#equals ds_fake - then - let true_child = - match f#get_firstChild with - None -> assert false - | Some n -> n - in - begin - ignore (p#replaceChild ~oldChild:f ~newChild:true_child) ; - aux p true_child t - end - else - let t' = from#importNode t true in - ignore (p#replaceChild ~newChild:t' ~oldChild:f) ; - (* ignore (highlight_node from t') *) - in - match - f#get_nodeType,t#get_nodeType - with - GdomeNodeTypeT.TEXT_NODE,GdomeNodeTypeT.TEXT_NODE -> - (match f#get_nodeValue, t#get_nodeValue with - Some v, Some v' when v#equals v' -> () - | Some _, (Some _ as v') -> f#set_nodeValue v' - | _,_ -> assert false) - | GdomeNodeTypeT.ELEMENT_NODE as t1,GdomeNodeTypeT.ELEMENT_NODE -> - (match - f#get_namespaceURI,t#get_namespaceURI,f#get_localName,t#get_localName - with - Some nu, Some nu', Some ln, Some ln' when - ln#equals ln' && nu#equals nu' -> - begin - match f#get_attributes, t#get_attributes with - Some fattrs, Some tattrs -> - let flen = fattrs#get_length in - let tlen = tattrs#get_length in - let processed = ref [] in - for i = 0 to flen -1 do - match fattrs#item i with - None -> () (* CSC: sigh, togliere un nodo rompe fa decrescere la lunghezza ==> passare a un while *) - | Some attr -> - match attr#get_namespaceURI with - None -> - (* Back to DOM Level 1 ;-( *) - begin - let name = attr#get_nodeName in - match tattrs#getNamedItem ~name with - None -> - ignore (fattrs#removeNamedItem ~name) - | Some attr' -> - processed := - (None,Some name)::!processed ; - match attr#get_nodeValue, attr'#get_nodeValue with - Some v1, Some v2 when - v1#equals v2 - || (name#equals ds_selection && - nu#equals ds_mathmlns && - ln#equals ds_maction) - -> - () - | Some v1, Some v2 -> - let attr'' = from#importNode attr' true in - ignore (fattrs#setNamedItem attr'') - | _,_ -> assert false - end - | Some namespaceURI -> - let localName = - match attr#get_localName with - Some v -> v - | None -> assert false - in - match - tattrs#getNamedItemNS ~namespaceURI ~localName - with - None -> - ignore - (fattrs#removeNamedItemNS - ~namespaceURI ~localName) - | Some attr' -> - processed := - (Some namespaceURI,Some localName)::!processed ; - match attr#get_nodeValue, attr'#get_nodeValue with - Some v1, Some v2 when - v1#equals v2 -> - () - | Some _, Some _ -> - let attr'' = from#importNode attr' true in - ignore (fattrs#setNamedItem attr'') - | _,_ -> assert false - done ; - for i = 0 to tlen -1 do - match tattrs#item i with - None -> assert false - | Some attr -> - let namespaceURI,localName = - match attr#get_namespaceURI with - None -> - None,attr#get_nodeName - | Some namespaceURI as v -> - v, match attr#get_localName with - None -> assert false - | Some v -> v - in - if - not - (List.exists - (function - None,Some localName' -> - (match namespaceURI with - None -> - localName#equals localName' - | Some _ -> false) - | Some namespaceURI', Some localName' -> - (match namespaceURI with - None -> false - | Some namespaceURI -> - localName#equals localName' && - namespaceURI#equals namespaceURI' - ) - | _,_ -> assert false - ) !processed) - then - let attr' = from#importNode attr false in - ignore (fattrs#setNamedItem attr') - done - | _,_ -> assert false - end ; - let rec dumb_diff = - function - [],[] -> () - | he1::tl1,he2::tl2 -> - aux f he1 he2 ; - dumb_diff (tl1,tl2) - | [],tl2 -> - List.iter - (function n -> - let n' = from#importNode n true in - ignore (f#appendChild n') ; - (* ignore (highlight_node from n') *) - () - ) tl2 - | tl1,[] -> - List.iter (function n -> ignore (f#removeChild n)) tl1 - in - let node_list_of_nodeList n = - let rec aux = - function - None -> [] - | Some n when - n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE - or n#get_nodeType = GdomeNodeTypeT.TEXT_NODE -> - n::(aux n#get_nextSibling) - | Some n -> - aux n#get_nextSibling - in - aux n#get_firstChild - in - dumb_diff - (node_list_of_nodeList f, node_list_of_nodeList t) - | _,_,_,_ -> replace t1 - ) - | t1,t2 when - (t1 = GdomeNodeTypeT.ELEMENT_NODE || t1 = GdomeNodeTypeT.TEXT_NODE) && - (t2 = GdomeNodeTypeT.ELEMENT_NODE || t2 = GdomeNodeTypeT.TEXT_NODE) -> - replace t1 - | _,_ -> assert false - in - try - aux (d :> Gdome.node) - (from#get_documentElement :> Gdome.node) - (d#get_documentElement :> Gdome.node) - with - (GdomeInit.DOMException (e,msg) as ex) -> raise ex - | e -> raise e -;; diff --git a/helm/ocaml/xmldiff/xmlDiff.mli b/helm/ocaml/xmldiff/xmlDiff.mli deleted file mode 100644 index cf084af94..000000000 --- a/helm/ocaml/xmldiff/xmlDiff.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* 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 update_dom: from: Gdome.document -> Gdome.document -> unit - -type highlighted_nodes -val highlight_nodes: xrefs:(string list) -> Gdome.document -> highlighted_nodes -val dim_nodes: highlighted_nodes -> unit diff --git a/helm/software/components/METAS/meta.helm-acic_content.src b/helm/software/components/METAS/meta.helm-acic_content.src new file mode 100644 index 000000000..2ffa1551b --- /dev/null +++ b/helm/software/components/METAS/meta.helm-acic_content.src @@ -0,0 +1,4 @@ +requires="helm-cic_acic" +version="0.0.1" +archive(byte)="acic_content.cma" +archive(native)="acic_content.cmxa" diff --git a/helm/software/components/METAS/meta.helm-cic.src b/helm/software/components/METAS/meta.helm-cic.src new file mode 100644 index 000000000..525cc9c22 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-cic.src @@ -0,0 +1,5 @@ +requires="helm-urimanager helm-xml expat" +version="0.0.1" +archive(byte)="cic.cma" +archive(native)="cic.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-cic_acic.src b/helm/software/components/METAS/meta.helm-cic_acic.src new file mode 100644 index 000000000..51afe1bda --- /dev/null +++ b/helm/software/components/METAS/meta.helm-cic_acic.src @@ -0,0 +1,4 @@ +requires="helm-cic_proof_checking" +version="0.0.1" +archive(byte)="cic_acic.cma" +archive(native)="cic_acic.cmxa" diff --git a/helm/software/components/METAS/meta.helm-cic_disambiguation.src b/helm/software/components/METAS/meta.helm-cic_disambiguation.src new file mode 100644 index 000000000..d2e467aae --- /dev/null +++ b/helm/software/components/METAS/meta.helm-cic_disambiguation.src @@ -0,0 +1,4 @@ +requires="helm-whelp helm-acic_content helm-cic_unification" +version="0.0.1" +archive(byte)="cic_disambiguation.cma" +archive(native)="cic_disambiguation.cmxa" diff --git a/helm/software/components/METAS/meta.helm-cic_proof_checking.src b/helm/software/components/METAS/meta.helm-cic_proof_checking.src new file mode 100644 index 000000000..223a182a9 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-cic_proof_checking.src @@ -0,0 +1,7 @@ +requires="helm-cic helm-logger helm-getter" +version="0.0.1" +archive(byte)="cic_proof_checking.cma" +archive(native)="cic_proof_checking.cmxa" +archive(byte,miniReduction)="cicSubstitution.cmo cicMiniReduction.cmo" +archive(native,miniReduction)="cicSubstitution.cmx cicMiniReduction.cmx" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-cic_unification.src b/helm/software/components/METAS/meta.helm-cic_unification.src new file mode 100644 index 000000000..75e2d4d31 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-cic_unification.src @@ -0,0 +1,5 @@ +requires="helm-cic_proof_checking helm-library" +version="0.0.1" +archive(byte)="cic_unification.cma" +archive(native)="cic_unification.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-content_pres.src b/helm/software/components/METAS/meta.helm-content_pres.src new file mode 100644 index 000000000..cd3d36854 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-content_pres.src @@ -0,0 +1,4 @@ +requires="helm-acic_content helm-utf8_macros camlp4.gramlib ulex" +version="0.0.1" +archive(byte)="content_pres.cma" +archive(native)="content_pres.cmxa" diff --git a/helm/software/components/METAS/meta.helm-extlib.src b/helm/software/components/METAS/meta.helm-extlib.src new file mode 100644 index 000000000..bfee89e3d --- /dev/null +++ b/helm/software/components/METAS/meta.helm-extlib.src @@ -0,0 +1,5 @@ +requires="unix camlp4.gramlib" +version="0.0.1" +archive(byte)="extlib.cma" +archive(native)="extlib.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-getter.src b/helm/software/components/METAS/meta.helm-getter.src new file mode 100644 index 000000000..8a7badf74 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-getter.src @@ -0,0 +1,5 @@ +requires="http unix pcre zip helm-xml helm-logger helm-urimanager helm-registry" +version="0.0.1" +archive(byte)="getter.cma" +archive(native)="getter.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-grafite.src b/helm/software/components/METAS/meta.helm-grafite.src new file mode 100644 index 000000000..0ae4a09d3 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-grafite.src @@ -0,0 +1,4 @@ +requires="helm-cic" +version="0.0.1" +archive(byte)="grafite.cma" +archive(native)="grafite.cmxa" diff --git a/helm/software/components/METAS/meta.helm-grafite_engine.src b/helm/software/components/METAS/meta.helm-grafite_engine.src new file mode 100644 index 000000000..c7203724c --- /dev/null +++ b/helm/software/components/METAS/meta.helm-grafite_engine.src @@ -0,0 +1,5 @@ +requires="helm-library helm-grafite helm-tactics" +version="0.0.1" +archive(byte)="grafite_engine.cma" +archive(native)="grafite_engine.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-grafite_parser.src b/helm/software/components/METAS/meta.helm-grafite_parser.src new file mode 100644 index 000000000..d921b5588 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-grafite_parser.src @@ -0,0 +1,5 @@ +requires="helm-lexicon helm-grafite ulex" +version="0.0.1" +archive(byte)="grafite_parser.cma" +archive(native)="grafite_parser.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-hgdome.src b/helm/software/components/METAS/meta.helm-hgdome.src new file mode 100644 index 000000000..d06666f43 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-hgdome.src @@ -0,0 +1,4 @@ +requires="helm-xml gdome2" +version="0.0.1" +archive(byte)="hgdome.cma" +archive(native)="hgdome.cmxa" diff --git a/helm/software/components/METAS/meta.helm-hmysql.src b/helm/software/components/METAS/meta.helm-hmysql.src new file mode 100644 index 000000000..144141e28 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-hmysql.src @@ -0,0 +1,4 @@ +requires="helm-registry mysql helm-extlib" +version="0.0.1" +archive(byte)="hmysql.cma" +archive(native)="hmysql.cmxa" diff --git a/helm/software/components/METAS/meta.helm-lexicon.src b/helm/software/components/METAS/meta.helm-lexicon.src new file mode 100644 index 000000000..35ab5dd36 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-lexicon.src @@ -0,0 +1,4 @@ +requires="helm-content_pres helm-cic_disambiguation camlp4.gramlib" +version="0.0.1" +archive(byte)="lexicon.cma" +archive(native)="lexicon.cmxa" diff --git a/helm/software/components/METAS/meta.helm-library.src b/helm/software/components/METAS/meta.helm-library.src new file mode 100644 index 000000000..d4955e05d --- /dev/null +++ b/helm/software/components/METAS/meta.helm-library.src @@ -0,0 +1,5 @@ +requires="helm-cic_acic helm-metadata" +version="0.0.1" +archive(byte)="library.cma" +archive(native)="library.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-logger.src b/helm/software/components/METAS/meta.helm-logger.src new file mode 100644 index 000000000..5b2e8d8ff --- /dev/null +++ b/helm/software/components/METAS/meta.helm-logger.src @@ -0,0 +1,5 @@ +requires="" +version="0.0.1" +archive(byte)="logger.cma" +archive(native)="logger.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-metadata.src b/helm/software/components/METAS/meta.helm-metadata.src new file mode 100644 index 000000000..a5b138301 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-metadata.src @@ -0,0 +1,4 @@ +requires="helm-hmysql helm-cic_proof_checking" +version="0.0.1" +archive(byte)="metadata.cma" +archive(native)="metadata.cmxa" diff --git a/helm/software/components/METAS/meta.helm-registry.src b/helm/software/components/METAS/meta.helm-registry.src new file mode 100644 index 000000000..82d364016 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-registry.src @@ -0,0 +1,4 @@ +requires="str netstring helm-xml" +version="0.0.1" +archive(byte)="registry.cma" +archive(native)="registry.cmxa" diff --git a/helm/software/components/METAS/meta.helm-tactics.src b/helm/software/components/METAS/meta.helm-tactics.src new file mode 100644 index 000000000..6e704ba06 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-tactics.src @@ -0,0 +1,4 @@ +requires="helm-cic_proof_checking helm-cic_unification helm-whelp" +version="0.0.1" +archive(byte)="tactics.cma" +archive(native)="tactics.cmxa" diff --git a/helm/software/components/METAS/meta.helm-thread.src b/helm/software/components/METAS/meta.helm-thread.src new file mode 100644 index 000000000..5253060d2 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-thread.src @@ -0,0 +1,7 @@ +requires="" +version="0.0.1" +archive(byte,mt)="thread.cma" +archive(native,mt)="thread.cmxa" +archive(byte)="thread_fake.cma" +archive(native)="thread_fake.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-urimanager.src b/helm/software/components/METAS/meta.helm-urimanager.src new file mode 100644 index 000000000..ff1874688 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-urimanager.src @@ -0,0 +1,5 @@ +requires="str" +version="0.0.1" +archive(byte)="urimanager.cma" +archive(native)="urimanager.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-utf8_macros.src b/helm/software/components/METAS/meta.helm-utf8_macros.src new file mode 100644 index 000000000..c2da77649 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-utf8_macros.src @@ -0,0 +1,7 @@ +requires="" +version="0.0.1" +archive(byte)="utf8_macros.cma" +archive(native)="utf8_macros.cmxa" +requires(syntax,preprocessor)="camlp4" +archive(syntax,preprocessor)="pa_extend.cmo pa_unicode_macro.cma" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-whelp.src b/helm/software/components/METAS/meta.helm-whelp.src new file mode 100644 index 000000000..20ea84329 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-whelp.src @@ -0,0 +1,4 @@ +requires="helm-metadata" +version="0.0.1" +archive(byte)="whelp.cma" +archive(native)="whelp.cmxa" diff --git a/helm/software/components/METAS/meta.helm-xml.src b/helm/software/components/METAS/meta.helm-xml.src new file mode 100644 index 000000000..626e644fc --- /dev/null +++ b/helm/software/components/METAS/meta.helm-xml.src @@ -0,0 +1,5 @@ +requires="zip expat helm-extlib" +version="0.0.1" +archive(byte)="xml.cma" +archive(native)="xml.cmxa" +linkopts="" diff --git a/helm/software/components/METAS/meta.helm-xmldiff.src b/helm/software/components/METAS/meta.helm-xmldiff.src new file mode 100644 index 000000000..9cc918307 --- /dev/null +++ b/helm/software/components/METAS/meta.helm-xmldiff.src @@ -0,0 +1,4 @@ +requires="gdome2" +version="0.0.1" +archive(byte)="xmldiff.cma" +archive(native)="xmldiff.cmxa" diff --git a/helm/software/components/Makefile b/helm/software/components/Makefile new file mode 100644 index 000000000..2968a2405 --- /dev/null +++ b/helm/software/components/Makefile @@ -0,0 +1,124 @@ + +export SHELL=/bin/bash + +include ../Makefile.defs + +# Warning: the modules must be in compilation order +NULL = +MODULES = \ + extlib \ + xml \ + hgdome \ + registry \ + hmysql \ + utf8_macros \ + thread \ + xmldiff \ + urimanager \ + logger \ + getter \ + cic \ + cic_proof_checking \ + cic_acic \ + acic_content \ + content_pres \ + grafite \ + metadata \ + library \ + cic_unification \ + whelp \ + tactics \ + cic_disambiguation \ + lexicon \ + grafite_engine \ + grafite_parser \ + tactics/paramodulation \ + $(NULL) + +METAS = $(filter-out %/paramodulation,$(MODULES:%=METAS/META.helm-%)) + +all: metas $(MODULES:%=%.all) +opt: metas $(MODULES:%=%.opt) +world: all opt +depend: $(MODULES:%=%.depend) +install: $(MODULES:%=%.install) +uninstall: $(MODULES:%=%.uninstall) +clean: $(MODULES:%=%.clean) clean_metas + +.stats: $(MODULES:%=%.stats) + (for m in $(MODULES); do echo -n "$$m:"; cat $$m/.stats; done) \ + | sort -t : -k 2 -n -r > .stats + +EXTRA_DIST_CLEAN = \ + libraries-clusters.ps \ + libraries-clusters.pdf \ + libraries-ext.ps \ + libraries.ps \ + .dep.dot \ + .extdep.dot \ + .clustersdep.dot \ + $(NULL) + +distclean: clean clean_metas + rm -f $(METAS) + rm -f configure config.log config.cache config.status + rm -f $(EXTRA_DIST_CLEAN) + +.PHONY: all opt world metas depend install uninstall clean clean_metas distclean + +%.all: + $(MAKE) -C $* all +%.opt: + $(MAKE) -C $* opt +%.clean: + $(MAKE) -C $* clean +%.depend: + $(MAKE) -C $* depend +%.stats: + @$(MAKE) -C $* .stats +%.install: + $(MAKE) -C $* install +%.uninstall: + $(MAKE) -C $* uninstall + +METAS/META.helm-%: METAS/meta.helm-%.src + cp $< $@ && echo "directory=\"$(shell pwd)/$*\"" >> $@ + +.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 "}" >> $@ + +.PHONY: .alldep.dot +.alldep.dot: + echo "digraph G {" > $@ + echo " rankdir = TB ;" >> $@ + for i in $(MODULES); do $(OCAMLFIND) query helm-$$i -recursive -p-format | grep -v "pxp-" | sed "s/^pxp/pxp[-*]/g" | sed "s/^/ \"helm-$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done + mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old + for i in $(MODULES); do echo "\"helm-$$i\" [shape=box,style=filled,fillcolor=yellow];" >> $@ ; done + echo "}" >> $@ + +.extdep.dot: .dep.dot + STATS/patch_deps.sh $< $@ +.clustersdep.dot: .dep.dot + USE_CLUSTERS=yes STATS/patch_deps.sh $< $@ + +libraries.ps: .dep.dot + dot -Tps -o $@ $< +libraries-ext.ps: .extdep.dot + dot -Tps -o $@ $< +libraries-clusters.ps: .clustersdep.dot + dot -Tps -o $@ $< +libraries-complete.ps: .alldep.dot + dot -Tps -o $@ $< + +ps: libraries.ps libraries-ext.ps libraries-clusters.ps + +tags: TAGS +.PHONY: TAGS +TAGS: + otags -vi -r . + diff --git a/helm/software/components/Makefile.common b/helm/software/components/Makefile.common new file mode 100644 index 000000000..9feae4f86 --- /dev/null +++ b/helm/software/components/Makefile.common @@ -0,0 +1,135 @@ +H=@ + +# This Makefile must be included by another one defining: +# $PACKAGE +# $PREDICATES +# $INTERFACE_FILES +# $IMPLEMENTATION_FILES +# $EXTRA_OBJECTS_TO_INSTALL +# $EXTRA_OBJECTS_TO_CLEAN +# and put in a directory where there is a .depend file. + +# $OCAMLFIND must be set to a meaningful vaule, including OCAMLPATH= + +PREPROCOPTIONS = -pp camlp4o +SYNTAXOPTIONS = -syntax camlp4o +PREREQ = +OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread +OCAMLDEBUGOPTIONS = -g +OCAMLARCHIVEOPTIONS = +REQUIRES := $(shell $(OCAMLFIND) -query -format '%(requires)' helm-$(PACKAGE)) +OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(PREPROCOPTIONS) +OCAMLOPT = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(PREPROCOPTIONS) +OCAMLDEP = $(OCAMLFIND) ocamldep -package "camlp4 $(CAMLP4REQUIRES)" $(SYNTAXOPTIONS) $(OCAMLDEPOPTIONS) +OCAMLLEX = ocamllex +OCAMLYACC = ocamlyacc + +OCAMLC_P4 = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(SYNTAXOPTIONS) +OCAMLOPT_P4 = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(SYNTAXOPTIONS) + +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)) +LIBRARIES_DEPS := \ + $(foreach X,$(filter-out /usr/lib/ocaml%,$(LIBRARIES)),\ + $(wildcard \ + $(shell dirname $(X))/*.mli \ + $(shell dirname $(X))/*.ml \ + $(shell dirname $(X))/paramodulation/*.ml \ + $(shell dirname $(X))/paramodultation/*.mli)) + + +ARCHIVE = $(PACKAGE).cma +ARCHIVE_OPT = $(PACKAGE).cmxa +OBJECTS_TO_INSTALL = $(ARCHIVE) $(ARCHIVE_OPT) $(ARCHIVE_OPT:%.cmxa=%.a) \ + $(INTERFACE_FILES) $(INTERFACE_FILES:%.mli=%.cmi) \ + $(EXTRA_OBJECTS_TO_INSTALL) +DEPEND_FILES = $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) + +$(ARCHIVE): $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(LIBRARIES) + $(H)if [ $(PACKAGE) != dummy ]; then \ + echo " OCAMLC -a $@";\ + $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ + $(IMPLEMENTATION_FILES:%.ml=%.cmo); fi + +$(ARCHIVE_OPT): $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(LIBRARIES_OPT) + $(H)if [ $(PACKAGE) != dummy ]; then \ + echo " OCAMLOPT -a $@";\ + $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ + $(IMPLEMENTATION_FILES:%.ml=%.cmx); fi + +prereq: $(PREREQ) +all: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(ARCHIVE) + @echo -n +opt: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(ARCHIVE_OPT) + @echo -n +world: all opt +test: test.ml $(ARCHIVE) + $(OCAMLC) $(ARCHIVE) -linkpkg -o $@ $< +test.opt: test.ml $(ARCHIVE_OPT) + $(OCAMLOPT) $(ARCHIVE_OPT) -linkpkg -o $@ $< +install: +uninstall: + +depend: $(DEPEND_FILES) + $(OCAMLDEP) $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) > .depend + +$(PACKAGE).ps: .dep.dot + dot -Tps -o $@ $< + +.dep.dot: .depend + ocamldot < .depend > $@ + +%.cmi: %.mli + @echo " OCAMLC $<" + $(H)$(OCAMLC) -c $< +%.cmo %.cmi: %.ml + @echo " OCAMLC $<" + $(H)$(OCAMLC) -c $< +%.cmx: %.ml + @echo " OCAMLOPT $<" + $(H)$(OCAMLOPT) -c $< +%.annot: %.ml + $(OCAMLC) -dtypes $(PKGS) -c $< +%.ml %.mli: %.mly + $(OCAMLYACC) $< +%.ml: %.mll + $(OCAMLLEX) $< + +ifneq ($(MAKECMDGOALS), clean) +$(IMPLEMENTATION_FILES:%.ml=%.cmo): $(LIBRARIES) +$(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES_DEPS) +$(IMPLEMENTATION_FILES:%.ml=%.cmx): $(LIBRARIES_OPT) +endif + +clean: + rm -f *.cm[ioax] *.cmxa *.o *.a *.annot $(EXTRA_OBJECTS_TO_CLEAN) + if [ -f test ]; then rm -f test; else true; fi + if [ -f test.opt ]; then rm -f test.opt; else true; fi + +backup: + cd ..; tar cvzf $(PACKAGE)_$(shell date +%s).tar.gz $(PACKAGE) + +ocamlinit: + echo "#use \"topfind\";;" > .ocamlinit + echo "#thread;;" >> .ocamlinit + for p in $(REQUIRES); do echo "#require \"$$p\";;" >> .ocamlinit; done + echo "#load \"$(PACKAGE).cma\";;" >> .ocamlinit + +# $(STATS_EXCLUDE) may be defined in libraries' Makefile to exclude some file +# from statistics collection +STATS_FILES = \ + $(shell find . -maxdepth 1 -type f -name \*.ml $(foreach f,$(STATS_EXCLUDE),-not -name $(f))) \ + $(shell find . -maxdepth 1 -type f -name \*.mli $(foreach f,$(STATS_EXCLUDE),-not -name $(f))) +.stats: $(STATS_FILES) + rm -f .stats + echo -n "LOC:" >> .stats + wc -l $(STATS_FILES) | tail -1 | awk '{ print $$1 }' >> .stats + +.PHONY: all opt world backup depend install uninstall clean ocamlinit + +ifneq ($(MAKECMDGOALS), depend) + include .depend +endif + +NULL = + diff --git a/helm/software/components/STATS/clusters.dot b/helm/software/components/STATS/clusters.dot new file mode 100644 index 000000000..b7298bce8 --- /dev/null +++ b/helm/software/components/STATS/clusters.dot @@ -0,0 +1,57 @@ +// clusterrank = none; + fillcolor = "gray93"; + fontsize = 24; + node [fontsize = 24]; + /* libs clusters */ + subgraph cluster_presentation { + label = "Terms at the content and presentation level"; + labelloc = "b"; + labeljust = "r"; + style = "filled"; + color = "white" + acic_content; + cic_disambiguation; + content_pres; + grafite_parser; + lexicon; + } + subgraph cluster_partially { + label = "Partially specified terms"; + labelloc = "t"; + labeljust = "l"; + style = "filled"; + color = "white" + cic_unification; + tactics; + grafite; + grafite_engine; + } + subgraph cluster_fully { + label = "Fully specified terms"; + labelloc = "b"; + labeljust = "l"; + style = "filled"; + color = "white" + cic; + cic_proof_checking; + getter; + metadata; + urimanager; + whelp; + library; + cic_acic; + } + subgraph cluster_utilities { + label = "Utilities"; + labelloc = "b"; + labeljust = "r"; + style = "filled"; + color = "white" + extlib; + hgdome; + hmysql; + registry; + utf8_macros; + xml; + logger; + } diff --git a/helm/software/components/STATS/daemons.dot b/helm/software/components/STATS/daemons.dot new file mode 100644 index 000000000..4a8ba388f --- /dev/null +++ b/helm/software/components/STATS/daemons.dot @@ -0,0 +1,19 @@ + /* apps */ + subgraph applications { + node [shape=plaintext,style=filled,fillcolor=slategray2]; + DependencyAnalyzer [label="Dependency\nAnalyzer\n .3 klocs"]; + Getter [label="Getter\n .3 klocs"]; + Matita [label="Matita\n 6.7 klocs"]; + ProofChecker [label="Proof Checker\n .1 klocs"]; + Uwobo [label="Uwobo\n 2.1 klocs"]; + Whelp [label="Whelp\n .6 klocs"]; + } + /* apps dep */ + DependencyAnalyzer -> metadata; + Getter -> getter; + Matita -> grafite_engine; + Matita -> grafite_parser; + Matita -> hgdome; + ProofChecker -> cic_proof_checking; + Uwobo -> content_pres; + Whelp -> grafite_parser; diff --git a/helm/software/components/STATS/deps.patch b/helm/software/components/STATS/deps.patch new file mode 100644 index 000000000..90130dfe8 --- /dev/null +++ b/helm/software/components/STATS/deps.patch @@ -0,0 +1,23 @@ +--- .clustersdep.dot 2006-01-26 10:10:46.000000000 +0100 ++++ .clustersdep.new 2006-01-26 10:10:44.000000000 +0100 +@@ -1,11 +1,8 @@ + digraph G { + xml [label="xml\n.5 klocs"]; +- xmldiff [label="xmldiff\n.3 klocs"]; + whelp [label="whelp\n.3 klocs"]; + utf8_macros [label="utf8_macros\n.2 klocs"]; + urimanager [label="urimanager\n.2 klocs"]; +- thread [label="thread\n.2 klocs"]; +- paramodulation [label="paramodulation\n5.9 klocs"]; + tactics [label="tactics\n10.0 klocs"]; + registry [label="registry\n.6 klocs"]; + metadata [label="metadata\n1.9 klocs"]; +@@ -42,7 +39,7 @@ + "cic_unification" -> "library"; + "library" -> "metadata"; + "library" -> "cic_acic"; +-"metadata" -> "cic_proof_checking"; ++"metadata" -> "cic"; + "metadata" -> "hmysql"; + "grafite" -> "cic"; + "content_pres" -> "utf8_macros"; diff --git a/helm/software/components/STATS/patch_deps.sh b/helm/software/components/STATS/patch_deps.sh new file mode 100755 index 000000000..d7dd7b3ba --- /dev/null +++ b/helm/software/components/STATS/patch_deps.sh @@ -0,0 +1,53 @@ +#!/bin/sh +# script args: source_file target_file + +use_clusters='no' +if [ ! -z "$USE_CLUSTERS" ]; then + use_clusters=$USE_CLUSTERS +fi + +# args: file snippet +# file will be modified in place +include_dot_snippet () +{ + echo "Adding to $1 graphviz snippet $2 ..." + sed -i "/digraph/r $2" $1 +} + +# args: stats file +# file will be modified in place +include_loc_stats () +{ + echo "Adding to $1 KLOCs stats from $2 ..." + tmp=`mktemp tmp.stats.XXXXXX` + for l in `cat $2`; do + module=$(basename $(echo $l | cut -d : -f 1)) + stat=$(echo $l | cut -d : -f 2) + if [ "$stat" = "LOC" ]; then + locs=$(echo $l | cut -d : -f 3) + klocs=$(echo "scale=1; $locs / 1000" | bc) + if [ "$klocs" = "0" ]; then klocs=".1"; fi + printf ' %s [label="%s\\n%s klocs"];\n' $module $module $klocs >> $tmp + fi + done + include_dot_snippet $1 $tmp + rm $tmp +} + +# args: file patch +apply_patch () +{ + if [ -f "$2" ]; then + echo "Applying to $1 patch $2 ..." + patch $1 $2 + fi +} + +cp $1 $2 +include_loc_stats $2 .stats +apply_patch $2 STATS/deps.patch +include_dot_snippet $2 STATS/daemons.dot +if [ "$use_clusters" = "yes" ]; then + include_dot_snippet $2 STATS/clusters.dot +fi + diff --git a/helm/software/components/acic_content/.depend b/helm/software/components/acic_content/.depend new file mode 100644 index 000000000..f6399321e --- /dev/null +++ b/helm/software/components/acic_content/.depend @@ -0,0 +1,30 @@ +contentPp.cmi: content.cmi +acic2content.cmi: content.cmi +content2cic.cmi: content.cmi +cicNotationUtil.cmi: cicNotationPt.cmo +cicNotationEnv.cmi: cicNotationPt.cmo +cicNotationPp.cmi: cicNotationPt.cmo cicNotationEnv.cmi +acic2astMatcher.cmi: cicNotationPt.cmo +termAcicContent.cmi: cicNotationPt.cmo +content.cmo: content.cmi +content.cmx: content.cmi +contentPp.cmo: content.cmi contentPp.cmi +contentPp.cmx: content.cmx contentPp.cmi +acic2content.cmo: content.cmi acic2content.cmi +acic2content.cmx: content.cmx acic2content.cmi +content2cic.cmo: content.cmi content2cic.cmi +content2cic.cmx: content.cmx content2cic.cmi +cicNotationUtil.cmo: cicNotationPt.cmo cicNotationUtil.cmi +cicNotationUtil.cmx: cicNotationPt.cmx cicNotationUtil.cmi +cicNotationEnv.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationEnv.cmi +cicNotationEnv.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationEnv.cmi +cicNotationPp.cmo: cicNotationPt.cmo cicNotationEnv.cmi cicNotationPp.cmi +cicNotationPp.cmx: cicNotationPt.cmx cicNotationEnv.cmx cicNotationPp.cmi +acic2astMatcher.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \ + acic2astMatcher.cmi +acic2astMatcher.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ + acic2astMatcher.cmi +termAcicContent.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \ + acic2astMatcher.cmi termAcicContent.cmi +termAcicContent.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ + acic2astMatcher.cmx termAcicContent.cmi diff --git a/helm/software/components/acic_content/Makefile b/helm/software/components/acic_content/Makefile new file mode 100644 index 000000000..862a9eefb --- /dev/null +++ b/helm/software/components/acic_content/Makefile @@ -0,0 +1,20 @@ +PACKAGE = acic_content +PREDICATES = + +INTERFACE_FILES = \ + content.mli \ + contentPp.mli \ + acic2content.mli \ + content2cic.mli \ + cicNotationUtil.mli \ + cicNotationEnv.mli \ + cicNotationPp.mli \ + acic2astMatcher.mli \ + termAcicContent.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + cicNotationPt.ml \ + $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/acic_content/acic2astMatcher.ml b/helm/software/components/acic_content/acic2astMatcher.ml new file mode 100644 index 000000000..d62786cc7 --- /dev/null +++ b/helm/software/components/acic_content/acic2astMatcher.ml @@ -0,0 +1,98 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +module Ast = CicNotationPt +module Util = CicNotationUtil + +module Matcher32 = +struct + module Pattern32 = + struct + type cic_mask_t = + Blob + | Uri of UriManager.uri + | Appl of cic_mask_t list + + let uri_of_term t = CicUtil.uri_of_term (Deannotate.deannotate_term t) + + let mask_of_cic = function + | Cic.AAppl (_, tl) -> Appl (List.map (fun _ -> Blob) tl), tl + | Cic.AConst (_, _, []) + | Cic.AVar (_, _, []) + | Cic.AMutInd (_, _, _, []) + | Cic.AMutConstruct (_, _, _, _, []) as t -> Uri (uri_of_term t), [] + | _ -> Blob, [] + + let tag_of_term t = + let mask, tl = mask_of_cic t in + Hashtbl.hash mask, tl + + let mask_of_appl_pattern = function + | Ast.UriPattern uri -> Uri uri, [] + | Ast.ImplicitPattern + | Ast.VarPattern _ -> Blob, [] + | Ast.ApplPattern pl -> Appl (List.map (fun _ -> Blob) pl), pl + + let tag_of_pattern p = + let mask, pl = mask_of_appl_pattern p in + Hashtbl.hash mask, pl + + type pattern_t = Ast.cic_appl_pattern + type term_t = Cic.annterm + + let string_of_pattern = CicNotationPp.pp_cic_appl_pattern + let string_of_term t = CicPp.ppterm (Deannotate.deannotate_term t) + + let classify = function + | Ast.ImplicitPattern + | Ast.VarPattern _ -> PatternMatcher.Variable + | Ast.UriPattern _ + | Ast.ApplPattern _ -> PatternMatcher.Constructor + end + + module M = PatternMatcher.Matcher (Pattern32) + + let compiler rows = + let match_cb rows = + let pl, pid = try List.hd rows with Not_found -> assert false in + (fun matched_terms constructors -> + let env = + try + List.map2 + (fun p t -> + match p with + | Ast.ImplicitPattern -> Util.fresh_name (), t + | Ast.VarPattern name -> name, t + | _ -> assert false) + pl matched_terms + with Invalid_argument _ -> assert false + in + Some (env, constructors, pid)) + in + M.compiler rows match_cb (fun () -> None) +end + diff --git a/helm/software/components/acic_content/acic2astMatcher.mli b/helm/software/components/acic_content/acic2astMatcher.mli new file mode 100644 index 000000000..0a9ec6a6b --- /dev/null +++ b/helm/software/components/acic_content/acic2astMatcher.mli @@ -0,0 +1,34 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +module Matcher32: +sig + (** @param l3_patterns level 3 (CIC) patterns (AKA cic_appl_pattern) *) + val compiler : + (CicNotationPt.cic_appl_pattern * int) list -> + (Cic.annterm -> + ((string * Cic.annterm) list * Cic.annterm list * int) option) +end + diff --git a/helm/software/components/acic_content/acic2content.ml b/helm/software/components/acic_content/acic2content.ml new file mode 100644 index 000000000..57b8502bb --- /dev/null +++ b/helm/software/components/acic_content/acic2content.ml @@ -0,0 +1,995 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 16/6/2003 *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +let object_prefix = "obj:";; +let declaration_prefix = "decl:";; +let definition_prefix = "def:";; +let inductive_prefix = "ind:";; +let joint_prefix = "joint:";; +let proof_prefix = "proof:";; +let conclude_prefix = "concl:";; +let premise_prefix = "prem:";; +let lemma_prefix = "lemma:";; + +(* e se mettessi la conversione di BY nell'apply_context ? *) +(* sarebbe carino avere l'invariante che la proof2pres +generasse sempre prove con contesto vuoto *) + +let gen_id prefix seed = + let res = prefix ^ string_of_int !seed in + incr seed ; + res +;; + +let name_of = function + Cic.Anonymous -> None + | Cic.Name b -> Some b;; + +exception Not_a_proof;; +exception NotImplemented;; +exception NotApplicable;; + +(* we do not care for positivity, here, that in any case is enforced by + well typing. Just a brutal search *) + +let rec occur uri = + let module C = Cic in + function + C.Rel _ -> false + | C.Var _ -> false + | C.Meta _ -> false + | C.Sort _ -> false + | C.Implicit _ -> assert false + | C.Prod (_,s,t) -> (occur uri s) or (occur uri t) + | C.Cast (te,ty) -> (occur uri te) + | C.Lambda (_,s,t) -> (occur uri s) or (occur uri t) (* or false ?? *) + | C.LetIn (_,s,t) -> (occur uri s) or (occur uri t) + | C.Appl l -> + List.fold_left + (fun b a -> + if b then b + else (occur uri a)) false l + | C.Const (_,_) -> false + | C.MutInd (uri1,_,_) -> if uri = uri1 then true else false + | C.MutConstruct (_,_,_,_) -> false + | C.MutCase _ -> false (* presuming too much?? *) + | C.Fix _ -> false (* presuming too much?? *) + | C.CoFix (_,_) -> false (* presuming too much?? *) +;; + +let get_id = + let module C = Cic in + function + C.ARel (id,_,_,_) -> id + | C.AVar (id,_,_) -> id + | C.AMeta (id,_,_) -> id + | C.ASort (id,_) -> id + | C.AImplicit _ -> raise NotImplemented + | C.AProd (id,_,_,_) -> id + | C.ACast (id,_,_) -> id + | C.ALambda (id,_,_,_) -> id + | C.ALetIn (id,_,_,_) -> id + | C.AAppl (id,_) -> id + | C.AConst (id,_,_) -> id + | C.AMutInd (id,_,_,_) -> id + | C.AMutConstruct (id,_,_,_,_) -> id + | C.AMutCase (id,_,_,_,_,_) -> id + | C.AFix (id,_,_) -> id + | C.ACoFix (id,_,_) -> id +;; + +let test_for_lifting ~ids_to_inner_types ~ids_to_inner_sorts= + let module C = Cic in + let module C2A = Cic2acic in + (* atomic terms are never lifted, according to my policy *) + function + C.ARel (id,_,_,_) -> false + | C.AVar (id,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.AMeta (id,_,_) -> + (try + Hashtbl.find ids_to_inner_sorts id = `Prop + with Not_found -> assert false) + | C.ASort (id,_) -> false + | C.AImplicit _ -> raise NotImplemented + | C.AProd (id,_,_,_) -> false + | C.ACast (id,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.ALambda (id,_,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.ALetIn (id,_,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.AAppl (id,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.AConst (id,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.AMutInd (id,_,_,_) -> false + | C.AMutConstruct (id,_,_,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + (* oppure: false *) + | C.AMutCase (id,_,_,_,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.AFix (id,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) + | C.ACoFix (id,_,_) -> + (try + ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; + true; + with Not_found -> false) +;; + +(* transform a proof p into a proof list, concatenating the last +conclude element to the apply_context list, in case context is +empty. Otherwise, it just returns [p] *) + +let flat seed p = + let module K = Content in + if (p.K.proof_context = []) then + if p.K.proof_apply_context = [] then [p] + else + let p1 = + { p with + K.proof_context = []; + K.proof_apply_context = [] + } in + p.K.proof_apply_context@[p1] + else + [p] +;; + +let rec serialize seed = + function + [] -> [] + | a::l -> (flat seed a)@(serialize seed l) +;; + +(* top_down = true if the term is a LAMBDA or a decl *) +let generate_conversion seed top_down id inner_proof ~ids_to_inner_types = + let module C2A = Cic2acic in + let module K = Content in + let exp = (try ((Hashtbl.find ids_to_inner_types id).C2A.annexpected) + with Not_found -> None) + in + match exp with + None -> inner_proof + | Some expty -> + if inner_proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then + { K.proof_name = inner_proof.K.proof_name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = [] ; + K.proof_apply_context = []; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "TD_Conversion"; + K.conclude_args = + [K.ArgProof {inner_proof with K.proof_name = None}]; + K.conclude_conclusion = Some expty + }; + } + else + { K.proof_name = inner_proof.K.proof_name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = [] ; + K.proof_apply_context = [{inner_proof with K.proof_name = None}]; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "BU_Conversion"; + K.conclude_args = + [K.Premise + { K.premise_id = gen_id premise_prefix seed; + K.premise_xref = inner_proof.K.proof_id; + K.premise_binder = None; + K.premise_n = None + } + ]; + K.conclude_conclusion = Some expty + }; + } +;; + +let generate_exact seed t id name ~ids_to_inner_types = + let module C2A = Cic2acic in + let module K = Content in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed ; + K.proof_context = [] ; + K.proof_apply_context = []; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Exact"; + K.conclude_args = [K.Term t]; + K.conclude_conclusion = + try Some (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + }; + } +;; + +let generate_intros_let_tac seed id n s is_intro inner_proof name ~ids_to_inner_types = + let module C2A = Cic2acic in + let module C = Cic in + let module K = Content in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed ; + K.proof_context = [] ; + K.proof_apply_context = []; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Intros+LetTac"; + K.conclude_args = [K.ArgProof inner_proof]; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> + (match inner_proof.K.proof_conclude.K.conclude_conclusion with + None -> None + | Some t -> + if is_intro then Some (C.AProd ("gen"^id,n,s,t)) + else Some (C.ALetIn ("gen"^id,n,s,t))) + }; + } +;; + +let build_decl_item seed id n s ~ids_to_inner_sorts = + let module K = Content in + let sort = + try + Some (Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)) + with Not_found -> None + in + match sort with + | Some `Prop -> + `Hypothesis + { K.dec_name = name_of n; + K.dec_id = gen_id declaration_prefix seed; + K.dec_inductive = false; + K.dec_aref = id; + K.dec_type = s + } + | _ -> + `Declaration + { K.dec_name = name_of n; + K.dec_id = gen_id declaration_prefix seed; + K.dec_inductive = false; + K.dec_aref = id; + K.dec_type = s + } +;; + +let rec build_subproofs_and_args seed l ~ids_to_inner_types ~ids_to_inner_sorts = + let module C = Cic in + let module K = Content in + let rec aux = + function + [] -> [],[] + | t::l1 -> + let subproofs,args = aux l1 in + if (test_for_lifting t ~ids_to_inner_types ~ids_to_inner_sorts) then + let new_subproof = + acic2content + seed ~name:"H" ~ids_to_inner_types ~ids_to_inner_sorts t in + let new_arg = + K.Premise + { K.premise_id = gen_id premise_prefix seed; + K.premise_xref = new_subproof.K.proof_id; + K.premise_binder = new_subproof.K.proof_name; + K.premise_n = None + } in + new_subproof::subproofs,new_arg::args + else + let hd = + (match t with + C.ARel (idr,idref,n,b) -> + let sort = + (try + Hashtbl.find ids_to_inner_sorts idr + with Not_found -> `Type (CicUniv.fresh())) in + if sort = `Prop then + K.Premise + { K.premise_id = gen_id premise_prefix seed; + K.premise_xref = idr; + K.premise_binder = Some b; + K.premise_n = Some n + } + else (K.Term t) + | C.AConst(id,uri,[]) -> + let sort = + (try + Hashtbl.find ids_to_inner_sorts id + with Not_found -> `Type (CicUniv.fresh())) in + if sort = `Prop then + K.Lemma + { K.lemma_id = gen_id lemma_prefix seed; + K.lemma_name = UriManager.name_of_uri uri; + K.lemma_uri = UriManager.string_of_uri uri + } + else (K.Term t) + | C.AMutConstruct(id,uri,tyno,consno,[]) -> + let sort = + (try + Hashtbl.find ids_to_inner_sorts id + with Not_found -> `Type (CicUniv.fresh())) in + if sort = `Prop then + let inductive_types = + (let o,_ = + CicEnvironment.get_obj CicUniv.empty_ugraph uri + in + match o with + | Cic.InductiveDefinition (l,_,_,_) -> l + | _ -> assert false + ) in + let (_,_,_,constructors) = + List.nth inductive_types tyno in + let name,_ = List.nth constructors (consno - 1) in + K.Lemma + { K.lemma_id = gen_id lemma_prefix seed; + K.lemma_name = name; + K.lemma_uri = + UriManager.string_of_uri uri ^ "#xpointer(1/" ^ + string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^ + ")" + } + else (K.Term t) + | _ -> (K.Term t)) in + subproofs,hd::args + in + match (aux l) with + [p],args -> + [{p with K.proof_name = None}], + List.map + (function + K.Premise prem when prem.K.premise_xref = p.K.proof_id -> + K.Premise {prem with K.premise_binder = None} + | i -> i) args + | p,a as c -> c + +and + +build_def_item seed id n t ~ids_to_inner_sorts ~ids_to_inner_types = + let module K = Content in + try + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + (let p = + (acic2content seed ?name:(name_of n) ~ids_to_inner_sorts ~ids_to_inner_types t) + in + `Proof p;) + else + `Definition + { K.def_name = name_of n; + K.def_id = gen_id definition_prefix seed; + K.def_aref = id; + K.def_term = t + } + with + Not_found -> assert false + +(* the following function must be called with an object of sort +Prop. For debugging purposes this is tested again, possibly raising an +Not_a_proof exception *) + +and acic2content seed ?name ~ids_to_inner_sorts ~ids_to_inner_types t = + let rec aux ?name t = + let module C = Cic in + let module K = Content in + let module C2A = Cic2acic in + let t1 = + match t with + C.ARel (id,idref,n,b) as t -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + generate_exact seed t id name ~ids_to_inner_types + else raise Not_a_proof + | C.AVar (id,uri,exp_named_subst) as t -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + generate_exact seed t id name ~ids_to_inner_types + else raise Not_a_proof + | C.AMeta (id,n,l) as t -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + generate_exact seed t id name ~ids_to_inner_types + else raise Not_a_proof + | C.ASort (id,s) -> raise Not_a_proof + | C.AImplicit _ -> raise NotImplemented + | C.AProd (_,_,_,_) -> raise Not_a_proof + | C.ACast (id,v,t) -> aux v + | C.ALambda (id,n,s,t) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + let proof = aux t in + let proof' = + if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then + match proof.K.proof_conclude.K.conclude_args with + [K.ArgProof p] -> p + | _ -> assert false + else proof in + let proof'' = + { proof' with + K.proof_name = None; + K.proof_context = + (build_decl_item seed id n s ids_to_inner_sorts):: + proof'.K.proof_context + } + in + generate_intros_let_tac seed id n s true proof'' name ~ids_to_inner_types + else raise Not_a_proof + | C.ALetIn (id,n,s,t) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + let proof = aux t in + let proof' = + if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then + match proof.K.proof_conclude.K.conclude_args with + [K.ArgProof p] -> p + | _ -> assert false + else proof in + let proof'' = + { proof' with + K.proof_name = None; + K.proof_context = + ((build_def_item seed id n s ids_to_inner_sorts + ids_to_inner_types):> Cic.annterm K.in_proof_context_element) + ::proof'.K.proof_context; + } + in + generate_intros_let_tac seed id n s false proof'' name ~ids_to_inner_types + else raise Not_a_proof + | C.AAppl (id,li) -> + (try rewrite + seed name id li ~ids_to_inner_types ~ids_to_inner_sorts + with NotApplicable -> + try inductive + seed name id li ~ids_to_inner_types ~ids_to_inner_sorts + with NotApplicable -> + let subproofs, args = + build_subproofs_and_args + seed li ~ids_to_inner_types ~ids_to_inner_sorts in +(* + let args_to_lift = + List.filter (test_for_lifting ~ids_to_inner_types) li in + let subproofs = + match args_to_lift with + [_] -> List.map aux args_to_lift + | _ -> List.map (aux ~name:"H") args_to_lift in + let args = build_args seed li subproofs + ~ids_to_inner_types ~ids_to_inner_sorts in *) + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = []; + K.proof_apply_context = serialize seed subproofs; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Apply"; + K.conclude_args = args; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + }; + }) + | C.AConst (id,uri,exp_named_subst) as t -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + generate_exact seed t id name ~ids_to_inner_types + else raise Not_a_proof + | C.AMutInd (id,uri,i,exp_named_subst) -> raise Not_a_proof + | C.AMutConstruct (id,uri,i,j,exp_named_subst) as t -> + let sort = Hashtbl.find ids_to_inner_sorts id in + if sort = `Prop then + generate_exact seed t id name ~ids_to_inner_types + else raise Not_a_proof + | C.AMutCase (id,uri,typeno,ty,te,patterns) -> + let inductive_types,noparams = + (let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + Cic.Constant _ -> assert false + | Cic.Variable _ -> assert false + | Cic.CurrentProof _ -> assert false + | Cic.InductiveDefinition (l,_,n,_) -> l,n + ) in + let (_,_,_,constructors) = List.nth inductive_types typeno in + let name_and_arities = + let rec count_prods = + function + C.Prod (_,_,t) -> 1 + count_prods t + | _ -> 0 in + List.map + (function (n,t) -> Some n,((count_prods t) - noparams)) constructors in + let pp = + let build_proof p (name,arity) = + let rec make_context_and_body c p n = + if n = 0 then c,(aux p) + else + (match p with + Cic.ALambda(idl,vname,s1,t1) -> + let ce = + build_decl_item seed idl vname s1 ~ids_to_inner_sorts in + make_context_and_body (ce::c) t1 (n-1) + | _ -> assert false) in + let context,body = make_context_and_body [] p arity in + K.ArgProof + {body with K.proof_name = name; K.proof_context=context} in + List.map2 build_proof patterns name_and_arities in + let context,term = + (match + build_subproofs_and_args + seed ~ids_to_inner_types ~ids_to_inner_sorts [te] + with + l,[t] -> l,t + | _ -> assert false) in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = []; + K.proof_apply_context = serialize seed context; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Case"; + K.conclude_args = + (K.Aux (UriManager.string_of_uri uri)):: + (K.Aux (string_of_int typeno))::(K.Term ty)::term::pp; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + } + } + | C.AFix (id, no, funs) -> + let proofs = + List.map + (function (_,name,_,_,bo) -> `Proof (aux ~name bo)) funs in + let fun_name = + List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no + in + let decreasing_args = + List.map (function (_,_,n,_,_) -> n) funs in + let jo = + { K.joint_id = gen_id joint_prefix seed; + K.joint_kind = `Recursive decreasing_args; + K.joint_defs = proofs + } + in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = [`Joint jo]; + K.proof_apply_context = []; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Exact"; + K.conclude_args = + [ K.Premise + { K.premise_id = gen_id premise_prefix seed; + K.premise_xref = jo.K.joint_id; + K.premise_binder = Some fun_name; + K.premise_n = Some no; + } + ]; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + } + } + | C.ACoFix (id,no,funs) -> + let proofs = + List.map + (function (_,name,_,bo) -> `Proof (aux ~name bo)) funs in + let jo = + { K.joint_id = gen_id joint_prefix seed; + K.joint_kind = `CoRecursive; + K.joint_defs = proofs + } + in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = [`Joint jo]; + K.proof_apply_context = []; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Exact"; + K.conclude_args = + [ K.Premise + { K.premise_id = gen_id premise_prefix seed; + K.premise_xref = jo.K.joint_id; + K.premise_binder = Some "tiralo fuori"; + K.premise_n = Some no; + } + ]; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + }; + } + in + let id = get_id t in + generate_conversion seed false id t1 ~ids_to_inner_types +in aux ?name t + +and inductive seed name id li ~ids_to_inner_types ~ids_to_inner_sorts = + let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in + let module C2A = Cic2acic in + let module K = Content in + let module C = Cic in + match li with + C.AConst (idc,uri,exp_named_subst)::args -> + let uri_str = UriManager.string_of_uri uri in + let suffix = Str.regexp_string "_ind.con" in + let len = String.length uri_str in + let n = (try (Str.search_backward suffix uri_str len) + with Not_found -> -1) in + if n<0 then raise NotApplicable + else + let method_name = + if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists" + else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd" + else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd" + else "ByInduction" in + let prefix = String.sub uri_str 0 n in + let ind_str = (prefix ^ ".ind") in + let ind_uri = UriManager.uri_of_string ind_str in + let inductive_types,noparams = + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph ind_uri in + match o with + | Cic.InductiveDefinition (l,_,n,_) -> (l,n) + | _ -> assert false + ) in + let rec split n l = + if n = 0 then ([],l) else + let p,a = split (n-1) (List.tl l) in + ((List.hd l::p),a) in + let params_and_IP,tail_args = split (noparams+1) args in + let constructors = + (match inductive_types with + [(_,_,_,l)] -> l + | _ -> raise NotApplicable) (* don't care for mutual ind *) in + let constructors1 = + let rec clean_up n t = + if n = 0 then t else + (match t with + (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t) + | _ -> assert false) in + List.map (clean_up noparams) constructors in + let no_constructors= List.length constructors in + let args_for_cases, other_args = + split no_constructors tail_args in + let subproofs,other_method_args = + build_subproofs_and_args seed other_args + ~ids_to_inner_types ~ids_to_inner_sorts in + let method_args= + let rec build_method_args = + function + [],_-> [] (* extra args are ignored ???? *) + | (name,ty)::tlc,arg::tla -> + let idarg = get_id arg in + let sortarg = + (try (Hashtbl.find ids_to_inner_sorts idarg) + with Not_found -> `Type (CicUniv.fresh())) in + let hdarg = + if sortarg = `Prop then + let (co,bo) = + let rec bc = + function + Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) -> + let ce = + build_decl_item + seed idl n s1 ~ids_to_inner_sorts in + if (occur ind_uri s) then + ( match t1 with + Cic.ALambda(id2,n2,s2,t2) -> + let inductive_hyp = + `Hypothesis + { K.dec_name = name_of n2; + K.dec_id = + gen_id declaration_prefix seed; + K.dec_inductive = true; + K.dec_aref = id2; + K.dec_type = s2 + } in + let (context,body) = bc (t,t2) in + (ce::inductive_hyp::context,body) + | _ -> assert false) + else + ( + let (context,body) = bc (t,t1) in + (ce::context,body)) + | _ , t -> ([],aux t) in + bc (ty,arg) in + K.ArgProof + { bo with + K.proof_name = Some name; + K.proof_context = co; + }; + else (K.Term arg) in + hdarg::(build_method_args (tlc,tla)) + | _ -> assert false in + build_method_args (constructors1,args_for_cases) in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = []; + K.proof_apply_context = serialize seed subproofs; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = method_name; + K.conclude_args = + K.Aux (string_of_int no_constructors) + ::K.Term (C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP))) + ::method_args@other_method_args; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + } + } + | _ -> raise NotApplicable + +and rewrite seed name id li ~ids_to_inner_types ~ids_to_inner_sorts = + let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in + let module C2A = Cic2acic in + let module K = Content in + let module C = Cic in + match li with + C.AConst (sid,uri,exp_named_subst)::args -> + if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or + UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI or + LibraryObjects.is_eq_ind_URI uri or + LibraryObjects.is_eq_ind_r_URI uri then + let subproofs,arg = + (match + build_subproofs_and_args + seed ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3] + with + l,[p] -> l,p + | _,_ -> assert false) in + let method_args = + let rec ma_aux n = function + [] -> [] + | a::tl -> + let hd = + if n = 0 then arg + else + let aid = get_id a in + let asort = (try (Hashtbl.find ids_to_inner_sorts aid) + with Not_found -> `Type (CicUniv.fresh())) in + if asort = `Prop then + K.ArgProof (aux a) + else K.Term a in + hd::(ma_aux (n-1) tl) in + (ma_aux 3 args) in + { K.proof_name = name; + K.proof_id = gen_id proof_prefix seed; + K.proof_context = []; + K.proof_apply_context = serialize seed subproofs; + K.proof_conclude = + { K.conclude_id = gen_id conclude_prefix seed; + K.conclude_aref = id; + K.conclude_method = "Rewrite"; + K.conclude_args = + K.Term (C.AConst (sid,uri,exp_named_subst))::method_args; + K.conclude_conclusion = + try Some + (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized + with Not_found -> None + } + } + else raise NotApplicable + | _ -> raise NotApplicable +;; + +let map_conjectures + seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty) += + let module K = Content in + let context' = + List.map + (function + (id,None) -> None + | (id,Some (name,Cic.ADecl t)) -> + Some + (* We should call build_decl_item, but we have not computed *) + (* the inner-types ==> we always produce a declaration *) + (`Declaration + { K.dec_name = name_of name; + K.dec_id = gen_id declaration_prefix seed; + K.dec_inductive = false; + K.dec_aref = get_id t; + K.dec_type = t + }) + | (id,Some (name,Cic.ADef t)) -> + Some + (* We should call build_def_item, but we have not computed *) + (* the inner-types ==> we always produce a declaration *) + (`Definition + { K.def_name = name_of name; + K.def_id = gen_id definition_prefix seed; + K.def_aref = get_id t; + K.def_term = t + }) + ) context + in + (id,n,context',ty) +;; + +(* map_sequent is similar to map_conjectures, but the for the hid +of the hypothesis, which are preserved instead of generating +fresh ones. We shall have to adopt a uniform policy, soon or later *) + +let map_sequent ((id,n,context,ty):Cic.annconjecture) = + let module K = Content in + let context' = + List.map + (function + (id,None) -> None + | (id,Some (name,Cic.ADecl t)) -> + Some + (* We should call build_decl_item, but we have not computed *) + (* the inner-types ==> we always produce a declaration *) + (`Declaration + { K.dec_name = name_of name; + K.dec_id = id; + K.dec_inductive = false; + K.dec_aref = get_id t; + K.dec_type = t + }) + | (id,Some (name,Cic.ADef t)) -> + Some + (* We should call build_def_item, but we have not computed *) + (* the inner-types ==> we always produce a declaration *) + (`Definition + { K.def_name = name_of name; + K.def_id = id; + K.def_aref = get_id t; + K.def_term = t + }) + ) context + in + (id,n,context',ty) +;; + +let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types = + let module C = Cic in + let module K = Content in + let module C2A = Cic2acic in + let seed = ref 0 in + function + C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) -> + (gen_id object_prefix seed, params, + Some + (List.map + (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types) + conjectures), + `Def (K.Const,ty, + build_def_item seed (get_id bo) (C.Name n) bo + ~ids_to_inner_sorts ~ids_to_inner_types)) + | C.AConstant (_,_,n,Some bo,ty,params,_) -> + (gen_id object_prefix seed, params, None, + `Def (K.Const,ty, + build_def_item seed (get_id bo) (C.Name n) bo + ~ids_to_inner_sorts ~ids_to_inner_types)) + | C.AConstant (id,_,n,None,ty,params,_) -> + (gen_id object_prefix seed, params, None, + `Decl (K.Const, + build_decl_item seed id (C.Name n) ty + ~ids_to_inner_sorts)) + | C.AVariable (_,n,Some bo,ty,params,_) -> + (gen_id object_prefix seed, params, None, + `Def (K.Var,ty, + build_def_item seed (get_id bo) (C.Name n) bo + ~ids_to_inner_sorts ~ids_to_inner_types)) + | C.AVariable (id,n,None,ty,params,_) -> + (gen_id object_prefix seed, params, None, + `Decl (K.Var, + build_decl_item seed id (C.Name n) ty + ~ids_to_inner_sorts)) + | C.AInductiveDefinition (id,l,params,nparams,_) -> + (gen_id object_prefix seed, params, None, + `Joint + { K.joint_id = gen_id joint_prefix seed; + K.joint_kind = `Inductive nparams; + K.joint_defs = List.map (build_inductive seed) l + }) + +and + build_inductive seed = + let module K = Content in + fun (_,n,b,ty,l) -> + `Inductive + { K.inductive_id = gen_id inductive_prefix seed; + K.inductive_name = n; + K.inductive_kind = b; + K.inductive_type = ty; + K.inductive_constructors = build_constructors seed l + } + +and + build_constructors seed l = + let module K = Content in + List.map + (fun (n,t) -> + { K.dec_name = Some n; + K.dec_id = gen_id declaration_prefix seed; + K.dec_inductive = false; + K.dec_aref = ""; + K.dec_type = t + }) l +;; + +(* +and 'term cinductiveType = + id * string * bool * 'term * (* typename, inductive, arity *) + 'term cconstructor list (* constructors *) + +and 'term cconstructor = + string * 'term +*) + + diff --git a/helm/software/components/acic_content/acic2content.mli b/helm/software/components/acic_content/acic2content.mli new file mode 100644 index 000000000..e1dfb82de --- /dev/null +++ b/helm/software/components/acic_content/acic2content.mli @@ -0,0 +1,33 @@ +(* 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 annobj2content : + ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> + ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> + Cic.annobj -> + Cic.annterm Content.cobj + +val map_sequent : + Cic.annconjecture -> Cic.annterm Content.conjecture diff --git a/helm/software/components/acic_content/cicNotationEnv.ml b/helm/software/components/acic_content/cicNotationEnv.ml new file mode 100644 index 000000000..32d4f0df5 --- /dev/null +++ b/helm/software/components/acic_content/cicNotationEnv.ml @@ -0,0 +1,153 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +module Ast = CicNotationPt + +type value = + | TermValue of Ast.term + | StringValue of string + | NumValue of string + | OptValue of value option + | ListValue of value list + +type value_type = + | TermType + | StringType + | NumType + | OptType of value_type + | ListType of value_type + +exception Value_not_found of string +exception Type_mismatch of string * value_type + +type declaration = string * value_type +type binding = string * (value_type * value) +type t = binding list + +let lookup env name = + try + List.assoc name env + with Not_found -> raise (Value_not_found name) + +let lookup_value env name = + try + snd (List.assoc name env) + with Not_found -> raise (Value_not_found name) + +let remove_name env name = List.remove_assoc name env + +let remove_names env names = + List.filter (fun name, _ -> not (List.mem name names)) env + +let lookup_term env name = + match lookup env name with + | _, TermValue x -> x + | ty, _ -> raise (Type_mismatch (name, ty)) + +let lookup_num env name = + match lookup env name with + | _, NumValue x -> x + | ty, _ -> raise (Type_mismatch (name, ty)) + +let lookup_string env name = + match lookup env name with + | _, StringValue x -> x + | ty, _ -> raise (Type_mismatch (name, ty)) + +let lookup_opt env name = + match lookup env name with + | _, OptValue x -> x + | ty, _ -> raise (Type_mismatch (name, ty)) + +let lookup_list env name = + match lookup env name with + | _, ListValue x -> x + | ty, _ -> raise (Type_mismatch (name, ty)) + +let opt_binding_some (n, (ty, v)) = (n, (OptType ty, OptValue (Some v))) +let opt_binding_none (n, (ty, v)) = (n, (OptType ty, OptValue None)) +let opt_binding_of_name (n, ty) = (n, (OptType ty, OptValue None)) +let list_binding_of_name (n, ty) = (n, (ListType ty, ListValue [])) +let opt_declaration (n, ty) = (n, OptType ty) +let list_declaration (n, ty) = (n, ListType ty) + +let declaration_of_var = function + | Ast.NumVar s -> s, NumType + | Ast.IdentVar s -> s, StringType + | Ast.TermVar s -> s, TermType + | _ -> assert false + +let value_of_term = function + | Ast.Num (s, _) -> NumValue s + | Ast.Ident (s, None) -> StringValue s + | t -> TermValue t + +let term_of_value = function + | NumValue s -> Ast.Num (s, 0) + | StringValue s -> Ast.Ident (s, None) + | TermValue t -> t + | _ -> assert false (* TO BE UNDERSTOOD *) + +let rec well_typed ty value = + match ty, value with + | TermType, TermValue _ + | StringType, StringValue _ + | OptType _, OptValue None + | NumType, NumValue _ -> true + | OptType ty', OptValue (Some value') -> well_typed ty' value' + | ListType ty', ListValue vl -> + List.for_all (fun value' -> well_typed ty' value') vl + | _ -> false + +let declarations_of_env = List.map (fun (name, (ty, _)) -> (name, ty)) +let declarations_of_term p = + List.map declaration_of_var (CicNotationUtil.variables_of_term p) + +let rec combine decls values = + match decls, values with + | [], [] -> [] + | (name, ty) :: decls, v :: values -> + (name, (ty, v)) :: (combine decls values) + | _ -> assert false + +let coalesce_env declarations env_list = + let env0 = List.map list_binding_of_name declarations in + let grow_env_entry env n v = + List.map + (function + | (n', (ty, ListValue vl)) as entry -> + if n' = n then n', (ty, ListValue (v :: vl)) else entry + | _ -> assert false) + env + in + let grow_env env_i env = + List.fold_left + (fun env (n, (_, v)) -> grow_env_entry env n v) + env env_i + in + List.fold_right grow_env env_list env0 + diff --git a/helm/software/components/acic_content/cicNotationEnv.mli b/helm/software/components/acic_content/cicNotationEnv.mli new file mode 100644 index 000000000..d4f87097e --- /dev/null +++ b/helm/software/components/acic_content/cicNotationEnv.mli @@ -0,0 +1,92 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** {2 Types} *) + +type value = + | TermValue of CicNotationPt.term + | StringValue of string + | NumValue of string + | OptValue of value option + | ListValue of value list + +type value_type = + | TermType + | StringType + | NumType + | OptType of value_type + | ListType of value_type + + (** looked up value not found in environment *) +exception Value_not_found of string + + (** looked up value has the wrong type + * parameters are value name and value type in environment *) +exception Type_mismatch of string * value_type + +type declaration = string * value_type +type binding = string * (value_type * value) +type t = binding list + +val declaration_of_var: CicNotationPt.pattern_variable -> declaration +val value_of_term: CicNotationPt.term -> value +val term_of_value: value -> CicNotationPt.term +val well_typed: value_type -> value -> bool + +val declarations_of_env: t -> declaration list +val declarations_of_term: CicNotationPt.term -> declaration list +val combine: declaration list -> value list -> t (** @raise Invalid_argument *) + +(** {2 Environment lookup} *) + +val lookup_value: t -> string -> value (** @raise Value_not_found *) + +(** lookup_* functions below may raise Value_not_found and Type_mismatch *) + +val lookup_term: t -> string -> CicNotationPt.term +val lookup_string: t -> string -> string +val lookup_num: t -> string -> string +val lookup_opt: t -> string -> value option +val lookup_list: t -> string -> value list + +val remove_name: t -> string -> t +val remove_names: t -> string list -> t + +(** {2 Bindings mangling} *) + +val opt_binding_some: binding -> binding (* v -> Some v *) +val opt_binding_none: binding -> binding (* v -> None *) + +val opt_binding_of_name: declaration -> binding (* None binding *) +val list_binding_of_name: declaration -> binding (* [] binding *) + +val opt_declaration: declaration -> declaration (* t -> OptType t *) +val list_declaration: declaration -> declaration (* t -> ListType t *) + +(** given a list of environments bindings a set of names n_1, ..., n_k, returns + * a single environment where n_i is bound to the list of values bound in the + * starting environments *) +val coalesce_env: declaration list -> t list -> t + diff --git a/helm/software/components/acic_content/cicNotationPp.ml b/helm/software/components/acic_content/cicNotationPp.ml new file mode 100644 index 000000000..5dc6fd821 --- /dev/null +++ b/helm/software/components/acic_content/cicNotationPp.ml @@ -0,0 +1,325 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt +module Env = CicNotationEnv + + (* when set to true debugging information, not in sync with input syntax, will + * be added to the output of pp_term. + * set to false if you need, for example, cut and paste from matitac output to + * matitatop *) +let debug_printing = true + +let pp_binder = function + | `Lambda -> "lambda" + | `Pi -> "Pi" + | `Exists -> "exists" + | `Forall -> "forall" + +let pp_literal = + if debug_printing then + (function (* debugging version *) + | `Symbol s -> sprintf "symbol(%s)" s + | `Keyword s -> sprintf "keyword(%s)" s + | `Number s -> sprintf "number(%s)" s) + else + (function + | `Symbol s + | `Keyword s + | `Number s -> s) + +let pp_assoc = + function + | Gramext.NonA -> "NonA" + | Gramext.LeftA -> "LeftA" + | Gramext.RightA -> "RightA" + +let pp_pos = + function +(* `None -> "`None" *) + | `Left -> "`Left" + | `Right -> "`Right" + | `Inner -> "`Inner" + +let pp_attribute = + function + | `IdRef id -> sprintf "x(%s)" id + | `XmlAttrs attrs -> + sprintf "X(%s)" + (String.concat ";" + (List.map (fun (_, n, v) -> sprintf "%s=%s" n v) attrs)) + | `Level (prec, assoc) -> sprintf "L(%d%s)" prec (pp_assoc assoc) + | `Raw _ -> "R" + | `Loc _ -> "@" + | `ChildPos p -> sprintf "P(%s)" (pp_pos p) + +let rec pp_term ?(pp_parens = true) t = + let t_pp = + match t with + | Ast.AttributedTerm (attr, term) when debug_printing -> + sprintf "%s[%s]" (pp_attribute attr) (pp_term ~pp_parens:false term) + | Ast.AttributedTerm (`Raw text, _) -> text + | Ast.AttributedTerm (_, term) -> pp_term ~pp_parens:false term + | Ast.Appl terms -> + sprintf "%s" (String.concat " " (List.map pp_term terms)) + | Ast.Binder (`Forall, (Ast.Ident ("_", None), typ), body) + | Ast.Binder (`Pi, (Ast.Ident ("_", None), typ), body) -> + sprintf "%s \\to %s" + (match typ with None -> "?" | Some typ -> pp_term typ) + (pp_term body) + | Ast.Binder (kind, var, body) -> + sprintf "\\%s %s.%s" (pp_binder kind) (pp_capture_variable var) + (pp_term body) + | Ast.Case (term, indtype, typ, patterns) -> + sprintf "%smatch %s%s with %s" + (match typ with None -> "" | Some t -> sprintf "[%s]" (pp_term t)) + (pp_term term) + (match indtype with + | None -> "" + | Some (ty, href_opt) -> + sprintf " in %s%s" ty + (match debug_printing, href_opt with + | true, Some uri -> + sprintf "(i.e.%s)" (UriManager.string_of_uri uri) + | _ -> "")) + (pp_patterns patterns) + | Ast.Cast (t1, t2) -> sprintf "(%s: %s)" (pp_term t1) (pp_term t2) + | Ast.LetIn (var, t1, t2) -> + sprintf "let %s = %s in %s" (pp_capture_variable var) (pp_term t1) + (pp_term t2) + | Ast.LetRec (kind, definitions, term) -> + sprintf "let %s %s in %s" + (match kind with `Inductive -> "rec" | `CoInductive -> "corec") + (String.concat " and " + (List.map + (fun (var, body, _) -> + sprintf "%s = %s" (pp_capture_variable var) (pp_term body)) + definitions)) + (pp_term term) + | Ast.Ident (name, Some []) | Ast.Ident (name, None) + | Ast.Uri (name, Some []) | Ast.Uri (name, None) -> + name + | Ast.Ident (name, Some substs) + | Ast.Uri (name, Some substs) -> + sprintf "%s \\subst [%s]" name (pp_substs substs) + | Ast.Implicit -> "?" + | Ast.Meta (index, substs) -> + sprintf "%d[%s]" index + (String.concat "; " + (List.map (function None -> "_" | Some t -> pp_term t) substs)) + | Ast.Num (num, _) -> num + | Ast.Sort `Set -> "Set" + | Ast.Sort `Prop -> "Prop" + | Ast.Sort (`Type _) -> "Type" + | Ast.Sort `CProp -> "CProp" + | Ast.Symbol (name, _) -> "'" ^ name + + | Ast.UserInput -> "" + + | Ast.Literal l -> pp_literal l + | Ast.Layout l -> pp_layout l + | Ast.Magic m -> pp_magic m + | Ast.Variable v -> pp_variable v + in + if pp_parens then sprintf "(%s)" t_pp + else t_pp + +and pp_subst (name, term) = sprintf "%s \\Assign %s" name (pp_term term) +and pp_substs substs = String.concat "; " (List.map pp_subst substs) + +and pp_pattern ((head, href, vars), term) = + let head_pp = + head ^ + (match debug_printing, href with + | true, Some uri -> sprintf "(i.e.%s)" (UriManager.string_of_uri uri) + | _ -> "") + in + sprintf "%s \\Rightarrow %s" + (match vars with + | [] -> head_pp + | _ -> + sprintf "(%s %s)" head_pp + (String.concat " " (List.map pp_capture_variable vars))) + (pp_term term) + +and pp_patterns patterns = + sprintf "[%s]" (String.concat " | " (List.map pp_pattern patterns)) + +and pp_capture_variable = function + | term, None -> pp_term term + | term, Some typ -> "(" ^ pp_term term ^ ": " ^ pp_term typ ^ ")" + +and pp_box_spec (kind, spacing, indent) = + let int_of_bool b = if b then 1 else 0 in + let kind_string = + match kind with + Ast.H -> "H" | Ast.V -> "V" | Ast.HV -> "HV" | Ast.HOV -> "HOV" + in + sprintf "%sBOX%d%d" kind_string (int_of_bool spacing) (int_of_bool indent) + +and pp_layout = function + | Ast.Sub (t1, t2) -> sprintf "%s \\SUB %s" (pp_term t1) (pp_term t2) + | Ast.Sup (t1, t2) -> sprintf "%s \\SUP %s" (pp_term t1) (pp_term t2) + | Ast.Below (t1, t2) -> sprintf "%s \\BELOW %s" (pp_term t1) (pp_term t2) + | Ast.Above (t1, t2) -> sprintf "%s \\ABOVE %s" (pp_term t1) (pp_term t2) + | Ast.Over (t1, t2) -> sprintf "[%s \\OVER %s]" (pp_term t1) (pp_term t2) + | Ast.Atop (t1, t2) -> sprintf "[%s \\ATOP %s]" (pp_term t1) (pp_term t2) + | Ast.Frac (t1, t2) -> sprintf "\\FRAC %s %s" (pp_term t1) (pp_term t2) + | Ast.Sqrt t -> sprintf "\\SQRT %s" (pp_term t) + | Ast.Root (arg, index) -> + sprintf "\\ROOT %s \\OF %s" (pp_term index) (pp_term arg) + | Ast.Break -> "\\BREAK" +(* | Space -> "\\SPACE" *) + | Ast.Box (box_spec, terms) -> + sprintf "\\%s [%s]" (pp_box_spec box_spec) + (String.concat " " (List.map pp_term terms)) + | Ast.Group terms -> + sprintf "\\GROUP [%s]" (String.concat " " (List.map pp_term terms)) + +and pp_magic = function + | Ast.List0 (t, sep_opt) -> + sprintf "list0 %s%s" (pp_term t) (pp_sep_opt sep_opt) + | Ast.List1 (t, sep_opt) -> + sprintf "list1 %s%s" (pp_term t) (pp_sep_opt sep_opt) + | Ast.Opt t -> sprintf "opt %s" (pp_term t) + | Ast.Fold (kind, p_base, names, p_rec) -> + let acc = match names with acc :: _ -> acc | _ -> assert false in + sprintf "fold %s %s rec %s %s" + (pp_fold_kind kind) (pp_term p_base) acc (pp_term p_rec) + | Ast.Default (p_some, p_none) -> + sprintf "default %s %s" (pp_term p_some) (pp_term p_none) + | Ast.If (p_test, p_true, p_false) -> + sprintf "if %s then %s else %s" + (pp_term p_test) (pp_term p_true) (pp_term p_false) + | Ast.Fail -> "fail" + +and pp_fold_kind = function + | `Left -> "left" + | `Right -> "right" + +and pp_sep_opt = function + | None -> "" + | Some sep -> sprintf " sep %s" (pp_literal sep) + +and pp_variable = function + | Ast.NumVar s -> "number " ^ s + | Ast.IdentVar s -> "ident " ^ s + | Ast.TermVar s -> "term " ^ s + | Ast.Ascription (t, n) -> assert false + | Ast.FreshVar n -> "fresh " ^ n + +let pp_term t = pp_term ~pp_parens:false t + +let pp_params = function + | [] -> "" + | params -> + " " ^ + String.concat " " + (List.map + (fun (name, typ) -> sprintf "(%s:%s)" name (pp_term typ)) + params) + +let pp_flavour = function + | `Definition -> "Definition" + | `Fact -> "Fact" + | `Goal -> "Goal" + | `Lemma -> "Lemma" + | `Remark -> "Remark" + | `Theorem -> "Theorem" + | `Variant -> "Variant" + +let pp_fields fields = + (if fields <> [] then "\n" else "") ^ + String.concat ";\n" + (List.map + (fun (name,ty,coercion) -> + " " ^ name ^ if coercion then ":>" else ": " ^ pp_term ty) fields) + +let pp_obj = function + | Ast.Inductive (params, types) -> + let pp_constructors constructors = + String.concat "\n" + (List.map (fun (name, typ) -> sprintf "| %s: %s" name (pp_term typ)) + constructors) + in + let pp_type (name, _, typ, constructors) = + sprintf "\nwith %s: %s \\def\n%s" name (pp_term typ) + (pp_constructors constructors) + in + (match types with + | [] -> assert false + | (name, inductive, typ, constructors) :: tl -> + let fst_typ_pp = + sprintf "%sinductive %s%s: %s \\def\n%s" + (if inductive then "" else "co") name (pp_params params) + (pp_term typ) (pp_constructors constructors) + in + fst_typ_pp ^ String.concat "" (List.map pp_type tl)) + | Ast.Theorem (flavour, name, typ, body) -> + sprintf "%s %s: %s %s" + (pp_flavour flavour) + name + (pp_term typ) + (match body with + | None -> "" + | Some body -> "\\def " ^ pp_term body) + | Ast.Record (params,name,ty,fields) -> + "record " ^ name ^ " " ^ pp_params params ^ " \\def {" ^ + pp_fields fields ^ "}" + +let rec pp_value = function + | Env.TermValue t -> sprintf "$%s$" (pp_term t) + | Env.StringValue s -> sprintf "\"%s\"" s + | Env.NumValue n -> n + | Env.OptValue (Some v) -> "Some " ^ pp_value v + | Env.OptValue None -> "None" + | Env.ListValue l -> sprintf "[%s]" (String.concat "; " (List.map pp_value l)) + +let rec pp_value_type = + function + | Env.TermType -> "Term" + | Env.StringType -> "String" + | Env.NumType -> "Number" + | Env.OptType t -> "Maybe " ^ pp_value_type t + | Env.ListType l -> "List " ^ pp_value_type l + +let pp_env env = + String.concat "; " + (List.map + (fun (name, (ty, value)) -> + sprintf "%s : %s = %s" name (pp_value_type ty) (pp_value value)) + env) + +let rec pp_cic_appl_pattern = function + | Ast.UriPattern uri -> UriManager.string_of_uri uri + | Ast.VarPattern name -> name + | Ast.ImplicitPattern -> "_" + | Ast.ApplPattern aps -> + sprintf "(%s)" (String.concat " " (List.map pp_cic_appl_pattern aps)) + diff --git a/helm/software/components/acic_content/cicNotationPp.mli b/helm/software/components/acic_content/cicNotationPp.mli new file mode 100644 index 000000000..57a4d6b82 --- /dev/null +++ b/helm/software/components/acic_content/cicNotationPp.mli @@ -0,0 +1,37 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val pp_term: CicNotationPt.term -> string +val pp_obj: CicNotationPt.obj -> string + +val pp_env: CicNotationEnv.t -> string +val pp_value: CicNotationEnv.value -> string +val pp_value_type: CicNotationEnv.value_type -> string + +val pp_pos: CicNotationPt.child_pos -> string +val pp_attribute: CicNotationPt.term_attribute -> string + +val pp_cic_appl_pattern: CicNotationPt.cic_appl_pattern -> string + diff --git a/helm/software/components/acic_content/cicNotationPt.ml b/helm/software/components/acic_content/cicNotationPt.ml new file mode 100644 index 000000000..a66aa5feb --- /dev/null +++ b/helm/software/components/acic_content/cicNotationPt.ml @@ -0,0 +1,190 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +(** CIC Notation Parse Tree *) + +type binder_kind = [ `Lambda | `Pi | `Exists | `Forall ] +type induction_kind = [ `Inductive | `CoInductive ] +type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ] +type fold_kind = [ `Left | `Right ] + +type location = Token.flocation +let fail floc msg = + let (x, y) = HExtlib.loc_of_floc floc in + failwith (Printf.sprintf "Error at characters %d - %d: %s" x y msg) + +type href = UriManager.uri + +type child_pos = [ `Left | `Right | `Inner ] + +type term_attribute = + [ `Loc of location (* source file location *) + | `IdRef of string (* ACic pointer *) + | `Level of int * Gramext.g_assoc (* precedence, associativity *) + | `ChildPos of child_pos (* position of l1 pattern variables *) + | `XmlAttrs of (string option * string * string) list + (* list of XML attributes: namespace, name, value *) + | `Raw of string (* unparsed version *) + ] + +type literal = + [ `Symbol of string + | `Keyword of string + | `Number of string + ] + +type case_indtype = string * href option + +(** To be increased each time the term type below changes, used for "safe" + * marshalling *) +let magic = 1 + +type term = + (* CIC AST *) + + | AttributedTerm of term_attribute * term + + | Appl of term list + | Binder of binder_kind * capture_variable * term (* kind, name, body *) + | Case of term * case_indtype option * term option * + (case_pattern * term) list + (* what to match, inductive type, out type, list *) + | Cast of term * term + | LetIn of capture_variable * term * term (* name, body, where *) + | LetRec of induction_kind * (capture_variable * term * int) list * term + (* (name, body, decreasing argument) list, where *) + | Ident of string * subst list option + (* literal, substitutions. + * Some [] -> user has given an empty explicit substitution list + * None -> user has given no explicit substitution list *) + | Implicit + | Meta of int * meta_subst list + | Num of string * int (* literal, instance *) + | Sort of sort_kind + | Symbol of string * int (* canonical name, instance *) + + | UserInput (* place holder for user input, used by MatitaConsole, not to be + used elsewhere *) + | Uri of string * subst list option (* as Ident, for long names *) + + (* Syntax pattern extensions *) + + | Literal of literal + | Layout of layout_pattern + + | Magic of magic_term + | Variable of pattern_variable + + (* name, type. First component must be Ident or Variable (FreshVar _) *) +and capture_variable = term * term option + +and meta_subst = term option +and subst = string * term +and case_pattern = string * href option * capture_variable list + +and box_kind = H | V | HV | HOV +and box_spec = box_kind * bool * bool (* kind, spacing, indent *) + +and layout_pattern = + | Sub of term * term + | Sup of term * term + | Below of term * term + | Above of term * term + | Frac of term * term + | Over of term * term + | Atop of term * term +(* | array of term * literal option * literal option + |+ column separator, row separator +| *) + | Sqrt of term + | Root of term * term (* argument, index *) + | Break + | Box of box_spec * term list + | Group of term list + +and magic_term = + (* level 1 magics *) + | List0 of term * literal option (* pattern, separator *) + | List1 of term * literal option (* pattern, separator *) + | Opt of term + + (* level 2 magics *) + | Fold of fold_kind * term * string list * term + (* base case pattern, recursive case bound names, recursive case pattern *) + | Default of term * term (* "some" case pattern, "none" case pattern *) + | Fail + | If of term * term * term (* test, pattern if true, pattern if false *) + +and pattern_variable = + (* level 1 and 2 variables *) + | NumVar of string + | IdentVar of string + | TermVar of string + + (* level 1 variables *) + | Ascription of term * string + + (* level 2 variables *) + | FreshVar of string + +type argument_pattern = + | IdentArg of int * string (* eta-depth, name *) + +type cic_appl_pattern = + | UriPattern of UriManager.uri + | VarPattern of string + | ImplicitPattern + | ApplPattern of cic_appl_pattern list + + (** + * true means inductive, false coinductive *) +type 'term inductive_type = string * bool * 'term * (string * 'term) list + +type obj = + | Inductive of (string * term) list * term inductive_type list + (** parameters, list of loc * mutual inductive types *) + | Theorem of Cic.object_flavour * string * term * term option + (** flavour, name, type, body + * - name is absent when an unnamed theorem is being proved, tipically in + * interactive usage + * - body is present when its given along with the command, otherwise it + * will be given in proof editing mode using the tactical language + *) + | Record of (string * term) list * string * term * (string * term * bool) list + (** left parameters, name, type, fields *) + +(** {2 Standard precedences} *) + +let let_in_prec = 10 +let binder_prec = 20 +let apply_prec = 70 +let simple_prec = 90 + +let let_in_assoc = Gramext.NonA +let binder_assoc = Gramext.RightA +let apply_assoc = Gramext.LeftA +let simple_assoc = Gramext.NonA + diff --git a/helm/software/components/acic_content/cicNotationUtil.ml b/helm/software/components/acic_content/cicNotationUtil.ml new file mode 100644 index 000000000..8e487ed11 --- /dev/null +++ b/helm/software/components/acic_content/cicNotationUtil.ml @@ -0,0 +1,388 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +module Ast = CicNotationPt + +let visit_ast ?(special_k = fun _ -> assert false) k = + let rec aux = function + | Ast.Appl terms -> Ast.Appl (List.map k terms) + | Ast.Binder (kind, var, body) -> + Ast.Binder (kind, aux_capture_variable var, k body) + | Ast.Case (term, indtype, typ, patterns) -> + Ast.Case (k term, indtype, aux_opt typ, aux_patterns patterns) + | Ast.Cast (t1, t2) -> Ast.Cast (k t1, k t2) + | Ast.LetIn (var, t1, t2) -> + Ast.LetIn (aux_capture_variable var, k t1, k t2) + | Ast.LetRec (kind, definitions, term) -> + let definitions = + List.map + (fun (var, ty, n) -> aux_capture_variable var, k ty, n) + definitions + in + Ast.LetRec (kind, definitions, k term) + | Ast.Ident (name, Some substs) -> + Ast.Ident (name, Some (aux_substs substs)) + | Ast.Uri (name, Some substs) -> Ast.Uri (name, Some (aux_substs substs)) + | Ast.Meta (index, substs) -> Ast.Meta (index, List.map aux_opt substs) + | (Ast.AttributedTerm _ + | Ast.Layout _ + | Ast.Literal _ + | Ast.Magic _ + | Ast.Variable _) as t -> special_k t + | (Ast.Ident _ + | Ast.Implicit + | Ast.Num _ + | Ast.Sort _ + | Ast.Symbol _ + | Ast.Uri _ + | Ast.UserInput) as t -> t + and aux_opt = function + | None -> None + | Some term -> Some (k term) + and aux_capture_variable (term, typ_opt) = k term, aux_opt typ_opt + and aux_patterns patterns = List.map aux_pattern patterns + and aux_pattern ((head, hrefs, vars), term) = + ((head, hrefs, List.map aux_capture_variable vars), k term) + and aux_subst (name, term) = (name, k term) + and aux_substs substs = List.map aux_subst substs + in + aux + +let visit_layout k = function + | Ast.Sub (t1, t2) -> Ast.Sub (k t1, k t2) + | Ast.Sup (t1, t2) -> Ast.Sup (k t1, k t2) + | Ast.Below (t1, t2) -> Ast.Below (k t1, k t2) + | Ast.Above (t1, t2) -> Ast.Above (k t1, k t2) + | Ast.Over (t1, t2) -> Ast.Over (k t1, k t2) + | Ast.Atop (t1, t2) -> Ast.Atop (k t1, k t2) + | Ast.Frac (t1, t2) -> Ast.Frac (k t1, k t2) + | Ast.Sqrt t -> Ast.Sqrt (k t) + | Ast.Root (arg, index) -> Ast.Root (k arg, k index) + | Ast.Break -> Ast.Break + | Ast.Box (kind, terms) -> Ast.Box (kind, List.map k terms) + | Ast.Group terms -> Ast.Group (List.map k terms) + +let visit_magic k = function + | Ast.List0 (t, l) -> Ast.List0 (k t, l) + | Ast.List1 (t, l) -> Ast.List1 (k t, l) + | Ast.Opt t -> Ast.Opt (k t) + | Ast.Fold (kind, t1, names, t2) -> Ast.Fold (kind, k t1, names, k t2) + | Ast.Default (t1, t2) -> Ast.Default (k t1, k t2) + | Ast.If (t1, t2, t3) -> Ast.If (k t1, k t2, k t3) + | Ast.Fail -> Ast.Fail + +let visit_variable k = function + | Ast.NumVar _ + | Ast.IdentVar _ + | Ast.TermVar _ + | Ast.FreshVar _ as t -> t + | Ast.Ascription (t, s) -> Ast.Ascription (k t, s) + +let variables_of_term t = + let rec vars = ref [] in + let add_variable v = + if List.mem v !vars then () + else vars := v :: !vars + in + let rec aux = function + | Ast.Magic m -> Ast.Magic (visit_magic aux m) + | Ast.Layout l -> Ast.Layout (visit_layout aux l) + | Ast.Variable v -> Ast.Variable (aux_variable v) + | Ast.Literal _ as t -> t + | Ast.AttributedTerm (_, t) -> aux t + | t -> visit_ast aux t + and aux_variable = function + | (Ast.NumVar _ + | Ast.IdentVar _ + | Ast.TermVar _) as t -> + add_variable t ; + t + | Ast.FreshVar _ as t -> t + | Ast.Ascription _ -> assert false + in + ignore (aux t) ; + !vars + +let names_of_term t = + let aux = function + | Ast.NumVar s + | Ast.IdentVar s + | Ast.TermVar s -> s + | _ -> assert false + in + List.map aux (variables_of_term t) + +let keywords_of_term t = + let rec keywords = ref [] in + let add_keyword k = keywords := k :: !keywords in + let rec aux = function + | Ast.AttributedTerm (_, t) -> aux t + | Ast.Layout l -> Ast.Layout (visit_layout aux l) + | Ast.Literal (`Keyword k) as t -> + add_keyword k; + t + | Ast.Literal _ as t -> t + | Ast.Magic m -> Ast.Magic (visit_magic aux m) + | Ast.Variable _ as v -> v + | t -> visit_ast aux t + in + ignore (aux t) ; + !keywords + +let rec strip_attributes t = + let special_k = function + | Ast.AttributedTerm (_, term) -> strip_attributes term + | Ast.Magic m -> Ast.Magic (visit_magic strip_attributes m) + | Ast.Variable _ as t -> t + | t -> assert false + in + visit_ast ~special_k strip_attributes t + +let rec get_idrefs = + function + | Ast.AttributedTerm (`IdRef id, t) -> id :: get_idrefs t + | Ast.AttributedTerm (_, t) -> get_idrefs t + | _ -> [] + +let meta_names_of_term term = + let rec names = ref [] in + let add_name n = + if List.mem n !names then () + else names := n :: !names + in + let rec aux = function + | Ast.AttributedTerm (_, term) -> aux term + | Ast.Appl terms -> List.iter aux terms + | Ast.Binder (_, _, body) -> aux body + | Ast.Case (term, indty, outty_opt, patterns) -> + aux term ; + aux_opt outty_opt ; + List.iter aux_branch patterns + | Ast.LetIn (_, t1, t2) -> + aux t1 ; + aux t2 + | Ast.LetRec (_, definitions, body) -> + List.iter aux_definition definitions ; + aux body + | Ast.Uri (_, Some substs) -> aux_substs substs + | Ast.Ident (_, Some substs) -> aux_substs substs + | Ast.Meta (_, substs) -> aux_meta_substs substs + + | Ast.Implicit + | Ast.Ident _ + | Ast.Num _ + | Ast.Sort _ + | Ast.Symbol _ + | Ast.Uri _ + | Ast.UserInput -> () + + | Ast.Magic magic -> aux_magic magic + | Ast.Variable var -> aux_variable var + + | _ -> assert false + and aux_opt = function + | Some term -> aux term + | None -> () + and aux_capture_var (_, ty_opt) = aux_opt ty_opt + and aux_branch (pattern, term) = + aux_pattern pattern ; + aux term + and aux_pattern (head, _, vars) = + List.iter aux_capture_var vars + and aux_definition (var, term, i) = + aux_capture_var var ; + aux term + and aux_substs substs = List.iter (fun (_, term) -> aux term) substs + and aux_meta_substs meta_substs = List.iter aux_opt meta_substs + and aux_variable = function + | Ast.NumVar name -> add_name name + | Ast.IdentVar name -> add_name name + | Ast.TermVar name -> add_name name + | Ast.FreshVar _ -> () + | Ast.Ascription _ -> assert false + and aux_magic = function + | Ast.Default (t1, t2) + | Ast.Fold (_, t1, _, t2) -> + aux t1 ; + aux t2 + | Ast.If (t1, t2, t3) -> + aux t1 ; + aux t2 ; + aux t3 + | Ast.Fail -> () + | _ -> assert false + in + aux term ; + !names + +let rectangular matrix = + let columns = Array.length matrix.(0) in + try + Array.iter (fun a -> if Array.length a <> columns then raise Exit) matrix; + true + with Exit -> false + +let ncombine ll = + let matrix = Array.of_list (List.map Array.of_list ll) in + assert (rectangular matrix); + let rows = Array.length matrix in + let columns = Array.length matrix.(0) in + let lists = ref [] in + for j = 0 to columns - 1 do + let l = ref [] in + for i = 0 to rows - 1 do + l := matrix.(i).(j) :: !l + done; + lists := List.rev !l :: !lists + done; + List.rev !lists + +let string_of_literal = function + | `Symbol s + | `Keyword s + | `Number s -> s + +let boxify = function + | [ a ] -> a + | l -> Ast.Layout (Ast.Box ((Ast.H, false, false), l)) + +let unboxify = function + | Ast.Layout (Ast.Box ((Ast.H, false, false), [ a ])) -> a + | l -> l + +let group = function + | [ a ] -> a + | l -> Ast.Layout (Ast.Group l) + +let ungroup = + let rec aux acc = + function + [] -> List.rev acc + | Ast.Layout (Ast.Group terms) :: terms' -> aux acc (terms @ terms') + | term :: terms -> aux (term :: acc) terms + in + aux [] + +let dress ~sep:sauce = + let rec aux = + function + | [] -> [] + | [hd] -> [hd] + | hd :: tl -> hd :: sauce :: aux tl + in + aux + +let dressn ~sep:sauces = + let rec aux = + function + | [] -> [] + | [hd] -> [hd] + | hd :: tl -> hd :: sauces @ aux tl + in + aux + +let find_appl_pattern_uris ap = + let rec aux acc = + function + | Ast.UriPattern uri -> uri :: acc + | Ast.ImplicitPattern + | Ast.VarPattern _ -> acc + | Ast.ApplPattern apl -> List.fold_left aux acc apl + in + let uris = aux [] ap in + HExtlib.list_uniq (List.fast_sort UriManager.compare uris) + +let rec find_branch = + function + Ast.Magic (Ast.If (_, Ast.Magic Ast.Fail, t)) -> find_branch t + | Ast.Magic (Ast.If (_, t, _)) -> find_branch t + | t -> t + +let cic_name_of_name = function + | Ast.Ident ("_", None) -> Cic.Anonymous + | Ast.Ident (name, None) -> Cic.Name name + | _ -> assert false + +let name_of_cic_name = +(* let add_dummy_xref t = Ast.AttributedTerm (`IdRef "", t) in *) + (* ZACK why we used to generate dummy xrefs? *) + let add_dummy_xref t = t in + function + | Cic.Name s -> add_dummy_xref (Ast.Ident (s, None)) + | Cic.Anonymous -> add_dummy_xref (Ast.Ident ("_", None)) + +let fresh_index = ref ~-1 + +type notation_id = int + +let fresh_id () = + incr fresh_index; + !fresh_index + + (* TODO ensure that names generated by fresh_var do not clash with user's *) +let fresh_name () = "fresh" ^ string_of_int (fresh_id ()) + +let rec freshen_term ?(index = ref 0) term = + let freshen_term = freshen_term ~index in + let fresh_instance () = incr index; !index in + let special_k = function + | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, freshen_term t) + | Ast.Layout l -> Ast.Layout (visit_layout freshen_term l) + | Ast.Magic m -> Ast.Magic (visit_magic freshen_term m) + | Ast.Variable v -> Ast.Variable (visit_variable freshen_term v) + | Ast.Literal _ as t -> t + | _ -> assert false + in + match term with + | Ast.Symbol (s, instance) -> Ast.Symbol (s, fresh_instance ()) + | Ast.Num (s, instance) -> Ast.Num (s, fresh_instance ()) + | t -> visit_ast ~special_k freshen_term t + +let freshen_obj obj = + let index = ref 0 in + let freshen_term = freshen_term ~index in + let freshen_name_ty = List.map (fun (n, t) -> (n, freshen_term t)) in + let freshen_name_ty_b = List.map (fun (n, t, b) -> (n, freshen_term t, b)) in + match obj with + | CicNotationPt.Inductive (params, indtypes) -> + let indtypes = + List.map + (fun (n, co, ty, ctors) -> (n, co, ty, freshen_name_ty ctors)) + indtypes + in + CicNotationPt.Inductive (freshen_name_ty params, indtypes) + | CicNotationPt.Theorem (flav, n, t, ty_opt) -> + let ty_opt = + match ty_opt with None -> None | Some ty -> Some (freshen_term ty) + in + CicNotationPt.Theorem (flav, n, freshen_term t, ty_opt) + | CicNotationPt.Record (params, n, ty, fields) -> + CicNotationPt.Record (freshen_name_ty params, n, freshen_term ty, + freshen_name_ty_b fields) + +let freshen_term = freshen_term ?index:None + diff --git a/helm/software/components/acic_content/cicNotationUtil.mli b/helm/software/components/acic_content/cicNotationUtil.mli new file mode 100644 index 000000000..5d309d68f --- /dev/null +++ b/helm/software/components/acic_content/cicNotationUtil.mli @@ -0,0 +1,91 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val fresh_name: unit -> string + +val variables_of_term: CicNotationPt.term -> CicNotationPt.pattern_variable list +val names_of_term: CicNotationPt.term -> string list + + (** extract all keywords (i.e. string literals) from a level 1 pattern *) +val keywords_of_term: CicNotationPt.term -> string list + +val visit_ast: + ?special_k:(CicNotationPt.term -> CicNotationPt.term) -> + (CicNotationPt.term -> CicNotationPt.term) -> + CicNotationPt.term -> + CicNotationPt.term + +val visit_layout: + (CicNotationPt.term -> CicNotationPt.term) -> + CicNotationPt.layout_pattern -> + CicNotationPt.layout_pattern + +val visit_magic: + (CicNotationPt.term -> CicNotationPt.term) -> + CicNotationPt.magic_term -> + CicNotationPt.magic_term + +val visit_variable: + (CicNotationPt.term -> CicNotationPt.term) -> + CicNotationPt.pattern_variable -> + CicNotationPt.pattern_variable + +val strip_attributes: CicNotationPt.term -> CicNotationPt.term + + (** @return the list of proper (i.e. non recursive) IdRef of a term *) +val get_idrefs: CicNotationPt.term -> string list + + (** generalization of List.combine to n lists *) +val ncombine: 'a list list -> 'a list list + +val string_of_literal: CicNotationPt.literal -> string + +val dress: sep:'a -> 'a list -> 'a list +val dressn: sep:'a list -> 'a list -> 'a list + +val boxify: CicNotationPt.term list -> CicNotationPt.term +val group: CicNotationPt.term list -> CicNotationPt.term +val ungroup: CicNotationPt.term list -> CicNotationPt.term list + +val find_appl_pattern_uris: + CicNotationPt.cic_appl_pattern -> UriManager.uri list + +val find_branch: + CicNotationPt.term -> CicNotationPt.term + +val cic_name_of_name: CicNotationPt.term -> Cic.name +val name_of_cic_name: Cic.name -> CicNotationPt.term + + (** Symbol/Numbers instances *) + +val freshen_term: CicNotationPt.term -> CicNotationPt.term +val freshen_obj: CicNotationPt.obj -> CicNotationPt.obj + + (** Notation id handling *) + +type notation_id + +val fresh_id: unit -> notation_id + diff --git a/helm/software/components/acic_content/content.ml b/helm/software/components/acic_content/content.ml new file mode 100644 index 000000000..22733dcaa --- /dev/null +++ b/helm/software/components/acic_content/content.ml @@ -0,0 +1,169 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 16/6/2003 *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +type id = string;; +type joint_recursion_kind = + [ `Recursive of int list + | `CoRecursive + | `Inductive of int (* paramsno *) + | `CoInductive of int (* paramsno *) + ] +;; + +type var_or_const = Var | Const;; + +type 'term declaration = + { dec_name : string option; + dec_id : id ; + dec_inductive : bool; + dec_aref : string; + dec_type : 'term + } +;; + +type 'term definition = + { def_name : string option; + def_id : id ; + def_aref : string ; + def_term : 'term + } +;; + +type 'term inductive = + { inductive_id : id ; + inductive_name : string; + inductive_kind : bool; + inductive_type : 'term; + inductive_constructors : 'term declaration list + } +;; + +type 'term decl_context_element = + [ `Declaration of 'term declaration + | `Hypothesis of 'term declaration + ] +;; + +type ('term,'proof) def_context_element = + [ `Proof of 'proof + | `Definition of 'term definition + ] +;; + +type ('term,'proof) in_joint_context_element = + [ `Inductive of 'term inductive + | 'term decl_context_element + | ('term,'proof) def_context_element + ] +;; + +type ('term,'proof) joint = + { joint_id : id ; + joint_kind : joint_recursion_kind ; + joint_defs : ('term,'proof) in_joint_context_element list + } +;; + +type ('term,'proof) joint_context_element = + [ `Joint of ('term,'proof) joint ] +;; + +type 'term proof = + { proof_name : string option; + proof_id : id ; + proof_context : 'term in_proof_context_element list ; + proof_apply_context: 'term proof list; + proof_conclude : 'term conclude_item + } + +and 'term in_proof_context_element = + [ 'term decl_context_element + | ('term,'term proof) def_context_element + | ('term,'term proof) joint_context_element + ] + +and 'term conclude_item = + { conclude_id : id; + conclude_aref : string; + conclude_method : string; + conclude_args : ('term arg) list ; + conclude_conclusion : 'term option + } + +and 'term arg = + Aux of string + | Premise of premise + | Lemma of lemma + | Term of 'term + | ArgProof of 'term proof + | ArgMethod of string (* ???? *) + +and premise = + { premise_id: id; + premise_xref : string ; + premise_binder : string option; + premise_n : int option; + } + +and lemma = + { lemma_id: id; + lemma_name: string; + lemma_uri: string + } + +;; + +type 'term conjecture = id * int * 'term context * 'term + +and 'term context = 'term hypothesis list + +and 'term hypothesis = + ['term decl_context_element | ('term,'term proof) def_context_element ] option +;; + +type 'term in_object_context_element = + [ `Decl of var_or_const * 'term decl_context_element + | `Def of var_or_const * 'term * ('term,'term proof) def_context_element + | ('term,'term proof) joint_context_element + ] +;; + +type 'term cobj = + id * (* id *) + UriManager.uri list * (* params *) + 'term conjecture list option * (* optional metasenv *) + 'term in_object_context_element (* actual object *) +;; diff --git a/helm/software/components/acic_content/content.mli b/helm/software/components/acic_content/content.mli new file mode 100644 index 000000000..c1122b8f2 --- /dev/null +++ b/helm/software/components/acic_content/content.mli @@ -0,0 +1,157 @@ +(* 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/. + *) + +type id = string;; +type joint_recursion_kind = + [ `Recursive of int list (* decreasing arguments *) + | `CoRecursive + | `Inductive of int (* paramsno *) + | `CoInductive of int (* paramsno *) + ] +;; + +type var_or_const = Var | Const;; + +type 'term declaration = + { dec_name : string option; + dec_id : id ; + dec_inductive : bool; + dec_aref : string; + dec_type : 'term + } +;; + +type 'term definition = + { def_name : string option; + def_id : id ; + def_aref : string ; + def_term : 'term + } +;; + +type 'term inductive = + { inductive_id : id ; + inductive_name : string; + inductive_kind : bool; + inductive_type : 'term; + inductive_constructors : 'term declaration list + } +;; + +type 'term decl_context_element = + [ `Declaration of 'term declaration + | `Hypothesis of 'term declaration + ] +;; + +type ('term,'proof) def_context_element = + [ `Proof of 'proof + | `Definition of 'term definition + ] +;; + +type ('term,'proof) in_joint_context_element = + [ `Inductive of 'term inductive + | 'term decl_context_element + | ('term,'proof) def_context_element + ] +;; + +type ('term,'proof) joint = + { joint_id : id ; + joint_kind : joint_recursion_kind ; + joint_defs : ('term,'proof) in_joint_context_element list + } +;; + +type ('term,'proof) joint_context_element = + [ `Joint of ('term,'proof) joint ] +;; + +type 'term proof = + { proof_name : string option; + proof_id : id ; + proof_context : 'term in_proof_context_element list ; + proof_apply_context: 'term proof list; + proof_conclude : 'term conclude_item + } + +and 'term in_proof_context_element = + [ 'term decl_context_element + | ('term,'term proof) def_context_element + | ('term,'term proof) joint_context_element + ] + +and 'term conclude_item = + { conclude_id : id; + conclude_aref : string; + conclude_method : string; + conclude_args : ('term arg) list ; + conclude_conclusion : 'term option + } + +and 'term arg = + Aux of string + | Premise of premise + | Lemma of lemma + | Term of 'term + | ArgProof of 'term proof + | ArgMethod of string (* ???? *) + +and premise = + { premise_id: id; + premise_xref : string ; + premise_binder : string option; + premise_n : int option; + } + +and lemma = + { lemma_id: id; + lemma_name : string; + lemma_uri: string + } +;; + +type 'term conjecture = id * int * 'term context * 'term + +and 'term context = 'term hypothesis list + +and 'term hypothesis = + ['term decl_context_element | ('term,'term proof) def_context_element ] option +;; + +type 'term in_object_context_element = + [ `Decl of var_or_const * 'term decl_context_element + | `Def of var_or_const * 'term * ('term,'term proof) def_context_element + | ('term,'term proof) joint_context_element + ] +;; + +type 'term cobj = + id * (* id *) + UriManager.uri list * (* params *) + 'term conjecture list option * (* optional metasenv *) + 'term in_object_context_element (* actual object *) +;; diff --git a/helm/software/components/acic_content/content2cic.ml b/helm/software/components/acic_content/content2cic.ml new file mode 100644 index 000000000..9acea81fa --- /dev/null +++ b/helm/software/components/acic_content/content2cic.ml @@ -0,0 +1,270 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 17/06/2003 *) +(* *) +(***************************************************************************) + +(* $Id$ *) + +exception TO_DO;; + +let proof2cic deannotate p = + let rec proof2cic premise_env p = + let module C = Cic in + let module Con = Content in + let rec extend_premise_env current_env = + function + [] -> current_env + | p::atl -> + extend_premise_env + ((p.Con.proof_id,(proof2cic current_env p))::current_env) atl in + let new_premise_env = extend_premise_env premise_env p.Con.proof_apply_context in + let body = conclude2cic new_premise_env p.Con.proof_conclude in + context2cic premise_env p.Con.proof_context body + + and context2cic premise_env context body = + List.fold_right (ce2cic premise_env) context body + + and ce2cic premise_env ce target = + let module C = Cic in + let module Con = Content in + match ce with + `Declaration d -> + (match d.Con.dec_name with + Some s -> + C.Lambda (C.Name s, deannotate d.Con.dec_type, target) + | None -> + C.Lambda (C.Anonymous, deannotate d.Con.dec_type, target)) + | `Hypothesis h -> + (match h.Con.dec_name with + Some s -> + C.Lambda (C.Name s, deannotate h.Con.dec_type, target) + | None -> + C.Lambda (C.Anonymous, deannotate h.Con.dec_type, target)) + | `Proof p -> + (match p.Con.proof_name with + Some s -> + C.LetIn (C.Name s, proof2cic premise_env p, target) + | None -> + C.LetIn (C.Anonymous, proof2cic premise_env p, target)) + | `Definition d -> + (match d.Con.def_name with + Some s -> + C.LetIn (C.Name s, proof2cic premise_env p, target) + | None -> + C.LetIn (C.Anonymous, proof2cic premise_env p, target)) + | `Joint {Con.joint_kind = kind; Con.joint_defs = defs} -> + (match target with + C.Rel n -> + (match kind with + `Recursive l -> + let funs = + List.map2 + (fun n bo -> + match bo with + `Proof bo -> + (match + bo.Con.proof_conclude.Con.conclude_conclusion, + bo.Con.proof_name + with + Some ty, Some name -> + (name,n,deannotate ty, + proof2cic premise_env bo) + | _,_ -> assert false) + | _ -> assert false) + l defs in + C.Fix (n, funs) + | `CoRecursive -> + let funs = + List.map + (function bo -> + match bo with + `Proof bo -> + (match + bo.Con.proof_conclude.Con.conclude_conclusion, + bo.Con.proof_name + with + Some ty, Some name -> + (name,deannotate ty, + proof2cic premise_env bo) + | _,_ -> assert false) + | _ -> assert false) + defs in + C.CoFix (n, funs) + | _ -> (* no inductive types in local contexts *) + assert false) + | _ -> assert false) + + and conclude2cic premise_env conclude = + let module C = Cic in + let module Con = Content in + if conclude.Con.conclude_method = "TD_Conversion" then + (match conclude.Con.conclude_args with + [Con.ArgProof p] -> proof2cic [] p (* empty! *) + | _ -> prerr_endline "1"; assert false) + else if conclude.Con.conclude_method = "BU_Conversion" then + (match conclude.Con.conclude_args with + [Con.Premise prem] -> + (try List.assoc prem.Con.premise_xref premise_env + with Not_found -> + prerr_endline + ("Not_found in BU_Conversion: " ^ prem.Con.premise_xref); + raise Not_found) + | _ -> prerr_endline "2"; assert false) + else if conclude.Con.conclude_method = "Exact" then + (match conclude.Con.conclude_args with + [Con.Term t] -> deannotate t + | [Con.Premise prem] -> + (match prem.Con.premise_n with + None -> assert false + | Some n -> C.Rel n) + | _ -> prerr_endline "3"; assert false) + else if conclude.Con.conclude_method = "Intros+LetTac" then + (match conclude.Con.conclude_args with + [Con.ArgProof p] -> proof2cic [] p (* empty! *) + | _ -> prerr_endline "4"; assert false) + else if (conclude.Con.conclude_method = "ByInduction" || + conclude.Con.conclude_method = "AndInd" || + conclude.Con.conclude_method = "Exists" || + conclude.Con.conclude_method = "FalseInd") then + (match (List.tl conclude.Con.conclude_args) with + Con.Term (C.AAppl ( + id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))::args -> + let subst = + List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in + let cargs = args2cic premise_env args in + let cparams_and_IP = List.map deannotate params_and_IP in + C.Appl (C.Const(uri,subst)::cparams_and_IP@cargs) + | _ -> prerr_endline "5"; assert false) + else if (conclude.Con.conclude_method = "Rewrite") then + (match conclude.Con.conclude_args with + Con.Term (C.AConst (sid,uri,exp_named_subst))::args -> + let subst = + List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in + let cargs = args2cic premise_env args in + C.Appl (C.Const(uri,subst)::cargs) + | _ -> prerr_endline "6"; assert false) + else if (conclude.Con.conclude_method = "Case") then + (match conclude.Con.conclude_args with + Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Premise(prem)::patterns -> + C.MutCase + (UriManager.uri_of_string uri, + int_of_string notype, deannotate ty, + List.assoc prem.Con.premise_xref premise_env, + List.map + (function + Con.ArgProof p -> proof2cic [] p + | _ -> prerr_endline "7a"; assert false) patterns) + | Con.Aux(uri)::Con.Aux(notype)::Con.Term(ty)::Con.Term(te)::patterns -> C.MutCase + (UriManager.uri_of_string uri, + int_of_string notype, deannotate ty, deannotate te, + List.map + (function + (Con.ArgProof p) -> proof2cic [] p + | _ -> prerr_endline "7a"; assert false) patterns) + | _ -> (prerr_endline "7"; assert false)) + else if (conclude.Con.conclude_method = "Apply") then + let cargs = (args2cic premise_env conclude.Con.conclude_args) in + C.Appl cargs + else (prerr_endline "8"; assert false) + + and args2cic premise_env l = + List.map (arg2cic premise_env) l + + and arg2cic premise_env = + let module C = Cic in + let module Con = Content in + function + Con.Aux n -> prerr_endline "8"; assert false + | Con.Premise prem -> + (match prem.Con.premise_n with + Some n -> C.Rel n + | None -> + (try List.assoc prem.Con.premise_xref premise_env + with Not_found -> + prerr_endline ("Not_found in arg2cic: premise " ^ (match prem.Con.premise_binder with None -> "previous" | Some p -> p) ^ ", xref=" ^ prem.Con.premise_xref); + raise Not_found)) + | Con.Lemma lemma -> + CicUtil.term_of_uri (UriManager.uri_of_string lemma.Con.lemma_uri) + | Con.Term t -> deannotate t + | Con.ArgProof p -> proof2cic [] p (* empty! *) + | Con.ArgMethod s -> raise TO_DO + +in proof2cic [] p +;; + +exception ToDo;; + +let cobj2obj deannotate (id,params,metasenv,obj) = + let module K = Content in + match obj with + `Def (Content.Const,ty,`Proof bo) -> + (match metasenv with + None -> + Cic.Constant + (id, Some (proof2cic deannotate bo), deannotate ty, params, []) + | Some metasenv' -> + let metasenv'' = + List.map + (function (_,i,canonical_context,term) -> + let canonical_context' = + List.map + (function + None -> None + | Some (`Declaration d) + | Some (`Hypothesis d) -> + (match d with + {K.dec_name = Some n ; K.dec_type = t} -> + Some (Cic.Name n, Cic.Decl (deannotate t)) + | _ -> assert false) + | Some (`Definition d) -> + (match d with + {K.def_name = Some n ; K.def_term = t} -> + Some (Cic.Name n, Cic.Def ((deannotate t),None)) + | _ -> assert false) + | Some (`Proof d) -> + (match d with + {K.proof_name = Some n } -> + Some (Cic.Name n, + Cic.Def ((proof2cic deannotate d),None)) + | _ -> assert false) + ) canonical_context + in + (i,canonical_context',deannotate term) + ) metasenv' + in + Cic.CurrentProof + (id, metasenv'', proof2cic deannotate bo, deannotate ty, params, + [])) + | _ -> raise ToDo +;; + +let cobj2obj = cobj2obj Deannotate.deannotate_term;; diff --git a/helm/software/components/acic_content/content2cic.mli b/helm/software/components/acic_content/content2cic.mli new file mode 100644 index 000000000..9bb6509cc --- /dev/null +++ b/helm/software/components/acic_content/content2cic.mli @@ -0,0 +1,35 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 27/6/2003 *) +(* *) +(**************************************************************************) + +val cobj2obj : Cic.annterm Content.cobj -> Cic.obj diff --git a/helm/software/components/acic_content/contentPp.ml b/helm/software/components/acic_content/contentPp.ml new file mode 100644 index 000000000..ca89fad7d --- /dev/null +++ b/helm/software/components/acic_content/contentPp.ml @@ -0,0 +1,158 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 17/06/2003 *) +(* *) +(***************************************************************************) + +(* $Id$ *) + +exception ContentPpInternalError;; +exception NotEnoughElements;; +exception TO_DO + +(* Utility functions *) + + +let string_of_name = + function + Some s -> s + | None -> "_" +;; + +(* get_nth l n returns the nth element of the list l if it exists or *) +(* raises NotEnoughElements if l has less than n elements *) +let rec get_nth l n = + match (n,l) with + (1, he::_) -> he + | (n, he::tail) when n > 1 -> get_nth tail (n-1) + | (_,_) -> raise NotEnoughElements +;; + +let rec blanks n = + if n = 0 then "" + else (" " ^ (blanks (n-1)));; + +let rec pproof (p: Cic.annterm Content.proof) indent = + let module Con = Content in + let new_indent = + (match p.Con.proof_name with + Some s -> + prerr_endline + ((blanks indent) ^ "(" ^ s ^ ")"); flush stderr ;(indent + 1) + | None ->indent) in + let new_indent1 = + if (p.Con.proof_context = []) then new_indent + else + (pcontext p.Con.proof_context new_indent; (new_indent + 1)) in + papply_context p.Con.proof_apply_context new_indent1; + pconclude p.Con.proof_conclude new_indent1; + +and pcontext c indent = + List.iter (pcontext_element indent) c + +and pcontext_element indent = + let module Con = Content in + function + `Declaration d -> + (match d.Con.dec_name with + Some s -> + prerr_endline + ((blanks indent) + ^ "Assume " ^ s ^ " : " + ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.dec_type))); + flush stderr + | None -> + prerr_endline ((blanks indent) ^ "NO NAME!!")) + | `Hypothesis h -> + (match h.Con.dec_name with + Some s -> + prerr_endline + ((blanks indent) + ^ "Suppose " ^ s ^ " : " + ^ (CicPp.ppterm (Deannotate.deannotate_term h.Con.dec_type))); + flush stderr + | None -> + prerr_endline ((blanks indent) ^ "NO NAME!!")) + | `Proof p -> pproof p indent + | `Definition d -> + (match d.Con.def_name with + Some s -> + prerr_endline + ((blanks indent) ^ "Let " ^ s ^ " = " + ^ (CicPp.ppterm (Deannotate.deannotate_term d.Con.def_term))); + flush stderr + | None -> + prerr_endline ((blanks indent) ^ "NO NAME!!")) + | `Joint ho -> + prerr_endline ((blanks indent) ^ "Joint Def"); + flush stderr + +and papply_context ac indent = + List.iter(function p -> (pproof p indent)) ac + +and pconclude concl indent = + let module Con = Content in + prerr_endline ((blanks indent) ^ "Apply method " ^ concl.Con.conclude_method ^ " to");flush stderr; + pargs concl.Con.conclude_args indent; + match concl.Con.conclude_conclusion with + None -> prerr_endline ((blanks indent) ^"No conclude conclusion");flush stderr + | Some t -> prerr_endline ((blanks indent) ^ "conclude" ^ concl.Con.conclude_method ^ (CicPp.ppterm (Deannotate.deannotate_term t)));flush stderr + +and pargs args indent = + List.iter (parg indent) args + +and parg indent = + let module Con = Content in + function + Con.Aux n -> prerr_endline ((blanks (indent+1)) ^ n) + | Con.Premise prem -> prerr_endline ((blanks (indent+1)) ^ "Premise") + | Con.Lemma lemma -> prerr_endline ((blanks (indent+1)) ^ "Lemma") + | Con.Term t -> + prerr_endline ((blanks (indent+1)) ^ (CicPp.ppterm (Deannotate.deannotate_term t))) + | Con.ArgProof p -> pproof p (indent+1) + | Con.ArgMethod s -> prerr_endline ((blanks (indent+1)) ^ "A Method !!!") +;; + +let print_proof p = pproof p 0;; + +let print_obj (_,_,_,obj) = + match obj with + `Decl (_,decl) -> + pcontext_element 0 (decl:> Cic.annterm Content.in_proof_context_element) + | `Def (_,_,def) -> + pcontext_element 0 (def:> Cic.annterm Content.in_proof_context_element) + | `Joint _ as jo -> pcontext_element 0 jo +;; + + + + + diff --git a/helm/software/components/acic_content/contentPp.mli b/helm/software/components/acic_content/contentPp.mli new file mode 100644 index 000000000..a160ab1ff --- /dev/null +++ b/helm/software/components/acic_content/contentPp.mli @@ -0,0 +1,30 @@ +(* 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 print_proof: Cic.annterm Content.proof -> unit + +val print_obj: Cic.annterm Content.cobj -> unit + +val parg: int -> Cic.annterm Content.arg ->unit diff --git a/helm/software/components/acic_content/termAcicContent.ml b/helm/software/components/acic_content/termAcicContent.ml new file mode 100644 index 000000000..fddd777f7 --- /dev/null +++ b/helm/software/components/acic_content/termAcicContent.ml @@ -0,0 +1,371 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) else () + +type interpretation_id = int + +let idref id t = Ast.AttributedTerm (`IdRef id, t) + +type term_info = + { sort: (Cic.id, Ast.sort_kind) Hashtbl.t; + uri: (Cic.id, UriManager.uri) Hashtbl.t; + } + +let get_types uri = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + | Cic.InductiveDefinition (l,_,_,_) -> l + | _ -> assert false + +let name_of_inductive_type uri i = + let types = get_types uri in + let (name, _, _, _) = try List.nth types i with Not_found -> assert false in + name + + (* returns pairs *) +let constructors_of_inductive_type uri i = + let types = get_types uri in + let (_, _, _, constructors) = + try List.nth types i with Not_found -> assert false + in + constructors + + (* returns name only *) +let constructor_of_inductive_type uri i j = + (try + fst (List.nth (constructors_of_inductive_type uri i) (j-1)) + with Not_found -> assert false) + +let ast_of_acic0 term_info acic k = + let k = k term_info in + let id_to_uris = term_info.uri in + let register_uri id uri = Hashtbl.add id_to_uris id uri in + let sort_of_id id = + try + Hashtbl.find term_info.sort id + with Not_found -> + prerr_endline (sprintf "warning: sort of id %s not found, using Type" id); + `Type (CicUniv.fresh ()) + in + let aux_substs substs = + Some + (List.map + (fun (uri, annterm) -> (UriManager.name_of_uri uri, k annterm)) + substs) + in + let aux_context context = + List.map + (function + | None -> None + | Some annterm -> Some (k annterm)) + context + in + let aux = function + | Cic.ARel (id,_,_,b) -> idref id (Ast.Ident (b, None)) + | Cic.AVar (id,uri,substs) -> + register_uri id uri; + idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs)) + | Cic.AMeta (id,n,l) -> idref id (Ast.Meta (n, aux_context l)) + | Cic.ASort (id,Cic.Prop) -> idref id (Ast.Sort `Prop) + | Cic.ASort (id,Cic.Set) -> idref id (Ast.Sort `Set) + | Cic.ASort (id,Cic.Type u) -> idref id (Ast.Sort (`Type u)) + | Cic.ASort (id,Cic.CProp) -> idref id (Ast.Sort `CProp) + | Cic.AImplicit (id, Some `Hole) -> idref id Ast.UserInput + | Cic.AImplicit (id, _) -> idref id Ast.Implicit + | Cic.AProd (id,n,s,t) -> + let binder_kind = + match sort_of_id id with + | `Set | `Type _ -> `Pi + | `Prop | `CProp -> `Forall + in + idref id (Ast.Binder (binder_kind, + (CicNotationUtil.name_of_cic_name n, Some (k s)), k t)) + | Cic.ACast (id,v,t) -> idref id (Ast.Cast (k v, k t)) + | Cic.ALambda (id,n,s,t) -> + idref id (Ast.Binder (`Lambda, + (CicNotationUtil.name_of_cic_name n, Some (k s)), k t)) + | Cic.ALetIn (id,n,s,t) -> + idref id (Ast.LetIn ((CicNotationUtil.name_of_cic_name n, None), + k s, k t)) + | Cic.AAppl (aid,args) -> idref aid (Ast.Appl (List.map k args)) + | Cic.AConst (id,uri,substs) -> + register_uri id uri; + idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs)) + | Cic.AMutInd (id,uri,i,substs) -> + let name = name_of_inductive_type uri i in + let uri_str = UriManager.string_of_uri uri in + let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (i+1) in + register_uri id (UriManager.uri_of_string puri_str); + idref id (Ast.Ident (name, aux_substs substs)) + | Cic.AMutConstruct (id,uri,i,j,substs) -> + let name = constructor_of_inductive_type uri i j in + let uri_str = UriManager.string_of_uri uri in + let puri_str = sprintf "%s#xpointer(1/%d/%d)" uri_str (i + 1) j in + register_uri id (UriManager.uri_of_string puri_str); + idref id (Ast.Ident (name, aux_substs substs)) + | Cic.AMutCase (id,uri,typeno,ty,te,patterns) -> + let name = name_of_inductive_type uri typeno in + let uri_str = UriManager.string_of_uri uri in + let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (typeno+1) in + let ctor_puri j = + UriManager.uri_of_string + (sprintf "%s#xpointer(1/%d/%d)" uri_str (typeno+1) j) + in + let case_indty = name, Some (UriManager.uri_of_string puri_str) in + let constructors = constructors_of_inductive_type uri typeno in + let rec eat_branch ty pat = + match (ty, pat) with + | Cic.Prod (_, _, t), Cic.ALambda (_, name, s, t') -> + let (cv, rhs) = eat_branch t t' in + (CicNotationUtil.name_of_cic_name name, Some (k s)) :: cv, rhs + | _, _ -> [], k pat + in + let j = ref 0 in + let patterns = + try + List.map2 + (fun (name, ty) pat -> + incr j; + let (capture_variables, rhs) = eat_branch ty pat in + ((name, Some (ctor_puri !j), capture_variables), rhs)) + constructors patterns + with Invalid_argument _ -> assert false + in + idref id (Ast.Case (k te, Some case_indty, Some (k ty), patterns)) + | Cic.AFix (id, no, funs) -> + let defs = + List.map + (fun (_, n, decr_idx, ty, bo) -> + ((Ast.Ident (n, None), Some (k ty)), k bo, decr_idx)) + funs + in + let name = + try + (match List.nth defs no with + | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n + | _ -> assert false) + with Not_found -> assert false + in + idref id (Ast.LetRec (`Inductive, defs, Ast.Ident (name, None))) + | Cic.ACoFix (id, no, funs) -> + let defs = + List.map + (fun (_, n, ty, bo) -> + ((Ast.Ident (n, None), Some (k ty)), k bo, 0)) + funs + in + let name = + try + (match List.nth defs no with + | (Ast.Ident (n, _), _), _, _ when n <> "_" -> n + | _ -> assert false) + with Not_found -> assert false + in + idref id (Ast.LetRec (`CoInductive, defs, Ast.Ident (name, None))) + in + aux acic + + (* persistent state *) + +let level2_patterns32 = Hashtbl.create 211 +let interpretations = Hashtbl.create 211 (* symb -> id list ref *) + +let compiled32 = ref None +let pattern32_matrix = ref [] + +let get_compiled32 () = + match !compiled32 with + | None -> assert false + | Some f -> Lazy.force f + +let set_compiled32 f = compiled32 := Some f + +let add_idrefs = + List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t)) + +let instantiate32 term_info idrefs env symbol args = + let rec instantiate_arg = function + | Ast.IdentArg (n, name) -> + let t = (try List.assoc name env with Not_found -> assert false) in + let rec count_lambda = function + | Ast.AttributedTerm (_, t) -> count_lambda t + | Ast.Binder (`Lambda, _, body) -> 1 + count_lambda body + | _ -> 0 + in + let rec add_lambda t n = + if n > 0 then + let name = CicNotationUtil.fresh_name () in + Ast.Binder (`Lambda, (Ast.Ident (name, None), None), + Ast.Appl [add_lambda t (n - 1); Ast.Ident (name, None)]) + else + t + in + add_lambda t (n - count_lambda t) + in + let head = + let symbol = Ast.Symbol (symbol, 0) in + add_idrefs idrefs symbol + in + if args = [] then head + else Ast.Appl (head :: List.map instantiate_arg args) + +let rec ast_of_acic1 term_info annterm = + let id_to_uris = term_info.uri in + let register_uri id uri = Hashtbl.add id_to_uris id uri in + match (get_compiled32 ()) annterm with + | None -> ast_of_acic0 term_info annterm ast_of_acic1 + | Some (env, ctors, pid) -> + let idrefs = + List.map + (fun annterm -> + let idref = CicUtil.id_of_annterm annterm in + (try + register_uri idref + (CicUtil.uri_of_term (Deannotate.deannotate_term annterm)) + with Invalid_argument _ -> ()); + idref) + ctors + in + let env' = + List.map (fun (name, term) -> (name, ast_of_acic1 term_info term)) env + in + let _, symbol, args, _ = + try + Hashtbl.find level2_patterns32 pid + with Not_found -> assert false + in + let ast = instantiate32 term_info idrefs env' symbol args in + Ast.AttributedTerm (`IdRef (CicUtil.id_of_annterm annterm), ast) + +let load_patterns32 t = + let t = + HExtlib.filter_map (function (true, ap, id) -> Some (ap, id) | _ -> None) t + in + set_compiled32 (lazy (Acic2astMatcher.Matcher32.compiler t)) + +let ast_of_acic id_to_sort annterm = + debug_print (lazy ("ast_of_acic <- " + ^ CicPp.ppterm (Deannotate.deannotate_term annterm))); + let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in + let ast = ast_of_acic1 term_info annterm in + debug_print (lazy ("ast_of_acic -> " ^ CicNotationPp.pp_term ast)); + ast, term_info.uri + +let fresh_id = + let counter = ref ~-1 in + fun () -> + incr counter; + !counter + +let add_interpretation dsc (symbol, args) appl_pattern = + let id = fresh_id () in + Hashtbl.add level2_patterns32 id (dsc, symbol, args, appl_pattern); + pattern32_matrix := (true, appl_pattern, id) :: !pattern32_matrix; + load_patterns32 !pattern32_matrix; + (try + let ids = Hashtbl.find interpretations symbol in + ids := id :: !ids + with Not_found -> Hashtbl.add interpretations symbol (ref [id])); + id + +let get_all_interpretations () = + List.map + (function (_, _, id) -> + let (dsc, _, _, _) = + try + Hashtbl.find level2_patterns32 id + with Not_found -> assert false + in + (id, dsc)) + !pattern32_matrix + +let get_active_interpretations () = + HExtlib.filter_map (function (true, _, id) -> Some id | _ -> None) + !pattern32_matrix + +let set_active_interpretations ids = + let pattern32_matrix' = + List.map + (function + | (_, ap, id) when List.mem id ids -> (true, ap, id) + | (_, ap, id) -> (false, ap, id)) + !pattern32_matrix + in + pattern32_matrix := pattern32_matrix'; + load_patterns32 !pattern32_matrix + +exception Interpretation_not_found + +let lookup_interpretations symbol = + try + HExtlib.list_uniq + (List.sort Pervasives.compare + (List.map + (fun id -> + let (dsc, _, args, appl_pattern) = + try + Hashtbl.find level2_patterns32 id + with Not_found -> assert false + in + dsc, args, appl_pattern) + !(Hashtbl.find interpretations symbol))) + with Not_found -> raise Interpretation_not_found + +let remove_interpretation id = + (try + let _, symbol, _, _ = Hashtbl.find level2_patterns32 id in + let ids = Hashtbl.find interpretations symbol in + ids := List.filter ((<>) id) !ids; + Hashtbl.remove level2_patterns32 id; + with Not_found -> raise Interpretation_not_found); + pattern32_matrix := + List.filter (fun (_, _, id') -> id <> id') !pattern32_matrix; + load_patterns32 !pattern32_matrix + +let _ = load_patterns32 [] + +let instantiate_appl_pattern env appl_pattern = + let lookup name = + try List.assoc name env + with Not_found -> + prerr_endline (sprintf "Name %s not found" name); + assert false + in + let rec aux = function + | Ast.UriPattern uri -> CicUtil.term_of_uri uri + | Ast.ImplicitPattern -> Cic.Implicit None + | Ast.VarPattern name -> lookup name + | Ast.ApplPattern terms -> Cic.Appl (List.map aux terms) + in + aux appl_pattern + diff --git a/helm/software/components/acic_content/termAcicContent.mli b/helm/software/components/acic_content/termAcicContent.mli new file mode 100644 index 000000000..1fd57e0d0 --- /dev/null +++ b/helm/software/components/acic_content/termAcicContent.mli @@ -0,0 +1,68 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + + (** {2 Persistant state handling} *) + +type interpretation_id + +val add_interpretation: + string -> (* id / description *) + string * CicNotationPt.argument_pattern list -> (* symbol, level 2 pattern *) + CicNotationPt.cic_appl_pattern -> (* level 3 pattern *) + interpretation_id + + (** @raise Interpretation_not_found *) +val lookup_interpretations: + string -> (* symbol *) + (string * CicNotationPt.argument_pattern list * + CicNotationPt.cic_appl_pattern) list + +exception Interpretation_not_found + + (** @raise Interpretation_not_found *) +val remove_interpretation: interpretation_id -> unit + + (** {3 Interpretations toggling} *) + +val get_all_interpretations: unit -> (interpretation_id * string) list +val get_active_interpretations: unit -> interpretation_id list +val set_active_interpretations: interpretation_id list -> unit + + (** {2 acic -> content} *) + +val ast_of_acic: + (Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> (* id -> sort *) + Cic.annterm -> (* acic *) + CicNotationPt.term (* ast *) + * (Cic.id, UriManager.uri) Hashtbl.t (* id -> uri *) + + (** {2 content -> acic} *) + + (** @param env environment from argument_pattern to cic terms + * @param pat cic_appl_pattern *) +val instantiate_appl_pattern: + (string * Cic.term) list -> CicNotationPt.cic_appl_pattern -> + Cic.term + diff --git a/helm/software/components/cic/.depend b/helm/software/components/cic/.depend new file mode 100644 index 000000000..a35156331 --- /dev/null +++ b/helm/software/components/cic/.depend @@ -0,0 +1,27 @@ +unshare.cmi: cic.cmo +deannotate.cmi: cic.cmo +cicParser.cmi: cic.cmo +cicUtil.cmi: cic.cmo +helmLibraryObjects.cmi: cic.cmo +discrimination_tree.cmi: cic.cmo +path_indexing.cmi: cic.cmo +cic.cmo: cicUniv.cmi +cic.cmx: cicUniv.cmx +unshare.cmo: cic.cmo unshare.cmi +unshare.cmx: cic.cmx unshare.cmi +cicUniv.cmo: cicUniv.cmi +cicUniv.cmx: cicUniv.cmi +deannotate.cmo: cic.cmo deannotate.cmi +deannotate.cmx: cic.cmx deannotate.cmi +cicParser.cmo: deannotate.cmi cicUniv.cmi cic.cmo cicParser.cmi +cicParser.cmx: deannotate.cmx cicUniv.cmx cic.cmx cicParser.cmi +cicUtil.cmo: cicUniv.cmi cic.cmo cicUtil.cmi +cicUtil.cmx: cicUniv.cmx cic.cmx cicUtil.cmi +helmLibraryObjects.cmo: cic.cmo helmLibraryObjects.cmi +helmLibraryObjects.cmx: cic.cmx helmLibraryObjects.cmi +libraryObjects.cmo: helmLibraryObjects.cmi libraryObjects.cmi +libraryObjects.cmx: helmLibraryObjects.cmx libraryObjects.cmi +discrimination_tree.cmo: cic.cmo discrimination_tree.cmi +discrimination_tree.cmx: cic.cmx discrimination_tree.cmi +path_indexing.cmo: cic.cmo path_indexing.cmi +path_indexing.cmx: cic.cmx path_indexing.cmi diff --git a/helm/software/components/cic/Makefile b/helm/software/components/cic/Makefile new file mode 100644 index 000000000..f3d9df425 --- /dev/null +++ b/helm/software/components/cic/Makefile @@ -0,0 +1,20 @@ +PACKAGE = cic +PREDICATES = + +INTERFACE_FILES = \ + unshare.mli \ + cicUniv.mli \ + deannotate.mli \ + cicParser.mli \ + cicUtil.mli \ + helmLibraryObjects.mli \ + libraryObjects.mli \ + discrimination_tree.mli \ + path_indexing.mli +IMPLEMENTATION_FILES = \ + cic.ml $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = cic.ml cic.cmi +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/cic/cic.ml b/helm/software/components/cic/cic.ml new file mode 100644 index 000000000..64825e505 --- /dev/null +++ b/helm/software/components/cic/cic.ml @@ -0,0 +1,240 @@ +(* 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 *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 29/11/2000 *) +(* *) +(* This module defines the internal representation of the objects (variables,*) +(* blocks of (co)inductive definitions and constants) and the terms of cic *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +(* 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 implicit_annotation = [ `Closed | `Type | `Hole ] + +(* INTERNAL REPRESENTATION OF CIC OBJECTS AND TERMS *) + +type sort = + Prop + | Set + | Type of CicUniv.universe + | CProp + +type name = + | Name of string + | Anonymous + +type object_flavour = + [ `Definition + | `Fact + | `Lemma + | `Remark + | `Theorem + | `Variant + ] + +type object_class = + [ `Coercion + | `Elim of sort (** elimination principle; if sort is Type, the universe is + * not relevant *) + | `Record of (string * bool) list (** + inductive type that encodes a record; the arguments are + the record fields names and if they are coercions *) + | `Projection (** record projection *) + ] + +type attribute = + [ `Class of object_class + | `Flavour of object_flavour + | `Generated + ] + +type term = + Rel of int (* DeBrujin index, 1 based*) + | 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 *) + | Implicit of implicit_annotation option (* *) + | Cast of term * term (* value, type *) + | Prod of name * term * term (* binder, source, target *) + | 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 * (* 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 (0 based), funs *) + | CoFix of int * coInductiveFun list (* funno (0 based), funs *) +and obj = + Constant of string * term option * term * (* id, body, type, *) + UriManager.uri list * attribute list (* parameters *) + | Variable of string * term option * term * (* name, body, type *) + UriManager.uri list * attribute list (* parameters *) + | CurrentProof of string * metasenv * term * (* name, conjectures, body, *) + term * UriManager.uri list * attribute list (* type, parameters *) + | InductiveDefinition of inductiveType list * (* inductive types, *) + UriManager.uri list * int * attribute list (* params, left params no *) +and inductiveType = + string * bool * term * (* typename, inductive, arity *) + constructor list (* constructors *) +and constructor = + 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 in declarations *) +(* order (i.e. [oldest ; ... ; newest]). Older variables can not *) +(* depend on new ones. *) +and conjecture = int * context * term +and metasenv = conjecture list +and substitution = (int * (context * term * term)) list + + + +(* 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 * 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 *) + | AImplicit of id * implicit_annotation option (* *) + | ACast of id * annterm * annterm (* value, type *) + | AProd of id * name * annterm * annterm (* binder, source, target *) + | 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 * (* 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 *) + (* consno is 1 based *) + | 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 = + AConstant of id * id option * string * (* name, *) + annterm option * annterm * (* body, type, *) + UriManager.uri list * attribute list (* parameters *) + | AVariable of id * + string * annterm option * annterm * (* name, body, type *) + UriManager.uri list * attribute list (* parameters *) + | ACurrentProof of id * id * + string * annmetasenv * (* name, conjectures, *) + annterm * annterm * UriManager.uri list * (* body,type,parameters *) + attribute list + | AInductiveDefinition of id * + anninductiveType list * (* inductive types , *) + UriManager.uri list * int * attribute list (* parameters,n ind. pars*) +and anninductiveType = + id * string * bool * annterm * (* typename, inductive, arity *) + annconstructor list (* constructors *) +and annconstructor = + string * annterm (* id, type *) +and anninductiveFun = + id * string * int * annterm * annterm (* name, ind. index, type, body *) +and anncoInductiveFun = + id * string * annterm * annterm (* name, type, body *) +and annotation = + string + +and context_entry = (* A declaration or definition *) + Decl of term + | Def of term * term option (* body, type (if known) *) + +and hypothesis = + (name * context_entry) option (* None means no more accessible *) + +and context = hypothesis list + +and anncontext_entry = (* A declaration or definition *) + ADecl of annterm + | ADef of annterm + +and annhypothesis = + id * (name * anncontext_entry) option (* None means no more accessible *) + +and anncontext = annhypothesis list +;; + +type lazy_term = + context -> metasenv -> CicUniv.universe_graph -> + term * metasenv * CicUniv.universe_graph + +type anntarget = + Object of annobj (* if annobj is a Constant, this is its type *) + | ConstantBody of annobj + | Term of annterm + | Conjecture of annconjecture + | Hypothesis of annhypothesis + +module CicHash = + Hashtbl.Make + (struct + type t = term + let equal = (==) + let hash = Hashtbl.hash + end) +;; + diff --git a/helm/software/components/cic/cicParser.ml b/helm/software/components/cic/cicParser.ml new file mode 100644 index 000000000..a7ad3c9cf --- /dev/null +++ b/helm/software/components/cic/cicParser.ml @@ -0,0 +1,780 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) + +open Printf + +(* ZACK TODO element from the DTD still to be handled: + + + + + + + +*) + +exception Getter_failure of string * string +exception Parser_failure of string + +type stack_entry = + | Arg of string * Cic.annterm (* relative uri, term *) + (* constants' body and types resides in differne files, thus we can't simple + * keep constants in Cic_obj stack entries *) + | Cic_attributes of Cic.attribute list + | Cic_constant_body of string * string * UriManager.uri list * Cic.annterm + * Cic.attribute list + (* id, for, params, body, object attributes *) + | Cic_constant_type of string * string * UriManager.uri list * Cic.annterm + * Cic.attribute list + (* id, name, params, type, object attributes *) + | Cic_term of Cic.annterm (* term *) + | Cic_obj of Cic.annobj (* object *) + | Cofix_fun of Cic.id * string * Cic.annterm * Cic.annterm + (* id, name, type, body *) + | Constructor of string * Cic.annterm (* name, type *) + | Decl of Cic.id * Cic.name * Cic.annterm (* id, binder, source *) + | Def of Cic.id * Cic.name * Cic.annterm (* id, binder, source *) + | Fix_fun of Cic.id * string * int * Cic.annterm * Cic.annterm + (* id, name, ind. index, type, body *) + | Inductive_type of string * string * bool * Cic.annterm * + (string * Cic.annterm) list (* id, name, inductive, arity, constructors *) + | Meta_subst of Cic.annterm option + | Obj_class of Cic.object_class + | Obj_flavour of Cic.object_flavour + | Obj_field of string (* field name *) + | Obj_generated + | Tag of string * (string * string) list (* tag name, attributes *) + (* ZACK TODO add file position to tag stack entry so that when attribute + * errors occur, the position of their _start_tag_ could be printed + * instead of the current position (usually the end tag) *) + +type ctxt = { + mutable stack: stack_entry list; + mutable xml_parser: XmlPushParser.xml_parser option; + mutable filename: string; + uri: UriManager.uri; +} + +let string_of_stack ctxt = + "[" ^ (String.concat "; " + (List.map + (function + | Arg (reluri, _) -> sprintf "Arg %s" reluri + | Cic_attributes _ -> "Cic_attributes" + | Cic_constant_body (id, name, _, _, _) -> + sprintf "Cic_constant_body %s (id=%s)" name id + | Cic_constant_type (id, name, _, _, _) -> + sprintf "Cic_constant_type %s (id=%s)" name id + | Cic_term _ -> "Cic_term" + | Cic_obj _ -> "Cic_obj" + | Constructor (name, _) -> "Constructor " ^ name + | Cofix_fun (id, _, _, _) -> sprintf "Cofix_fun (id=%s)" id + | Decl (id, _, _) -> sprintf "Decl (id=%s)" id + | Def (id, _, _) -> sprintf "Def (id=%s)" id + | Fix_fun (id, _, _, _, _) -> sprintf "Fix_fun (id=%s)" id + | Inductive_type (id, name, _, _, _) -> + sprintf "Inductive_type %s (id=%s)" name id + | Meta_subst _ -> "Meta_subst" + | Obj_class _ -> "Obj_class" + | Obj_flavour _ -> "Obj_flavour" + | Obj_field name -> "Obj_field " ^ name + | Obj_generated -> "Obj_generated" + | Tag (tag, _) -> "Tag " ^ tag) + ctxt.stack)) ^ "]" + +let compare_attrs (a1, v1) (a2, v2) = Pervasives.compare a1 a2 +let sort_attrs = List.sort compare_attrs + +let new_parser_context uri = { + stack = []; + xml_parser = None; + filename = "-"; + uri = uri; +} + +let get_parser ctxt = + match ctxt.xml_parser with + | Some p -> p + | None -> assert false + +(** {2 Error handling} *) + +let parse_error ctxt msg = + let (line, col) = XmlPushParser.get_position (get_parser ctxt) in + raise (Parser_failure (sprintf "[%s: line %d, column %d] %s" + ctxt.filename line col msg)) + +let attribute_error ctxt tag = + parse_error ctxt ("wrong attribute set for " ^ tag) + +(** {2 Parsing context management} *) + +let pop ctxt = +(* debug_print (lazy "pop");*) + match ctxt.stack with + | hd :: tl -> (ctxt.stack <- tl) + | _ -> assert false + +let push ctxt v = +(* debug_print (lazy "push");*) + ctxt.stack <- v :: ctxt.stack + +let set_top ctxt v = +(* debug_print (lazy "set_top");*) + match ctxt.stack with + | _ :: tl -> (ctxt.stack <- v :: tl) + | _ -> assert false + + (** pop the last tag from the open tags stack returning a pair *) +let pop_tag ctxt = + match ctxt.stack with + | Tag (tag, attrs) :: tl -> + ctxt.stack <- tl; + (tag, attrs) + | _ -> parse_error ctxt "unexpected extra content" + + (** pop the last tag from the open tags stack returning its attributes. + * Attributes are returned as a list of pair _sorted_ by + * attribute name *) +let pop_tag_attrs ctxt = sort_attrs (snd (pop_tag ctxt)) + +let pop_cics ctxt = + let rec aux acc stack = + match stack with + | Cic_term t :: tl -> aux (t :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + values + +let pop_class_modifiers ctxt = + let rec aux acc stack = + match stack with + | (Cic_term (Cic.ASort _) as m) :: tl + | (Obj_field _ as m) :: tl -> + aux (m :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + values + +let pop_meta_substs ctxt = + let rec aux acc stack = + match stack with + | Meta_subst t :: tl -> aux (t :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + values + +let pop_fix_funs ctxt = + let rec aux acc stack = + match stack with + | Fix_fun (id, name, index, typ, body) :: tl -> + aux ((id, name, index, typ, body) :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + values + +let pop_cofix_funs ctxt = + let rec aux acc stack = + match stack with + | Cofix_fun (id, name, typ, body) :: tl -> + aux ((id, name, typ, body) :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + values + +let pop_constructors ctxt = + let rec aux acc stack = + match stack with + | Constructor (name, t) :: tl -> aux ((name, t) :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + values + +let pop_inductive_types ctxt = + let rec aux acc stack = + match stack with + | Inductive_type (id, name, ind, arity, ctors) :: tl -> + aux ((id, name, ind, arity, ctors) :: acc) tl + | tl -> acc, tl + in + let values, new_stack = aux [] ctxt.stack in + if values = [] then + parse_error ctxt "no \"InductiveType\" element found"; + ctxt.stack <- new_stack; + values + + (** travels the stack (without popping) for the first term subject of explicit + * named substitution and return its URI *) +let find_base_uri ctxt = + let rec aux = function + | Cic_term (Cic.AConst (_, uri, _)) :: _ + | Cic_term (Cic.AMutInd (_, uri, _, _)) :: _ + | Cic_term (Cic.AMutConstruct (_, uri, _, _, _)) :: _ + | Cic_term (Cic.AVar (_, uri, _)) :: _ -> + uri + | Arg _ :: tl -> aux tl + | _ -> parse_error ctxt "no \"arg\" element found" + in + UriManager.buri_of_uri (aux ctxt.stack) + + (** backwardly eats the stack building an explicit named substitution from Arg + * stack entries *) +let pop_subst ctxt base_uri = + let rec aux acc stack = + match stack with + | Arg (rel_uri, term) :: tl -> + let uri = UriManager.uri_of_string (base_uri ^ "/" ^ rel_uri) in + aux ((uri, term) :: acc) tl + | tl -> acc, tl + in + let subst, new_stack = aux [] ctxt.stack in + if subst = [] then + parse_error ctxt "no \"arg\" element found"; + ctxt.stack <- new_stack; + subst + +let pop_cic ctxt = + match ctxt.stack with + | Cic_term t :: tl -> + ctxt.stack <- tl; + t + | _ -> parse_error ctxt "no cic term found" + +let pop_obj_attributes ctxt = + match ctxt.stack with + | Cic_attributes attributes :: tl -> + ctxt.stack <- tl; + attributes + | _ -> [] + +(** {2 Auxiliary functions} *) + +let uri_of_string = UriManager.uri_of_string + +let uri_list_of_string = + let space_RE = Str.regexp " " in + fun s -> + List.map uri_of_string (Str.split space_RE s) + +let sort_of_string ctxt = function + | "Prop" -> Cic.Prop + | "Set" -> Cic.Set + | "CProp" -> Cic.CProp + (* THIS CASE IS HERE ONLY TO ALLOW THE PARSING OF COQ LIBRARY + * THIS SHOULD BE REMOVED AS SOON AS univ_maker OR COQ'S EXPORTATION + * IS FIXED *) + | "Type" -> Cic.Type (CicUniv.fresh ~uri:ctxt.uri ()) + | s -> + let len = String.length s in + if not(len > 5) then parse_error ctxt "sort expected"; + if not(String.sub s 0 5 = "Type:") then parse_error ctxt "sort expected"; + try + Cic.Type + (CicUniv.fresh + ~uri:ctxt.uri + ~id:(int_of_string (String.sub s 5 (len - 5))) ()) + with + | Failure "int_of_string" + | Invalid_argument _ -> parse_error ctxt "sort expected" + +let patch_subst ctxt subst = function + | Cic.AConst (id, uri, _) -> Cic.AConst (id, uri, subst) + | Cic.AMutInd (id, uri, typeno, _) -> + Cic.AMutInd (id, uri, typeno, subst) + | Cic.AMutConstruct (id, uri, typeno, consno, _) -> + Cic.AMutConstruct (id, uri, typeno, consno, subst) + | Cic.AVar (id, uri, _) -> Cic.AVar (id, uri, subst) + | _ -> + parse_error ctxt + ("only \"CONST\", \"VAR\", \"MUTIND\", and \"MUTCONSTRUCT\" can be" ^ + " instantiated") + + (** backwardly eats the stack seeking for the first open tag carrying + * "helm:exception" attributes. If found return Some of a pair containing + * exception name and argument. Return None otherwise *) +let find_helm_exception ctxt = + let rec aux = function + | [] -> None + | Tag (_, attrs) :: tl -> + (try + let exn = List.assoc "helm:exception" attrs in + let arg = + try List.assoc "helm:exception_arg" attrs with Not_found -> "" + in + Some (exn, arg) + with Not_found -> aux tl) + | _ :: tl -> aux tl + in + aux ctxt.stack + +(** {2 Push parser callbacks} + * each callback needs to be instantiated to a parsing context *) + +let start_element ctxt tag attrs = +(* debug_print (lazy (sprintf "<%s%s>" tag (match attrs with | [] -> "" | _ -> " " ^ String.concat " " (List.map (fun (a,v) -> sprintf "%s=\"%s\"" a v) attrs))));*) + push ctxt (Tag (tag, attrs)) + +let end_element ctxt tag = +(* debug_print (lazy (sprintf "" tag));*) +(* debug_print (lazy (string_of_stack ctxt));*) + let attribute_error () = attribute_error ctxt tag in + let parse_error = parse_error ctxt in + let sort_of_string = sort_of_string ctxt in + match tag with + | "REL" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["binder", binder; "id", id; "idref", idref; "value", value] + | ["binder", binder; "id", id; "idref", idref; "sort", _; + "value", value] -> + Cic.ARel (id, idref, int_of_string value, binder) + | _ -> attribute_error ())) + | "VAR" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "uri", uri] + | ["id", id; "sort", _; "uri", uri] -> + Cic.AVar (id, uri_of_string uri, []) + | _ -> attribute_error ())) + | "CONST" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "uri", uri] + | ["id", id; "sort", _; "uri", uri] -> + Cic.AConst (id, uri_of_string uri, []) + | _ -> attribute_error ())) + | "SORT" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "value", sort] -> Cic.ASort (id, sort_of_string sort) + | _ -> attribute_error ())) + | "APPLY" -> + let args = pop_cics ctxt in + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id ] + | ["id", id; "sort", _] -> Cic.AAppl (id, args) + | _ -> attribute_error ())) + | "decl" -> + let source = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["binder", binder; "id", id ] + | ["binder", binder; "id", id; "type", _] -> + Decl (id, Cic.Name binder, source) + | ["id", id] + | ["id", id; "type", _] -> Decl (id, Cic.Anonymous, source) + | _ -> attribute_error ()) + | "def" -> (* same as "decl" above *) + let source = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["binder", binder; "id", id] + | ["binder", binder; "id", id; "sort", _] -> + Def (id, Cic.Name binder, source) + | ["id", id] + | ["id", id; "sort", _] -> Def (id, Cic.Anonymous, source) + | _ -> attribute_error ()) + | "arity" (* transparent elements (i.e. which contain a CIC) *) + | "body" + | "inductiveTerm" + | "pattern" + | "patternsType" + | "target" + | "term" + | "type" -> + let term = pop_cic ctxt in + pop ctxt; (* pops start tag matching current end tag (e.g. ) *) + push ctxt (Cic_term term) + | "substitution" -> (* optional transparent elements (i.e. which _may_ + * contain a CIC) *) + set_top ctxt (* replace *) + (match ctxt.stack with + | Cic_term term :: tl -> + ctxt.stack <- tl; + (Meta_subst (Some term)) + | _ -> Meta_subst None) + | "PROD" -> + let target = pop_cic ctxt in + let rec add_decl target = function + | Decl (id, binder, source) :: tl -> + add_decl (Cic.AProd (id, binder, source, target)) tl + | tl -> + ctxt.stack <- tl; + target + in + let term = add_decl target ctxt.stack in + (match pop_tag_attrs ctxt with + [] + | ["type", _] -> () + | _ -> attribute_error ()); + push ctxt (Cic_term term) + | "LAMBDA" -> + let target = pop_cic ctxt in + let rec add_decl target = function + | Decl (id, binder, source) :: tl -> + add_decl (Cic.ALambda (id, binder, source, target)) tl + | tl -> + ctxt.stack <- tl; + target + in + let term = add_decl target ctxt.stack in + (match pop_tag_attrs ctxt with + [] + | ["sort", _] -> () + | _ -> attribute_error ()); + push ctxt (Cic_term term) + | "LETIN" -> + let target = pop_cic ctxt in + let rec add_def target = function + | Def (id, binder, source) :: tl -> + add_def (Cic.ALetIn (id, binder, source, target)) tl + | tl -> + ctxt.stack <- tl; + target + in + let term = add_def target ctxt.stack in + (match pop_tag_attrs ctxt with + [] + | ["sort", _] -> () + | _ -> attribute_error ()); + push ctxt (Cic_term term) + | "CAST" -> + let typ = pop_cic ctxt in + let term = pop_cic ctxt in + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + ["id", id] + | ["id", id; "sort", _] -> Cic.ACast (id, term, typ) + | _ -> attribute_error ())); + | "IMPLICIT" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id] -> Cic.AImplicit (id, None) + | ["annotation", annotation; "id", id] -> + let implicit_annotation = + match annotation with + | "closed" -> `Closed + | "hole" -> `Hole + | "type" -> `Type + | _ -> parse_error "invalid value for \"annotation\" attribute" + in + Cic.AImplicit (id, Some implicit_annotation) + | _ -> attribute_error ())) + | "META" -> + let meta_substs = pop_meta_substs ctxt in + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "no", no] + | ["id", id; "no", no; "sort", _] -> + Cic.AMeta (id, int_of_string no, meta_substs) + | _ -> attribute_error ())); + | "MUTIND" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "noType", noType; "uri", uri] -> + Cic.AMutInd (id, uri_of_string uri, int_of_string noType, []) + | _ -> attribute_error ())); + | "MUTCONSTRUCT" -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "noConstr", noConstr; "noType", noType; "uri", uri] + | ["id", id; "noConstr", noConstr; "noType", noType; "sort", _; + "uri", uri] -> + Cic.AMutConstruct (id, uri_of_string uri, int_of_string noType, + int_of_string noConstr, []) + | _ -> attribute_error ())); + | "FixFunction" -> + let body = pop_cic ctxt in + let typ = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["id", id; "name", name; "recIndex", recIndex] -> + Fix_fun (id, name, int_of_string recIndex, typ, body) + | _ -> attribute_error ()) + | "CofixFunction" -> + let body = pop_cic ctxt in + let typ = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["id", id; "name", name] -> + Cofix_fun (id, name, typ, body) + | _ -> attribute_error ()) + | "FIX" -> + let fix_funs = pop_fix_funs ctxt in + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "noFun", noFun] + | ["id", id; "noFun", noFun; "sort", _] -> + Cic.AFix (id, int_of_string noFun, fix_funs) + | _ -> attribute_error ())) + | "COFIX" -> + let cofix_funs = pop_cofix_funs ctxt in + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "noFun", noFun] + | ["id", id; "noFun", noFun; "sort", _] -> + Cic.ACoFix (id, int_of_string noFun, cofix_funs) + | _ -> attribute_error ())) + | "MUTCASE" -> + (match pop_cics ctxt with + | patternsType :: inductiveTerm :: patterns -> + push ctxt (Cic_term + (match pop_tag_attrs ctxt with + | ["id", id; "noType", noType; "uriType", uriType] + | ["id", id; "noType", noType; "sort", _; "uriType", uriType] -> + Cic.AMutCase (id, uri_of_string uriType, int_of_string noType, + patternsType, inductiveTerm, patterns) + | _ -> attribute_error ())) + | _ -> parse_error "invalid \"MUTCASE\" content") + | "Constructor" -> + let typ = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["name", name] -> Constructor (name, typ) + | _ -> attribute_error ()) + | "InductiveType" -> + let constructors = pop_constructors ctxt in + let arity = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["id", id; "inductive", inductive; "name", name] -> + Inductive_type (id, name, bool_of_string inductive, arity, + constructors) + | _ -> attribute_error ()) + | "InductiveDefinition" -> + let inductive_types = pop_inductive_types ctxt in + let obj_attributes = pop_obj_attributes ctxt in + push ctxt (Cic_obj + (match pop_tag_attrs ctxt with + | ["id", id; "noParams", noParams; "params", params] -> + Cic.AInductiveDefinition (id, inductive_types, + uri_list_of_string params, int_of_string noParams, obj_attributes) + | _ -> attribute_error ())) + | "ConstantType" -> + let typ = pop_cic ctxt in + let obj_attributes = pop_obj_attributes ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["id", id; "name", name; "params", params] -> + Cic_constant_type (id, name, uri_list_of_string params, typ, + obj_attributes) + | _ -> attribute_error ()) + | "ConstantBody" -> + let body = pop_cic ctxt in + let obj_attributes = pop_obj_attributes ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["for", for_; "id", id; "params", params] -> + Cic_constant_body (id, for_, uri_list_of_string params, body, + obj_attributes) + | _ -> attribute_error ()) + | "Variable" -> + let typ = pop_cic ctxt in + let body = + match pop_cics ctxt with + | [] -> None + | [t] -> Some t + | _ -> parse_error "wrong content for \"Variable\"" + in + let obj_attributes = pop_obj_attributes ctxt in + push ctxt (Cic_obj + (match pop_tag_attrs ctxt with + | ["id", id; "name", name; "params", params] -> + Cic.AVariable (id, name, body, typ, uri_list_of_string params, + obj_attributes) + | _ -> attribute_error ())) + | "arg" -> + let term = pop_cic ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["relUri", relUri] -> Arg (relUri, term) + | _ -> attribute_error ()) + | "instantiate" -> + (* explicit named substitution handling: when the end tag of an element + * subject of exlicit named subst (MUTIND, MUTCONSTRUCT, CONST, VAR) it + * is stored on the stack with no substitutions (i.e. []). When the end + * tag of an "instantiate" element is found we patch the term currently + * on the stack with the substitution built from "instantiate" children + *) + (* XXX inefficiency here: first travels the elements in order to + * find the baseUri, then in order to build the explicit named subst *) + let base_uri = find_base_uri ctxt in + let subst = pop_subst ctxt base_uri in + let term = pop_cic ctxt in + (* comment from CicParser3.ml: + * CSC: the "id" optional attribute should be parsed and reflected in + * Cic.annterm and id = string_of_xml_attr (n#attribute "id") *) + (* replace *) + set_top ctxt (Cic_term (patch_subst ctxt subst term)) + | "attributes" -> + let rec aux acc = function (* retrieve object attributes *) + | Obj_class c :: tl -> aux (`Class c :: acc) tl + | Obj_flavour f :: tl -> aux (`Flavour f :: acc) tl + | Obj_generated :: tl -> aux (`Generated :: acc) tl + | tl -> acc, tl + in + let obj_attrs, new_stack = aux [] ctxt.stack in + ctxt.stack <- new_stack; + set_top ctxt (Cic_attributes obj_attrs) + | "generated" -> set_top ctxt Obj_generated + | "field" -> + push ctxt + (match pop_tag_attrs ctxt with + | ["name", name] -> Obj_field name + | _ -> attribute_error ()) + | "flavour" -> + push ctxt + (match pop_tag_attrs ctxt with + | [ "value", "definition"] -> Obj_flavour `Definition + | [ "value", "fact"] -> Obj_flavour `Fact + | [ "value", "lemma"] -> Obj_flavour `Lemma + | [ "value", "remark"] -> Obj_flavour `Remark + | [ "value", "theorem"] -> Obj_flavour `Theorem + | [ "value", "variant"] -> Obj_flavour `Variant + | _ -> attribute_error ()) + | "class" -> + let class_modifiers = pop_class_modifiers ctxt in + push ctxt + (match pop_tag_attrs ctxt with + | ["value", "coercion"] -> Obj_class `Coercion + | ["value", "elim"] -> + (match class_modifiers with + | [Cic_term (Cic.ASort (_, sort))] -> Obj_class (`Elim sort) + | _ -> + parse_error + "unexpected extra content for \"elim\" object class") + | ["value", "record"] -> + let fields = + List.map + (function + | Obj_field name -> + (match Str.split (Str.regexp " ") name with + | [name] -> name, false + | [name;"coercion"] -> name,true + | _ -> + parse_error + "wrong \"field\"'s name attribute") + | _ -> + parse_error + "unexpected extra content for \"record\" object class") + class_modifiers + in + Obj_class (`Record fields) + | ["value", "projection"] -> Obj_class `Projection + | _ -> attribute_error ()) + | tag -> + match find_helm_exception ctxt with + | Some (exn, arg) -> raise (Getter_failure (exn, arg)) + | None -> parse_error (sprintf "unknown element \"%s\"" tag) + +(** {2 Parser internals} *) + +let has_gz_suffix fname = + try + let idx = String.rindex fname '.' in + let suffix = String.sub fname idx (String.length fname - idx) in + suffix = ".gz" + with Not_found -> false + +let parse uri filename = + let ctxt = new_parser_context uri in + ctxt.filename <- filename; + let module P = XmlPushParser in + let callbacks = { + P.default_callbacks with + P.start_element = Some (start_element ctxt); + P.end_element = Some (end_element ctxt); + } in + let xml_parser = P.create_parser callbacks in + ctxt.xml_parser <- Some xml_parser; + try + (try + let xml_source = + if has_gz_suffix filename then `Gzip_file filename + else `File filename + in + P.parse xml_parser xml_source + with exn -> + ctxt.xml_parser <- None; + (* ZACK: the above "<- None" is vital for garbage collection. Without it + * we keep in memory a circular structure parser -> callbacks -> ctxt -> + * parser. I don't know if the ocaml garbage collector is supposed to + * collect such structures, but for sure the expat bindings will (orribly) + * leak when used in conjunction with such structures *) + raise exn); + ctxt.xml_parser <- None; (* ZACK: same comment as above *) +(* debug_print (lazy (string_of_stack stack));*) + (* assert (List.length ctxt.stack = 1) *) + List.hd ctxt.stack + with + | Failure "int_of_string" -> parse_error ctxt "integer number expected" + | Invalid_argument "bool_of_string" -> parse_error ctxt "boolean expected" + | P.Parse_error msg -> parse_error ctxt ("parse error: " ^ msg) + | Parser_failure _ + | Getter_failure _ as exn -> + raise exn + | exn -> + raise (Parser_failure ("uncaught exception: " ^ Printexc.to_string exn)) + +(** {2 API implementation} *) + +let annobj_of_xml uri filename filenamebody = + match filenamebody with + | None -> + (match parse uri filename with + | Cic_constant_type (id, name, params, typ, obj_attributes) -> + Cic.AConstant (id, None, name, None, typ, params, obj_attributes) + | Cic_obj obj -> obj + | _ -> raise (Parser_failure ("no object found in " ^ filename))) + | Some filenamebody -> + (match parse uri filename, parse uri filenamebody with + | Cic_constant_type (type_id, name, params, typ, obj_attributes), + Cic_constant_body (body_id, _, _, body, _) -> + Cic.AConstant (type_id, Some body_id, name, Some body, typ, params,obj_attributes) + | _ -> + raise (Parser_failure (sprintf "no constant found in %s, %s" + filename filenamebody))) + +let obj_of_xml uri filename filenamebody = + Deannotate.deannotate_obj (annobj_of_xml uri filename filenamebody) diff --git a/helm/software/components/cic/cicParser.mli b/helm/software/components/cic/cicParser.mli new file mode 100644 index 000000000..9472b4c54 --- /dev/null +++ b/helm/software/components/cic/cicParser.mli @@ -0,0 +1,46 @@ +(* Copyright (C) 2000-2005, 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/. + *) + + (** raised for exception received by the getter (i.e. embedded in the source + * XML document). Arguments are values of "helm:exception" and + * "helm:exception_arg" attributes *) +exception Getter_failure of string * string + + (** generic parser failure *) +exception Parser_failure of string + + (* 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. + * Both files are assumed to be gzipped. *) +val annobj_of_xml: UriManager.uri -> string -> string option -> Cic.annobj + + (* 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. + * Both files are assumed to be gzipped. *) +val obj_of_xml : UriManager.uri -> string -> string option -> Cic.obj + diff --git a/helm/software/components/cic/cicUniv.ml b/helm/software/components/cic/cicUniv.ml new file mode 100644 index 000000000..8ae118c9b --- /dev/null +++ b/helm/software/components/cic/cicUniv.ml @@ -0,0 +1,982 @@ +(* 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 *) +(* *) +(* Enrico Tassi *) +(* 23/04/2004 *) +(* *) +(* This module implements the aciclic graph of universes. *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +(*****************************************************************************) +(** switch implementation **) +(*****************************************************************************) + +let fast_implementation = ref true ;; + +(*****************************************************************************) +(** open **) +(*****************************************************************************) + +open Printf + +(*****************************************************************************) +(** Types and default values **) +(*****************************************************************************) + +type universe = int * UriManager.uri option + +module UniverseType = struct + type t = universe + let compare = Pervasives.compare +end + +module SOF = Set.Make(UniverseType) + +type entry = { + eq_closure : SOF.t; + ge_closure : SOF.t; + gt_closure : SOF.t; + in_gegt_of : SOF.t; + one_s_eq : SOF.t; + one_s_ge : SOF.t; + one_s_gt : SOF.t; +} + +module MAL = Map.Make(UniverseType) + +type arc_type = GE | GT | EQ + +type bag = entry MAL.t + +let empty_entry = { + eq_closure=SOF.empty; + ge_closure=SOF.empty; + gt_closure=SOF.empty; + in_gegt_of=SOF.empty; + one_s_eq=SOF.empty; + one_s_ge=SOF.empty; + one_s_gt=SOF.empty; +} +let empty_bag = MAL.empty + +let are_set_eq s1 s2 = + SOF.equal s1 s2 + +let are_entry_eq v1 v2 = + (are_set_eq v1.gt_closure v2.gt_closure ) && + (are_set_eq v1.ge_closure v2.ge_closure ) && + (are_set_eq v1.eq_closure v2.eq_closure ) && + (*(are_set_eq v1.in_gegt_of v2.in_gegt_of ) &&*) + (are_set_eq v1.one_s_ge v2.one_s_ge ) && + (are_set_eq v1.one_s_gt v2.one_s_gt ) && + (are_set_eq v1.one_s_eq v2.one_s_eq ) + +let are_ugraph_eq = MAL.equal are_entry_eq + +(*****************************************************************************) +(** Pretty printings **) +(*****************************************************************************) + +let string_of_universe (i,u) = + match u with + Some u -> + "(" ^ ((string_of_int i) ^ "," ^ (UriManager.string_of_uri u) ^ ")") + | None -> "(" ^ (string_of_int i) ^ ",None)" + +let string_of_universe_set l = + SOF.fold (fun x s -> s ^ (string_of_universe x) ^ " ") l "" + +let string_of_node n = + "{"^ + "eq_c: " ^ (string_of_universe_set n.eq_closure) ^ "; " ^ + "ge_c: " ^ (string_of_universe_set n.ge_closure) ^ "; " ^ + "gt_c: " ^ (string_of_universe_set n.gt_closure) ^ "; " ^ + "i_gegt: " ^ (string_of_universe_set n.in_gegt_of) ^ "}\n" + +let string_of_arc (a,u,v) = + (string_of_universe u) ^ " " ^ a ^ " " ^ (string_of_universe v) + +let string_of_mal m = + let rc = ref "" in + MAL.iter (fun k v -> + rc := !rc ^ sprintf "%s --> %s" (string_of_universe k) + (string_of_node v)) m; + !rc + +let string_of_bag b = + string_of_mal b + +(*****************************************************************************) +(** Benchmarking **) +(*****************************************************************************) +let time_spent = ref 0.0;; +let partial = ref 0.0 ;; + +let reset_spent_time () = time_spent := 0.0;; +let get_spent_time () = !time_spent ;; +let begin_spending () = + (*assert (!partial = 0.0);*) + partial := Unix.gettimeofday () +;; + +let end_spending () = + assert (!partial > 0.0); + let interval = (Unix.gettimeofday ()) -. !partial in + partial := 0.0; + time_spent := !time_spent +. interval +;; + + +(*****************************************************************************) +(** Helpers **) +(*****************************************************************************) + +(* find the repr *) +let repr u m = + try + MAL.find u m + with + Not_found -> empty_entry + +(* FIXME: May be faster if we make it by hand *) +let merge_closures f nodes m = + SOF.fold (fun x i -> SOF.union (f (repr x m)) i ) nodes SOF.empty + + +(*****************************************************************************) +(** _fats implementation **) +(*****************************************************************************) + +let rec closure_of_fast ru m = + let eq_c = closure_eq_fast ru m in + let ge_c = closure_ge_fast ru m in + let gt_c = closure_gt_fast ru m in + { + eq_closure = eq_c; + ge_closure = ge_c; + gt_closure = gt_c; + in_gegt_of = ru.in_gegt_of; + one_s_eq = ru.one_s_eq; + one_s_ge = ru.one_s_ge; + one_s_gt = ru.one_s_gt + } + +and closure_eq_fast ru m = + let eq_c = + let j = ru.one_s_eq in + let _Uj = merge_closures (fun x -> x.eq_closure) j m in + let one_step_eq = ru.one_s_eq in + (SOF.union one_step_eq _Uj) + in + eq_c + +and closure_ge_fast ru m = + let ge_c = + let j = SOF.union ru.one_s_ge (SOF.union ru.one_s_gt ru.one_s_eq) in + let _Uj = merge_closures (fun x -> x.ge_closure) j m in + let _Ux = j in + (SOF.union _Uj _Ux) + in + ge_c + +and closure_gt_fast ru m = + let gt_c = + let j = ru.one_s_gt in + let k = ru.one_s_ge in + let l = ru.one_s_eq in + let _Uj = merge_closures (fun x -> x.ge_closure) j m in + let _Uk = merge_closures (fun x -> x.gt_closure) k m in + let _Ul = merge_closures (fun x -> x.gt_closure) l m in + let one_step_gt = ru.one_s_gt in + (SOF.union (SOF.union (SOF.union _Ul one_step_gt) _Uk) _Uj) + in + gt_c + +and print_rec_status u ru = + print_endline ("Aggiusto " ^ (string_of_universe u) ^ + "e ottengo questa chiusura\n " ^ (string_of_node ru)) + +and adjust_fast u m = + let ru = repr u m in + let gt_c = closure_gt_fast ru m in + let ge_c = closure_ge_fast ru m in + let eq_c = closure_eq_fast ru m in + let changed_eq = not (are_set_eq eq_c ru.eq_closure) in + let changed_gegt = + (not (are_set_eq gt_c ru.gt_closure)) || + (not (are_set_eq ge_c ru.ge_closure)) + in + if ((not changed_gegt) && (not changed_eq)) then + m + else + begin + let ru' = { + eq_closure = eq_c; + ge_closure = ge_c; + gt_closure = gt_c; + in_gegt_of = ru.in_gegt_of; + one_s_eq = ru.one_s_eq; + one_s_ge = ru.one_s_ge; + one_s_gt = ru.one_s_gt} + in + let m = MAL.add u ru' m in + let m = + SOF.fold (fun x m -> adjust_fast x m) + (SOF.union ru'.eq_closure ru'.in_gegt_of) m + (* TESI: + ru'.in_gegt_of m + *) + in + m (*adjust_fast u m*) + end + +and add_gt_arc_fast u v m = + let ru = repr u m in + let ru' = {ru with one_s_gt = SOF.add v ru.one_s_gt} in + let m' = MAL.add u ru' m in + let rv = repr v m' in + let rv' = {rv with in_gegt_of = SOF.add u rv.in_gegt_of} in + let m'' = MAL.add v rv' m' in + adjust_fast u m'' + +and add_ge_arc_fast u v m = + let ru = repr u m in + let ru' = { ru with one_s_ge = SOF.add v ru.one_s_ge} in + let m' = MAL.add u ru' m in + let rv = repr v m' in + let rv' = {rv with in_gegt_of = SOF.add u rv.in_gegt_of} in + let m'' = MAL.add v rv' m' in + adjust_fast u m'' + +and add_eq_arc_fast u v m = + let ru = repr u m in + let rv = repr v m in + let ru' = {ru with one_s_eq = SOF.add v ru.one_s_eq} in + (*TESI: let ru' = {ru' with in_gegt_of = SOF.add v ru.in_gegt_of} in *) + let m' = MAL.add u ru' m in + let rv' = {rv with one_s_eq = SOF.add u rv.one_s_eq} in + (*TESI: let rv' = {rv' with in_gegt_of = SOF.add u rv.in_gegt_of} in *) + let m'' = MAL.add v rv' m' in + adjust_fast v (*(adjust_fast u*) m'' (* ) *) +;; + + +(*****************************************************************************) +(** safe implementation **) +(*****************************************************************************) + +let closure_of u m = + let ru = repr u m in + let eq_c = + let j = ru.one_s_eq in + let _Uj = merge_closures (fun x -> x.eq_closure) j m in + let one_step_eq = ru.one_s_eq in + (SOF.union one_step_eq _Uj) + in + let ge_c = + let j = SOF.union ru.one_s_ge (SOF.union ru.one_s_gt ru.one_s_eq) in + let _Uj = merge_closures (fun x -> x.ge_closure) j m in + let _Ux = j in + (SOF.union _Uj _Ux) + in + let gt_c = + let j = ru.one_s_gt in + let k = ru.one_s_ge in + let l = ru.one_s_eq in + let _Uj = merge_closures (fun x -> x.ge_closure) j m in + let _Uk = merge_closures (fun x -> x.gt_closure) k m in + let _Ul = merge_closures (fun x -> x.gt_closure) l m in + let one_step_gt = ru.one_s_gt in + (SOF.union (SOF.union (SOF.union _Ul one_step_gt) _Uk) _Uj) + in + { + eq_closure = eq_c; + ge_closure = ge_c; + gt_closure = gt_c; + in_gegt_of = ru.in_gegt_of; + one_s_eq = ru.one_s_eq; + one_s_ge = ru.one_s_ge; + one_s_gt = ru.one_s_gt + } + +let rec simple_adjust m = + let m' = + MAL.mapi (fun x _ -> closure_of x m) m + in + if not (are_ugraph_eq m m') then( + simple_adjust m') + else + m' + +let add_eq_arc u v m = + let ru = repr u m in + let rv = repr v m in + let ru' = {ru with one_s_eq = SOF.add v ru.one_s_eq} in + let m' = MAL.add u ru' m in + let rv' = {rv with one_s_eq = SOF.add u rv.one_s_eq} in + let m'' = MAL.add v rv' m' in + simple_adjust m'' + +let add_ge_arc u v m = + let ru = repr u m in + let ru' = { ru with one_s_ge = SOF.add v ru.one_s_ge} in + let m' = MAL.add u ru' m in + simple_adjust m' + +let add_gt_arc u v m = + let ru = repr u m in + let ru' = {ru with one_s_gt = SOF.add v ru.one_s_gt} in + let m' = MAL.add u ru' m in + simple_adjust m' + + +(*****************************************************************************) +(** Outhern interface, that chooses between _fast and safe **) +(*****************************************************************************) + +(* + given the 2 nodes plus the current bag, adds the arc, recomputes the + closures and returns the new map +*) +let add_eq fast u v b = + if fast then + add_eq_arc_fast u v b + else + add_eq_arc u v b + +(* + given the 2 nodes plus the current bag, adds the arc, recomputes the + closures and returns the new map +*) +let add_ge fast u v b = + if fast then + add_ge_arc_fast u v b + else + add_ge_arc u v b +(* + given the 2 nodes plus the current bag, adds the arc, recomputes the + closures and returns the new map +*) +let add_gt fast u v b = + if fast then + add_gt_arc_fast u v b + else + add_gt_arc u v b + + +(*****************************************************************************) +(** Other real code **) +(*****************************************************************************) + +exception UniverseInconsistency of string + +let error arc node1 closure_type node2 closure = + let s = "\n ===== Universe Inconsistency detected =====\n\n" ^ + " Unable to add\n" ^ + "\t" ^ (string_of_arc arc) ^ "\n" ^ + " cause\n" ^ + "\t" ^ (string_of_universe node1) ^ "\n" ^ + " is in the " ^ closure_type ^ " closure\n" ^ + "\t{" ^ (string_of_universe_set closure) ^ "}\n" ^ + " of\n" ^ + "\t" ^ (string_of_universe node2) ^ "\n\n" ^ + " ===== Universe Inconsistency detected =====\n" in + prerr_endline s; + raise (UniverseInconsistency s) + + +let fill_empty_nodes_with_uri (g, already_contained) l uri = + let fill_empty_universe u = + match u with + (i,None) -> (i,Some uri) + | (i,Some _) as u -> u + in + let fill_empty_set s = + SOF.fold (fun e s -> SOF.add (fill_empty_universe e) s) s SOF.empty + in + let fill_empty_entry e = { + eq_closure = (fill_empty_set e.eq_closure) ; + ge_closure = (fill_empty_set e.ge_closure) ; + gt_closure = (fill_empty_set e.gt_closure) ; + in_gegt_of = (fill_empty_set e.in_gegt_of) ; + one_s_eq = (fill_empty_set e.one_s_eq) ; + one_s_ge = (fill_empty_set e.one_s_ge) ; + one_s_gt = (fill_empty_set e.one_s_gt) ; + } in + let m = g in + let m' = MAL.fold ( + fun k v m -> + MAL.add (fill_empty_universe k) (fill_empty_entry v) m) m MAL.empty + in + let l' = List.map fill_empty_universe l in + (m', already_contained),l' + + +(*****************************************************************************) +(** World interface **) +(*****************************************************************************) + +type universe_graph = bag * UriManager.UriSet.t +(* the graph , the cache of already merged ugraphs *) + +let empty_ugraph = empty_bag, UriManager.UriSet.empty + +let current_index_anon = ref (-1) +let current_index_named = ref (-1) + +let restart_numbering () = current_index_named := (-1) + +let fresh ?uri ?id () = + let i = + match uri,id with + | None,None -> + current_index_anon := !current_index_anon + 1; + !current_index_anon + | None, Some _ -> assert false + | Some _, None -> + current_index_named := !current_index_named + 1; + !current_index_named + | Some _, Some id -> id + in + (i,uri) + +let name_universe u uri = + match u with + | (i, None) -> (i, Some uri) + | _ -> u + +let print_ugraph (g, _) = + prerr_endline (string_of_bag g) + +let add_eq ?(fast=(!fast_implementation)) u v b = + (* should we check to no add twice the same?? *) + let m = b in + let ru = repr u m in + if SOF.mem v ru.gt_closure then + error ("EQ",u,v) v "GT" u ru.gt_closure + else + begin + let rv = repr v m in + if SOF.mem u rv.gt_closure then + error ("EQ",u,v) u "GT" v rv.gt_closure + else + add_eq fast u v b + end + +let add_ge ?(fast=(!fast_implementation)) u v b = + (* should we check to no add twice the same?? *) + let m = b in + let rv = repr v m in + if SOF.mem u rv.gt_closure then + error ("GE",u,v) u "GT" v rv.gt_closure + else + add_ge fast u v b + +let add_gt ?(fast=(!fast_implementation)) u v b = + (* should we check to no add twice the same?? *) + (* + FIXME : check the thesis... no need to check GT and EQ closure since the + GE is a superset of both + *) + let m = b in + let rv = repr v m in + + if u = v then + error ("GT",u,v) u "==" v SOF.empty + else + + (*if SOF.mem u rv.gt_closure then + error ("GT",u,v) u "GT" v rv.gt_closure + else + begin*) + if SOF.mem u rv.ge_closure then + error ("GT",u,v) u "GE" v rv.ge_closure + else +(* begin + if SOF.mem u rv.eq_closure then + error ("GT",u,v) u "EQ" v rv.eq_closure + else*) + add_gt fast u v b +(* end + end*) + +(*****************************************************************************) +(** START: Decomment this for performance comparisons **) +(*****************************************************************************) + +let add_eq ?(fast=(!fast_implementation)) u v (b,already_contained) = + (*prerr_endline "add_eq";*) + begin_spending (); + let rc = add_eq ~fast u v b in + end_spending (); + rc,already_contained + +let add_ge ?(fast=(!fast_implementation)) u v (b,already_contained) = +(* prerr_endline "add_ge"; *) + begin_spending (); + let rc = add_ge ~fast u v b in + end_spending (); + rc,already_contained + +let add_gt ?(fast=(!fast_implementation)) u v (b,already_contained) = +(* prerr_endline "add_gt"; *) + begin_spending (); + let rc = add_gt ~fast u v b in + end_spending (); + rc,already_contained + +let profiler_eq = HExtlib.profile "CicUniv.add_eq" +let profiler_ge = HExtlib.profile "CicUniv.add_ge" +let profiler_gt = HExtlib.profile "CicUniv.add_gt" +let add_gt ?fast u v b = + profiler_gt.HExtlib.profile (fun _ -> add_gt ?fast u v b) () +let add_ge ?fast u v b = + profiler_ge.HExtlib.profile (fun _ -> add_ge ?fast u v b) () +let add_eq ?fast u v b = + profiler_eq.HExtlib.profile (fun _ -> add_eq ?fast u v b) () + +(*****************************************************************************) +(** END: Decomment this for performance comparisons **) +(*****************************************************************************) + +let merge_ugraphs ~base_ugraph ~increment:(increment, uri_of_increment) = + let merge_brutal (u,_) v = + let m1 = u in + let m2 = v in + MAL.fold ( + fun k v x -> + (SOF.fold ( + fun u x -> + let m = add_gt k u x in m) + (SOF.union v.one_s_gt v.gt_closure) + (SOF.fold ( + fun u x -> + let m = add_ge k u x in m) + (SOF.union v.one_s_ge v.ge_closure) + (SOF.fold ( + fun u x -> + let m = add_eq k u x in m) + (SOF.union v.one_s_eq v.eq_closure) x))) + ) m1 m2 + in + let base, already_contained = base_ugraph in + if MAL.is_empty base then + increment + else if + MAL.is_empty (fst increment) || + UriManager.UriSet.mem uri_of_increment already_contained + then + base_ugraph + else + fst (merge_brutal increment base_ugraph), + UriManager.UriSet.add uri_of_increment already_contained + +let profiler_merge = HExtlib.profile "CicUniv.merge_graphs" +let merge_ugraphs ~base_ugraph ~increment = + profiler_merge.HExtlib.profile + (fun _ -> merge_ugraphs ~base_ugraph ~increment) () + +(*****************************************************************************) +(** Xml sesialization and parsing **) +(*****************************************************************************) + +let xml_of_universe name u = + match u with + | (i,Some u) -> + Xml.xml_empty name [ + None,"id",(string_of_int i) ; + None,"uri",(UriManager.string_of_uri u)] + | (_,None) -> + raise (Failure "we can serialize only universes with uri") + +let xml_of_set s = + let l = + List.map (xml_of_universe "node") (SOF.elements s) + in + List.fold_left (fun s x -> [< s ; x >] ) [<>] l + +let xml_of_entry_content e = + let stream_of_field f name = + let eq_c = xml_of_set f in + if eq_c != [<>] then + Xml.xml_nempty name [] eq_c + else + [<>] + in + [< + (stream_of_field e.eq_closure "eq_closure"); + (stream_of_field e.gt_closure "gt_closure"); + (stream_of_field e.ge_closure "ge_closure"); + (stream_of_field e.in_gegt_of "in_gegt_of"); + (stream_of_field e.one_s_eq "one_s_eq"); + (stream_of_field e.one_s_gt "one_s_gt"); + (stream_of_field e.one_s_ge "one_s_ge") + >] + +let xml_of_entry u e = + let (i,u') = u in + let u'' = + match u' with + Some x -> x + | None -> + raise (Failure "we can serialize only universes (entry) with uri") + in + let ent = Xml.xml_nempty "entry" [ + None,"id",(string_of_int i) ; + None,"uri",(UriManager.string_of_uri u'')] in + let content = xml_of_entry_content e in + ent content + +let write_xml_of_ugraph filename (m,_) l = + let tokens = + [< + Xml.xml_cdata "\n"; + Xml.xml_nempty "ugraph" [] + ([< (MAL.fold ( fun k v s -> [< s ; (xml_of_entry k v) >]) m [<>]) ; + (List.fold_left + (fun s u -> [< s ; xml_of_universe "owned_node" u >]) [<>] l) >])>] + in + Xml.pp ~gzip:true tokens (Some filename) + +let univno = fst + + +let rec clean_ugraph (m,already_contained) f = + let m' = + MAL.fold (fun k v x -> if (f k) then MAL.add k v x else x ) m MAL.empty in + let m'' = MAL.fold (fun k v x -> + let v' = { + eq_closure = SOF.filter f v.eq_closure; + ge_closure = SOF.filter f v.ge_closure; + gt_closure = SOF.filter f v.gt_closure; + in_gegt_of = SOF.filter f v.in_gegt_of; + one_s_eq = SOF.filter f v.one_s_eq; + one_s_ge = SOF.filter f v.one_s_ge; + one_s_gt = SOF.filter f v.one_s_gt + } in + MAL.add k v' x ) m' MAL.empty in + let e_l = + MAL.fold (fun k v l -> if v = empty_entry && not(f k) then + begin + k::l end else l) m'' [] + in + if e_l != [] then + clean_ugraph + (m'', already_contained) (fun u -> (f u) && not (List.mem u e_l)) + else + MAL.fold + (fun k v x -> if v <> empty_entry then MAL.add k v x else x) + m'' MAL.empty, + already_contained + +let clean_ugraph g l = + clean_ugraph g (fun u -> List.mem u l) + +let assigner_of = + function + "ge_closure" -> (fun e u->{e with ge_closure=SOF.add u e.ge_closure}) + | "gt_closure" -> (fun e u->{e with gt_closure=SOF.add u e.gt_closure}) + | "eq_closure" -> (fun e u->{e with eq_closure=SOF.add u e.eq_closure}) + | "in_gegt_of" -> (fun e u->{e with in_gegt_of =SOF.add u e.in_gegt_of}) + | "one_s_ge" -> (fun e u->{e with one_s_ge =SOF.add u e.one_s_ge}) + | "one_s_gt" -> (fun e u->{e with one_s_gt =SOF.add u e.one_s_gt}) + | "one_s_eq" -> (fun e u->{e with one_s_eq =SOF.add u e.one_s_eq}) + | s -> raise (Failure ("unsupported tag " ^ s)) +;; + +let cb_factory m l = + let module XPP = XmlPushParser in + let current_node = ref (0,None) in + let current_entry = ref empty_entry in + let current_assign = ref (assigner_of "in_gegt_of") in + { XPP.default_callbacks with + XPP.end_element = Some( fun name -> + match name with + | "entry" -> + m := MAL.add !current_node !current_entry !m; + current_entry := empty_entry + | _ -> () + ); + XPP.start_element = Some( fun name attlist -> + match name with + | "ugraph" -> () + | "entry" -> + let id = List.assoc "id" attlist in + let uri = List.assoc "uri" attlist in + current_node := (int_of_string id,Some (UriManager.uri_of_string uri)) + | "node" -> + let id = int_of_string (List.assoc "id" attlist) in + let uri = List.assoc "uri" attlist in + current_entry := !current_assign !current_entry + (id,Some (UriManager.uri_of_string uri)) + | "owned_node" -> + let id = int_of_string (List.assoc "id" attlist) in + let uri = List.assoc "uri" attlist in + l := (id,Some (UriManager.uri_of_string uri)) :: !l + | s -> current_assign := assigner_of s + ) + } +;; + +let ugraph_and_univlist_of_xml filename = + let module XPP = XmlPushParser in + let result_map = ref MAL.empty in + let result_list = ref [] in + let cb = cb_factory result_map result_list in + let xml_parser = XPP.create_parser cb in + let xml_source = `Gzip_file filename in + (try XPP.parse xml_parser xml_source + with (XPP.Parse_error err) as exn -> raise exn); + (!result_map,UriManager.UriSet.empty), !result_list + + +(*****************************************************************************) +(** the main, only for testing **) +(*****************************************************************************) + +(* + +type arc = Ge | Gt | Eq ;; + +let randomize_actionlist n m = + let ge_percent = 0.7 in + let gt_percent = 0.15 in + let random_step () = + let node1 = Random.int m in + let node2 = Random.int m in + let op = + let r = Random.float 1.0 in + if r < ge_percent then + Ge + else (if r < (ge_percent +. gt_percent) then + Gt + else + Eq) + in + op,node1,node2 + in + let rec aux n = + match n with + 0 -> [] + | n -> (random_step ())::(aux (n-1)) + in + aux n + +let print_action_list l = + let string_of_step (op,node1,node2) = + (match op with + Ge -> "Ge" + | Gt -> "Gt" + | Eq -> "Eq") ^ + "," ^ (string_of_int node1) ^ "," ^ (string_of_int node2) + in + let rec aux l = + match l with + [] -> "]" + | a::tl -> + ";" ^ (string_of_step a) ^ (aux tl) + in + let body = aux l in + let l_body = (String.length body) - 1 in + prerr_endline ("[" ^ (String.sub body 1 l_body)) + +let debug = false +let d_print_endline = if debug then print_endline else ignore +let d_print_ugraph = if debug then print_ugraph else ignore + +let _ = + (if Array.length Sys.argv < 2 then + prerr_endline ("Usage " ^ Sys.argv.(0) ^ " max_edges max_nodes")); + Random.self_init (); + let max_edges = int_of_string Sys.argv.(1) in + let max_nodes = int_of_string Sys.argv.(2) in + let action_listR = randomize_actionlist max_edges max_nodes in + + let action_list = [Ge,1,4;Ge,2,6;Ge,1,1;Eq,6,4;Gt,6,3] in + let action_list = action_listR in + + print_action_list action_list; + let prform_step ?(fast=false) (t,u,v) g = + let f,str = + match t with + Ge -> add_ge,">=" + | Gt -> add_gt,">" + | Eq -> add_eq,"=" + in + d_print_endline ( + "Aggiungo " ^ + (string_of_int u) ^ + " " ^ str ^ " " ^ + (string_of_int v)); + let g' = f ~fast (u,None) (v,None) g in + (*print_ugraph g' ;*) + g' + in + let fail = ref false in + let time1 = Unix.gettimeofday () in + let n_safe = ref 0 in + let g_safe = + try + d_print_endline "SAFE"; + List.fold_left ( + fun g e -> + n_safe := !n_safe + 1; + prform_step e g + ) empty_ugraph action_list + with + UniverseInconsistency s -> fail:=true;empty_bag + in + let time2 = Unix.gettimeofday () in + d_print_ugraph g_safe; + let time3 = Unix.gettimeofday () in + let n_test = ref 0 in + let g_test = + try + d_print_endline "FAST"; + List.fold_left ( + fun g e -> + n_test := !n_test + 1; + prform_step ~fast:true e g + ) empty_ugraph action_list + with + UniverseInconsistency s -> empty_bag + in + let time4 = Unix.gettimeofday () in + d_print_ugraph g_test; + if are_ugraph_eq g_safe g_test && !n_test = !n_safe then + begin + let num_eq = + List.fold_left ( + fun s (e,_,_) -> + if e = Eq then s+1 else s + ) 0 action_list + in + let num_gt = + List.fold_left ( + fun s (e,_,_) -> + if e = Gt then s+1 else s + ) 0 action_list + in + let num_ge = max_edges - num_gt - num_eq in + let time_fast = (time4 -. time3) in + let time_safe = (time2 -. time1) in + let gap = ((time_safe -. time_fast) *. 100.0) /. time_safe in + let fail = if !fail then 1 else 0 in + print_endline + (sprintf + "OK %d safe %1.4f fast %1.4f %% %1.2f #eq %d #gt %d #ge %d %d" + fail time_safe time_fast gap num_eq num_gt num_ge !n_safe); + exit 0 + end + else + begin + print_endline "FAIL"; + print_ugraph g_safe; + print_ugraph g_test; + exit 1 + end +;; + + *) + +let recons_univ u = + match u with + | i, None -> u + | i, Some uri -> + i, Some (UriManager.uri_of_string (UriManager.string_of_uri uri)) + +let recons_entry entry = + let recons_set set = + SOF.fold (fun univ set -> SOF.add (recons_univ univ) set) set SOF.empty + in + { + eq_closure = recons_set entry.eq_closure; + ge_closure = recons_set entry.ge_closure; + gt_closure = recons_set entry.gt_closure; + in_gegt_of = recons_set entry.in_gegt_of; + one_s_eq = recons_set entry.one_s_eq; + one_s_ge = recons_set entry.one_s_ge; + one_s_gt = recons_set entry.one_s_gt; + } + +let recons_graph (graph,uriset) = + MAL.fold + (fun universe entry map -> + MAL.add (recons_univ universe) (recons_entry entry) map) + graph + MAL.empty, + UriManager.UriSet.fold + (fun u acc -> + UriManager.UriSet.add + (UriManager.uri_of_string (UriManager.string_of_uri u)) acc) + uriset UriManager.UriSet.empty + +let assert_univ u = + match u with + | (_,None) -> raise (UniverseInconsistency "This universe graph has a hole") + | _ -> () + +let assert_univs_have_uri (graph,_) univlist = + let assert_set s = + SOF.iter (fun u -> assert_univ u) s + in + let assert_entry e = + assert_set e.eq_closure; + assert_set e.ge_closure; + assert_set e.gt_closure; + assert_set e.in_gegt_of; + assert_set e.one_s_eq; + assert_set e.one_s_ge; + assert_set e.one_s_gt; + in + MAL.iter (fun k v -> assert_univ k; assert_entry v)graph; + List.iter assert_univ univlist + +let eq u1 u2 = + match u1,u2 with + | (id1, Some uri1),(id2, Some uri2) -> + id1 = id2 && UriManager.eq uri1 uri2 + | (id1, None),(id2, None) -> id1 = id2 + | _ -> false + +let compare (id1, uri1) (id2, uri2) = + let cmp = id1 - id2 in + if cmp = 0 then + match uri1,uri2 with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> ~-1 + | Some uri1, Some uri2 -> UriManager.compare uri1 uri2 + else + cmp + +(* EOF *) diff --git a/helm/software/components/cic/cicUniv.mli b/helm/software/components/cic/cicUniv.mli new file mode 100644 index 000000000..eb3c50866 --- /dev/null +++ b/helm/software/components/cic/cicUniv.mli @@ -0,0 +1,154 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + + +(* + The strings contains an unreadable message +*) +exception UniverseInconsistency of string + +(* + Cic.Type of universe +*) +type universe + +(* + Opaque data structure you will use to store constraints +*) +type universe_graph + +(* + returns a fresh universe +*) +val fresh: + ?uri:UriManager.uri -> + ?id:int -> + unit -> + universe + + (* names a universe if unnamed *) +val name_universe: universe -> UriManager.uri -> universe + +(* + really useful at the begin and in all the functions that don't care + of universes +*) +val empty_ugraph: universe_graph + +(* + These are the real functions to add eq/ge/gt constraints + to the passed graph, returning an updated graph or raising + UniverseInconsistency +*) +val add_eq: + ?fast:bool -> universe -> universe -> universe_graph -> universe_graph +val add_ge: + ?fast:bool -> universe -> universe -> universe_graph -> universe_graph +val add_gt: + ?fast:bool -> universe -> universe -> universe_graph -> universe_graph + +(* + debug function to print the graph to standard error +*) +val print_ugraph: + universe_graph -> unit + +(* + does what expected, but I don't remember why this was exported +*) +val string_of_universe: + universe -> string + +(* + given the list of visible universes (see universes_of_obj) returns a + cleaned graph (cleaned from the not visible nodes) +*) +val clean_ugraph: + universe_graph -> universe list -> universe_graph + +(* + Since fresh() can't add the right uri to each node, you + must fill empty nodes with the uri before you serialize the graph to xml + + these empty nodes are also filled in the universe list +*) +val fill_empty_nodes_with_uri: + universe_graph -> universe list -> UriManager.uri -> + universe_graph * universe list + +(* + makes a union. + TODO: + - remember already merged uri so that we completely skip already merged + graphs, this may include a dependecy graph (not merge a subpart of an + already merged graph) +*) +val merge_ugraphs: + base_ugraph:universe_graph -> + increment:(universe_graph * UriManager.uri) -> universe_graph + +(* + ugraph to xml file and viceversa +*) +val write_xml_of_ugraph: + string -> universe_graph -> universe list -> unit + +(* + given a filename parses the xml and returns the data structure +*) +val ugraph_and_univlist_of_xml: + string -> universe_graph * universe list +val restart_numbering: + unit -> unit + +(* + returns the universe number (used to save it do xml) +*) +val univno: universe -> int + + (** re-hash-cons URIs contained in the given universe so that phisicaly + * equality could be enforced. Mainly used by + * CicEnvironment.restore_from_channel *) +val recons_graph: universe_graph -> universe_graph + + (** re-hash-cons a single universe *) +val recons_univ: universe -> universe + + (** consistency chek that should be done before committin the graph to the + * cache *) +val assert_univs_have_uri: universe_graph -> universe list-> unit + + (** asserts the universe is named *) +val assert_univ: universe -> unit + +val compare: universe -> universe -> int +val eq: universe -> universe -> bool + +(* + Benchmarking stuff +*) +val get_spent_time: unit -> float +val reset_spent_time: unit -> unit + diff --git a/helm/software/components/cic/cicUtil.ml b/helm/software/components/cic/cicUtil.ml new file mode 100644 index 000000000..7c6e3eabe --- /dev/null +++ b/helm/software/components/cic/cicUtil.ml @@ -0,0 +1,365 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +exception Meta_not_found of int +exception Subst_not_found of int + +let lookup_meta index metasenv = + try + List.find (fun (index', _, _) -> index = index') metasenv + with Not_found -> raise (Meta_not_found index) + +let lookup_subst n subst = + try + List.assoc n subst + with Not_found -> raise (Subst_not_found n) + +let exists_meta index = List.exists (fun (index', _, _) -> (index = index')) + +(* clean_up_meta take a substitution, a metasenv a meta_inex and a local +context l and clean up l with respect to the hidden hipothesis in the +canonical context *) + +let clean_up_local_context subst metasenv n l = + let cc = + (try + let (cc,_,_) = lookup_subst n subst in cc + with Subst_not_found _ -> + try + let (_,cc,_) = lookup_meta n metasenv in cc + with Meta_not_found _ -> assert false) in + (try + List.map2 + (fun t1 t2 -> + match t1,t2 with + None , _ -> None + | _ , t -> t) cc l + with + Invalid_argument _ -> assert false) + +let is_closed = + let module C = Cic in + let rec is_closed k = + function + C.Rel m when m > k -> false + | C.Rel m -> true + | C.Meta (_,l) -> + List.fold_left + (fun i t -> i && (match t with None -> true | Some t -> is_closed k t) + ) true l + | C.Sort _ -> true + | C.Implicit _ -> assert false + | C.Cast (te,ty) -> is_closed k te && is_closed k ty + | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest + | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest + | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest + | C.Appl l -> + List.fold_right (fun x i -> i && is_closed k x) l true + | 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 && is_closed k x) + exp_named_subst true + | C.MutCase (_,_,out,te,pl) -> + is_closed k out && is_closed k te && + List.fold_right (fun x i -> i && is_closed k x) pl true + | C.Fix (_,fl) -> + let len = List.length fl in + let k_plus_len = k + len in + List.fold_right + (fun (_,_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo + ) fl true + | C.CoFix (_,fl) -> + let len = List.length fl in + let k_plus_len = k + len in + List.fold_right + (fun (_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo + ) fl true +in + is_closed 0 +;; + +let rec is_meta_closed = + function + Cic.Rel _ -> true + | Cic.Meta _ -> false + | Cic.Sort _ -> true + | Cic.Implicit _ -> assert false + | Cic.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty + | Cic.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest + | Cic.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest + | Cic.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest + | Cic.Appl l -> + not (List.exists (fun x -> not (is_meta_closed x)) l) + | Cic.Var (_,exp_named_subst) + | Cic.Const (_,exp_named_subst) + | Cic.MutInd (_,_,exp_named_subst) + | Cic.MutConstruct (_,_,_,exp_named_subst) -> + not (List.exists (fun (_,x) -> not (is_meta_closed x)) exp_named_subst) + | Cic.MutCase (_,_,out,te,pl) -> + is_meta_closed out && is_meta_closed te && + not (List.exists (fun x -> not (is_meta_closed x)) pl) + | Cic.Fix (_,fl) -> + not (List.exists + (fun (_,_,ty,bo) -> + not (is_meta_closed ty) || not (is_meta_closed bo)) + fl) + | Cic.CoFix (_,fl) -> + not (List.exists + (fun (_,ty,bo) -> + not (is_meta_closed ty) || not (is_meta_closed bo)) + fl) +;; + +let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))" +let slash_RE = Str.regexp "/" + +let term_of_uri uri = + let s = UriManager.string_of_uri uri in + try + (if UriManager.uri_is_con uri then + Cic.Const (uri, []) + else if UriManager.uri_is_var uri then + Cic.Var (uri, []) + else if not (Str.string_match xpointer_RE s 0) then + raise (UriManager.IllFormedUri s) + else + let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in + let baseuri = UriManager.uri_of_string baseuri in + (match Str.split slash_RE xpointer with + | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, []) + | [_; tyno; consno] -> + Cic.MutConstruct + (baseuri, int_of_string tyno - 1, int_of_string consno, []) + | _ -> raise Exit)) + with + | Exit + | Failure _ + | Not_found -> raise (UriManager.IllFormedUri s) + +let uri_of_term = function + | Cic.Const (uri, []) + | Cic.Var (uri, []) -> uri + | Cic.MutInd (baseuri, tyno, []) -> + UriManager.uri_of_string + (sprintf "%s#xpointer(1/%d)" (UriManager.string_of_uri baseuri) (tyno+1)) + | Cic.MutConstruct (baseuri, tyno, consno, []) -> + UriManager.uri_of_string + (sprintf "%s#xpointer(1/%d/%d)" (UriManager.string_of_uri baseuri) + (tyno + 1) consno) + | _ -> raise (Invalid_argument "uri_of_term") + + +(* +let pack terms = + List.fold_right + (fun term acc -> Cic.Prod (Cic.Anonymous, term, acc)) + terms (Cic.Sort (Cic.Type (CicUniv.fresh ()))) + +let rec unpack = function + | Cic.Prod (Cic.Anonymous, term, Cic.Sort (Cic.Type _)) -> [term] + | Cic.Prod (Cic.Anonymous, term, tgt) -> term :: unpack tgt + | _ -> assert false +*) + +let rec strip_prods n = function + | t when n = 0 -> t + | Cic.Prod (_, _, tgt) when n > 0 -> strip_prods (n-1) tgt + | _ -> failwith "not enough prods" + +let params_of_obj = function + | Cic.Constant (_, _, _, params, _) + | Cic.Variable (_, _, _, params, _) + | Cic.CurrentProof (_, _, _, _, params, _) + | Cic.InductiveDefinition (_, params, _, _) -> + params + +let attributes_of_obj = function + | Cic.Constant (_, _, _, _, attributes) + | Cic.Variable (_, _, _, _, attributes) + | Cic.CurrentProof (_, _, _, _, _, attributes) + | Cic.InductiveDefinition (_, _, _, attributes) -> + attributes +let rec mk_rels howmany from = + match howmany with + | 0 -> [] + | _ -> (Cic.Rel (howmany + from)) :: (mk_rels (howmany-1) from) + +let id_of_annterm = + function + | Cic.ARel (id,_,_,_) + | Cic.AVar (id,_,_) + | Cic.AMeta (id,_,_) + | Cic.ASort (id,_) + | Cic.AImplicit (id,_) + | Cic.ACast (id,_,_) + | Cic.AProd (id,_,_,_) + | Cic.ALambda (id,_,_,_) + | Cic.ALetIn (id,_,_,_) + | Cic.AAppl (id,_) + | Cic.AConst (id,_,_) + | Cic.AMutInd (id,_,_,_) + | Cic.AMutConstruct (id,_,_,_,_) + | Cic.AMutCase (id,_,_,_,_,_) + | Cic.AFix (id,_,_) + | Cic.ACoFix (id,_,_) -> id + + +let rec rehash_term = + let module C = Cic in + let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in + function + | (C.Rel _) as t -> t + | C.Var (uri,exp_named_subst) -> + let uri' = recons uri in + let exp_named_subst' = + List.map + (function (uri,t) ->(recons uri,rehash_term t)) + exp_named_subst + in + C.Var (uri',exp_named_subst') + | C.Meta (i,l) -> + let l' = + List.map + (function + None -> None + | Some t -> Some (rehash_term t) + ) l + in + C.Meta(i,l') + | C.Sort (C.Type u) -> + CicUniv.assert_univ u; + C.Sort (C.Type (CicUniv.recons_univ u)) + | C.Sort _ as t -> t + | C.Implicit _ as t -> t + | C.Cast (te,ty) -> C.Cast (rehash_term te, rehash_term ty) + | C.Prod (n,s,t) -> C.Prod (n, rehash_term s, rehash_term t) + | C.Lambda (n,s,t) -> C.Lambda (n, rehash_term s, rehash_term t) + | C.LetIn (n,s,t) -> C.LetIn (n, rehash_term s, rehash_term t) + | C.Appl l -> C.Appl (List.map rehash_term l) + | C.Const (uri,exp_named_subst) -> + let uri' = recons uri in + let exp_named_subst' = + List.map + (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst + in + C.Const (uri',exp_named_subst') + | C.MutInd (uri,tyno,exp_named_subst) -> + let uri' = recons uri in + let exp_named_subst' = + List.map + (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst + in + C.MutInd (uri',tyno,exp_named_subst') + | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> + let uri' = recons uri in + let exp_named_subst' = + List.map + (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst + in + C.MutConstruct (uri',tyno,consno,exp_named_subst') + | C.MutCase (uri,i,outty,t,pl) -> + C.MutCase (recons uri, i, rehash_term outty, rehash_term t, + List.map rehash_term pl) + | C.Fix (i, fl) -> + let liftedfl = + List.map + (fun (name, i, ty, bo) -> + (name, i, rehash_term ty, rehash_term bo)) + fl + in + C.Fix (i, liftedfl) + | C.CoFix (i, fl) -> + let liftedfl = + List.map + (fun (name, ty, bo) -> (name, rehash_term ty, rehash_term bo)) + fl + in + C.CoFix (i, liftedfl) + +let rehash_obj = + let module C = Cic in + let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in + function + C.Constant (name,bo,ty,params,attrs) -> + let bo' = + match bo with + None -> None + | Some bo -> Some (rehash_term bo) + in + let ty' = rehash_term ty in + let params' = List.map recons params in + C.Constant (name, bo', ty', params',attrs) + | C.CurrentProof (name,conjs,bo,ty,params,attrs) -> + let conjs' = + List.map + (function (i,hyps,ty) -> + (i, + List.map (function + None -> None + | Some (name,C.Decl t) -> + Some (name,C.Decl (rehash_term t)) + | Some (name,C.Def (bo,ty)) -> + let ty' = + match ty with + None -> None + | Some ty'' -> Some (rehash_term ty'') + in + Some (name,C.Def (rehash_term bo, ty'))) hyps, + rehash_term ty)) + conjs + in + let bo' = rehash_term bo in + let ty' = rehash_term ty in + let params' = List.map recons params in + C.CurrentProof (name, conjs', bo', ty', params',attrs) + | C.Variable (name,bo,ty,params,attrs) -> + let bo' = + match bo with + None -> None + | Some bo -> Some (rehash_term bo) + in + let ty' = rehash_term ty in + let params' = List.map recons params in + C.Variable (name, bo', ty', params',attrs) + | C.InductiveDefinition (tl,params,paramsno,attrs) -> + let params' = List.map recons params in + let tl' = + List.map (function (name, inductive, ty, constructors) -> + name, + inductive, + rehash_term ty, + (List.map + (function (name, ty) -> name, rehash_term ty) + constructors)) + tl + in + C.InductiveDefinition (tl', params', paramsno, attrs) + diff --git a/helm/software/components/cic/cicUtil.mli b/helm/software/components/cic/cicUtil.mli new file mode 100644 index 000000000..b6fd7459d --- /dev/null +++ b/helm/software/components/cic/cicUtil.mli @@ -0,0 +1,61 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +exception Meta_not_found of int +exception Subst_not_found of int + +val lookup_meta: int -> Cic.metasenv -> Cic.conjecture +val lookup_subst: int -> Cic.substitution -> Cic.context * Cic.term * Cic.term +val exists_meta: int -> Cic.metasenv -> bool +val clean_up_local_context : + Cic.substitution -> Cic.metasenv -> int -> (Cic.term option) list + -> (Cic.term option) list + +val is_closed : Cic.term -> bool +val is_meta_closed : Cic.term -> bool + + (** @raise Failure "not enough prods" *) +val strip_prods: int -> Cic.term -> Cic.term + +(** conversions between terms which are fully representable as uris (Var, Const, + * Mutind, and MutConstruct) and corresponding tree representations *) +val term_of_uri: UriManager.uri -> Cic.term (** @raise UriManager.IllFormedUri *) +val uri_of_term: Cic.term -> UriManager.uri (** @raise Invalid_argument "uri_of_term" *) + +val id_of_annterm: Cic.annterm -> Cic.id + +(** {2 Cic selectors} *) + +val params_of_obj: Cic.obj -> UriManager.uri list +val attributes_of_obj: Cic.obj -> Cic.attribute list + +(** mk_rels [howmany] [from] + * creates a list of [howmany] rels starting from [from] in decreasing order *) +val mk_rels : int -> int -> Cic.term list + +(** {2 Uri hash consing} *) +val rehash_term: Cic.term -> Cic.term +val rehash_obj: Cic.obj -> Cic.obj + diff --git a/helm/software/components/cic/deannotate.ml b/helm/software/components/cic/deannotate.ml new file mode 100644 index 000000000..f04f5aa10 --- /dev/null +++ b/helm/software/components/cic/deannotate.ml @@ -0,0 +1,126 @@ +(* 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/. + *) + +(* $Id$ *) + +(* 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,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 + (function + None -> None + | Some at -> Some (deannotate_term at) + ) l + in + C.Meta (n, l') + | C.ASort (_,s) -> C.Sort s + | C.AImplicit (_, annotation) -> C.Implicit annotation + | C.ACast (_,va,ty) -> C.Cast (deannotate_term va, deannotate_term ty) + | C.AProd (_,name,so,ta) -> + C.Prod (name, deannotate_term so, deannotate_term ta) + | C.ALambda (_,name,so,ta) -> + C.Lambda (name, deannotate_term so, deannotate_term ta) + | 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,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) = + (name, index, deannotate_term ty, deannotate_term bo) + +and deannotate_coinductiveFun (_,name,ty,bo) = + (name, deannotate_term ty, deannotate_term bo) +;; + +let deannotate_inductiveType (_, name, isinductive, arity, cons) = + (name, isinductive, deannotate_term arity, + List.map (fun (id,ty) -> (id,deannotate_term ty)) cons) +;; + +let deannotate_obj = + let module C = Cic in + function + C.AConstant (_, _, id, bo, ty, params, attrs) -> + C.Constant (id, + (match bo with None -> None | Some bo -> Some (deannotate_term bo)), + deannotate_term ty, params, attrs) + | C.AVariable (_, name, bo, ty, params, attrs) -> + C.Variable (name, + (match bo with None -> None | Some bo -> Some (deannotate_term bo)), + deannotate_term ty, params, attrs) + | C.ACurrentProof (_, _, name, conjs, bo, ty, params, attrs) -> + C.CurrentProof ( + name, + List.map + (function + (_,id,acontext,con) -> + let context = + List.map + (function + _,Some (n,(C.ADef at)) -> + Some (n,(C.Def ((deannotate_term at),None))) + | _,Some (n,(C.ADecl at)) -> + Some (n,(C.Decl (deannotate_term at))) + | _,None -> None + ) acontext + in + (id,context,deannotate_term con) + ) conjs, + deannotate_term bo,deannotate_term ty, params, attrs + ) + | C.AInductiveDefinition (_, tys, params, parno, attrs) -> + C.InductiveDefinition (List.map deannotate_inductiveType tys, + params, parno, attrs) +;; diff --git a/helm/software/components/cic/deannotate.mli b/helm/software/components/cic/deannotate.mli new file mode 100644 index 000000000..89b18d2d6 --- /dev/null +++ b/helm/software/components/cic/deannotate.mli @@ -0,0 +1,36 @@ +(* 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 *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 29/11/2000 *) +(* *) +(******************************************************************************) + +val deannotate_term : Cic.annterm -> Cic.term +val deannotate_obj : Cic.annobj -> Cic.obj diff --git a/helm/software/components/cic/discrimination_tree.ml b/helm/software/components/cic/discrimination_tree.ml new file mode 100644 index 000000000..bab98921d --- /dev/null +++ b/helm/software/components/cic/discrimination_tree.ml @@ -0,0 +1,343 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +module DiscriminationTreeIndexing = + functor (A:Set.S) -> + struct + + type path_string_elem = Cic.term;; + type path_string = path_string_elem list;; + + + (* needed by the retrieve_* functions, to know the arities of the "functions" *) + + let arities = Hashtbl.create 11;; + + + let rec path_string_of_term = function + | Cic.Meta _ -> [Cic.Implicit None] + | Cic.Appl ((hd::tl) as l) -> + if not (Hashtbl.mem arities hd) then + Hashtbl.add arities hd (List.length tl); + List.concat (List.map path_string_of_term l) + | term -> [term] + ;; + + + module OrderedPathStringElement = struct + type t = path_string_elem + + let compare = Pervasives.compare + end + + module PSMap = Map.Make(OrderedPathStringElement);; + + type key = PSMap.key + + module DiscriminationTree = Trie.Make(PSMap);; + + type t = A.t DiscriminationTree.t + let empty = DiscriminationTree.empty + +(* + module OrderedPosEquality = struct + type t = Utils.pos * Inference.equality + let compare = Pervasives.compare + end + + module PosEqSet = Set.Make(OrderedPosEquality);; + + let string_of_discrimination_tree tree = + let rec to_string level = function + | DiscriminationTree.Node (value, map) -> + let s = + match value with + | Some v -> + (String.make (2 * level) ' ') ^ + "{" ^ (String.concat "; " + (List.map + (fun (p, e) -> + "(" ^ (Utils.string_of_pos p) ^ ", " ^ + (Inference.string_of_equality e) ^ ")") + (PosEqSet.elements v))) ^ "}" + | None -> "" + in + let rest = + String.concat "\n" + (PSMap.fold + (fun k v s -> + let ks = CicPp.ppterm k in + let rs = to_string (level+1) v in + ((String.make (2 * level) ' ') ^ ks ^ "\n" ^ rs)::s) + map []) + in + s ^ rest + in + to_string 0 tree + ;; +*) + + let index tree term info = + let ps = path_string_of_term term in + let ps_set = + try DiscriminationTree.find ps tree + with Not_found -> A.empty in + let tree = + DiscriminationTree.add ps (A.add info ps_set) tree in + tree + +(* + let index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let psl = path_string_of_term l + and psr = path_string_of_term r in + let index pos tree ps = + let ps_set = + try DiscriminationTree.find ps tree with Not_found -> PosEqSet.empty in + let tree = + DiscriminationTree.add ps (PosEqSet.add (pos, equality) ps_set) tree in + tree + in + match ordering with + | Utils.Gt -> index Utils.Left tree psl + | Utils.Lt -> index Utils.Right tree psr + | _ -> + let tree = index Utils.Left tree psl in + index Utils.Right tree psr + ;; +*) + + let remove_index tree term info = + let ps = path_string_of_term term in + try + let ps_set = + A.remove info (DiscriminationTree.find ps tree) in + if A.is_empty ps_set then + DiscriminationTree.remove ps tree + else + DiscriminationTree.add ps ps_set tree + with Not_found -> + tree + +(* +let remove_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let psl = path_string_of_term l + and psr = path_string_of_term r in + let remove_index pos tree ps = + try + let ps_set = + PosEqSet.remove (pos, equality) (DiscriminationTree.find ps tree) in + if PosEqSet.is_empty ps_set then + DiscriminationTree.remove ps tree + else + DiscriminationTree.add ps ps_set tree + with Not_found -> + tree + in + match ordering with + | Utils.Gt -> remove_index Utils.Left tree psl + | Utils.Lt -> remove_index Utils.Right tree psr + | _ -> + let tree = remove_index Utils.Left tree psl in + remove_index Utils.Right tree psr +;; +*) + + + let in_index tree term test = + let ps = path_string_of_term term in + try + let ps_set = DiscriminationTree.find ps tree in + A.exists test ps_set + with Not_found -> + false + +(* + let in_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let psl = path_string_of_term l + and psr = path_string_of_term r in + let meta_convertibility = Inference.meta_convertibility_eq equality in + let ok ps = + try + let set = DiscriminationTree.find ps tree in + PosEqSet.exists (fun (p, e) -> meta_convertibility e) set + with Not_found -> + false + in + (ok psl) || (ok psr) +;; +*) + + + let head_of_term = function + | Cic.Appl (hd::tl) -> hd + | term -> term + ;; + + + let rec subterm_at_pos pos term = + match pos with + | [] -> term + | index::pos -> + match term with + | Cic.Appl l -> + (try subterm_at_pos pos (List.nth l index) + with Failure _ -> raise Not_found) + | _ -> raise Not_found + ;; + + + let rec after_t pos term = + let pos' = + match pos with + | [] -> raise Not_found + | pos -> List.fold_right (fun i r -> if r = [] then [i+1] else i::r) pos [] + in + try + ignore(subterm_at_pos pos' term ); pos' + with Not_found -> + let pos, _ = + List.fold_right + (fun i (r, b) -> if b then (i::r, true) else (r, true)) pos ([], false) + in + after_t pos term + ;; + + + let next_t pos term = + let t = subterm_at_pos pos term in + try + let _ = subterm_at_pos [1] t in + pos @ [1] + with Not_found -> + match pos with + | [] -> [1] + | pos -> after_t pos term + ;; + + + let retrieve_generalizations tree term = + let rec retrieve tree term pos = + match tree with + | DiscriminationTree.Node (Some s, _) when pos = [] -> s + | DiscriminationTree.Node (_, map) -> + let res = + try + let hd_term = head_of_term (subterm_at_pos pos term) in + let n = PSMap.find hd_term map in + match n with + | DiscriminationTree.Node (Some s, _) -> s + | DiscriminationTree.Node (None, _) -> + let newpos = try next_t pos term with Not_found -> [] in + retrieve n term newpos + with Not_found -> + A.empty + in + try + let n = PSMap.find (Cic.Implicit None) map in + let newpos = try after_t pos term with Not_found -> [-1] in + if newpos = [-1] then + match n with + | DiscriminationTree.Node (Some s, _) -> A.union s res + | _ -> res + else + A.union res (retrieve n term newpos) + with Not_found -> + res + in + retrieve tree term [] + ;; + + + let jump_list = function + | DiscriminationTree.Node (value, map) -> + let rec get n tree = + match tree with + | DiscriminationTree.Node (v, m) -> + if n = 0 then + [tree] + else + PSMap.fold + (fun k v res -> + let a = try Hashtbl.find arities k with Not_found -> 0 in + (get (n-1 + a) v) @ res) m [] + in + PSMap.fold + (fun k v res -> + let arity = try Hashtbl.find arities k with Not_found -> 0 in + (get arity v) @ res) + map [] + ;; + + + let retrieve_unifiables tree term = + let rec retrieve tree term pos = + match tree with + | DiscriminationTree.Node (Some s, _) when pos = [] -> s + | DiscriminationTree.Node (_, map) -> + let subterm = + try Some (subterm_at_pos pos term) with Not_found -> None + in + match subterm with + | None -> A.empty + | Some (Cic.Meta _) -> + let newpos = try next_t pos term with Not_found -> [] in + let jl = jump_list tree in + List.fold_left + (fun r s -> A.union r s) + A.empty + (List.map (fun t -> retrieve t term newpos) jl) + | Some subterm -> + let res = + try + let hd_term = head_of_term subterm in + let n = PSMap.find hd_term map in + match n with + | DiscriminationTree.Node (Some s, _) -> s + | DiscriminationTree.Node (None, _) -> + retrieve n term (next_t pos term) + with Not_found -> + A.empty + in + try + let n = PSMap.find (Cic.Implicit None) map in + let newpos = try after_t pos term with Not_found -> [-1] in + if newpos = [-1] then + match n with + | DiscriminationTree.Node (Some s, _) -> A.union s res + | _ -> res + else + A.union res (retrieve n term newpos) + with Not_found -> + res + in + retrieve tree term [] + end +;; + diff --git a/helm/software/components/cic/discrimination_tree.mli b/helm/software/components/cic/discrimination_tree.mli new file mode 100644 index 000000000..61631f478 --- /dev/null +++ b/helm/software/components/cic/discrimination_tree.mli @@ -0,0 +1,43 @@ +(* Copyright (C) 2005, 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/. + *) + +module DiscriminationTreeIndexing : + functor (A : Set.S) -> + sig + + val arities : (Cic.term, int) Hashtbl.t + + type key = Cic.term + type t + + val empty : t + val index : t -> key -> A.elt -> t + val remove_index : t -> key -> A.elt -> t + val in_index : t -> key -> (A.elt -> bool) -> bool + val retrieve_generalizations : t -> key -> A.t + val retrieve_unifiables : t -> key -> A.t + end + + diff --git a/helm/software/components/cic/helmLibraryObjects.ml b/helm/software/components/cic/helmLibraryObjects.ml new file mode 100644 index 000000000..3038582ab --- /dev/null +++ b/helm/software/components/cic/helmLibraryObjects.ml @@ -0,0 +1,230 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +(** {2 Auxiliary functions} *) + +let uri = UriManager.uri_of_string + +let const ?(subst = []) uri = Cic.Const (uri, subst) +let var ?(subst = []) uri = Cic.Var (uri, subst) +let mutconstruct ?(subst = []) uri typeno consno = + Cic.MutConstruct (uri, typeno, consno, subst) +let mutind ?(subst = []) uri typeno = Cic.MutInd (uri, typeno, subst) + +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) + +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))) + +(** {2 Helm's objects shorthands} *) + +module Logic = + struct + let eq_SURI = "cic:/Coq/Init/Logic/eq.ind" + let eq_URI = uri eq_SURI + let eq_XURI = eq_SURI ^ "#xpointer(1/1)" + let eq_ind_URI = uri "cic:/Coq/Init/Logic/eq_ind.con" + let eq_ind_r_URI = uri "cic:/Coq/Init/Logic/eq_ind_r.con" + let true_URI = uri "cic:/Coq/Init/Logic/True.ind" + let false_URI = uri "cic:/Coq/Init/Logic/False.ind" + let false_ind_URI = uri "cic:/Coq/Init/Logic/False_ind.con" + let ex_SURI = "cic:/Coq/Init/Logic/ex.ind" + let ex_URI = uri ex_SURI + let ex_XURI = ex_SURI ^ "#xpointer(1/1)" + let ex_ind_URI = uri "cic:/Coq/Init/Logic/ex_ind.con" + let and_SURI = "cic:/Coq/Init/Logic/and.ind" + let and_URI = uri and_SURI + let and_XURI = and_SURI ^ "#xpointer(1/1)" + let and_ind_URI = uri "cic:/Coq/Init/Logic/and_ind.con" + let or_SURI = "cic:/Coq/Init/Logic/or.ind" + let or_URI = uri or_SURI + let or_XURI = or_SURI ^ "#xpointer(1/1)" + let not_SURI = "cic:/Coq/Init/Logic/not.con" + let not_URI = uri not_SURI + let iff_SURI = "cic:/Coq/Init/Logic/iff.con" + let iff_URI = uri "cic:/Coq/Init/Logic/iff.con" + let sym_eq_URI = uri "cic:/Coq/Init/Logic/sym_eq.con" + let trans_eq_URI = uri "cic:/Coq/Init/Logic/trans_eq.con" + let absurd_URI = uri "cic:/Coq/Init/Logic/absurd.con" + end + +module Datatypes = + struct + let bool_URI = uri "cic:/Coq/Init/Datatypes/bool.ind" + let nat_URI = uri "cic:/Coq/Init/Datatypes/nat.ind" + + let trueb = mutconstruct bool_URI 0 1 + let falseb = mutconstruct bool_URI 0 2 + let zero = mutconstruct nat_URI 0 1 + let succ = mutconstruct nat_URI 0 2 + end + +module Reals = + struct + let r_URI = uri "cic:/Coq/Reals/Rdefinitions/R.con" + let rplus_SURI = "cic:/Coq/Reals/Rdefinitions/Rplus.con" + let rplus_URI = uri rplus_SURI + let rminus_SURI = "cic:/Coq/Reals/Rdefinitions/Rminus.con" + let rminus_URI = uri rminus_SURI + let rmult_SURI = "cic:/Coq/Reals/Rdefinitions/Rmult.con" + let rmult_URI = uri rmult_SURI + let rdiv_SURI = "cic:/Coq/Reals/Rdefinitions/Rdiv.con" + let rdiv_URI = uri rdiv_SURI + let ropp_SURI = "cic:/Coq/Reals/Rdefinitions/Ropp.con" + let ropp_URI = uri ropp_SURI + let rinv_SURI = "cic:/Coq/Reals/Rdefinitions/Rinv.con" + let rinv_URI = uri rinv_SURI + let r0_SURI = "cic:/Coq/Reals/Rdefinitions/R0.con" + let r0_URI = uri r0_SURI + let r1_SURI = "cic:/Coq/Reals/Rdefinitions/R1.con" + let r1_URI = uri r1_SURI + let rle_SURI = "cic:/Coq/Reals/Rdefinitions/Rle.con" + let rle_URI = uri rle_SURI + let rge_SURI = "cic:/Coq/Reals/Rdefinitions/Rge.con" + let rge_URI = uri rge_SURI + let rlt_SURI = "cic:/Coq/Reals/Rdefinitions/Rlt.con" + let rlt_URI = uri rlt_SURI + let rgt_SURI = "cic:/Coq/Reals/Rdefinitions/Rgt.con" + let rgt_URI = uri rgt_SURI + let rtheory_URI = uri "cic:/Coq/Reals/RIneq/RTheory.con" + let rinv_r1_URI = uri "cic:/Coq/Reals/RIneq/Rinv_1.con" + let pow_URI = uri "cic:/Coq/Reals/Rfunctions/pow.con" + + let r = const r_URI + let rplus = const rplus_URI + let rmult = const rmult_URI + let ropp = const ropp_URI + let r0 = const r0_URI + let r1 = const r1_URI + let rtheory = const rtheory_URI + end + +module Peano = + struct + let plus_SURI = "cic:/Coq/Init/Peano/plus.con" + let plus_URI = uri plus_SURI + let minus_SURI = "cic:/Coq/Init/Peano/minus.con" + let minus_URI = uri minus_SURI + let mult_SURI = "cic:/Coq/Init/Peano/mult.con" + let mult_URI = uri mult_SURI + let pred_URI = uri "cic:/Coq/Init/Peano/pred.con" + let le_SURI = "cic:/Coq/Init/Peano/le.ind" + let le_URI = uri le_SURI + let le_XURI = le_SURI ^ "#xpointer(1/1)" + let ge_SURI = "cic:/Coq/Init/Peano/ge.con" + let ge_URI = uri ge_SURI + let lt_SURI = "cic:/Coq/Init/Peano/lt.con" + let lt_URI = uri lt_SURI + let gt_SURI = "cic:/Coq/Init/Peano/gt.con" + let gt_URI = uri gt_SURI + + let plus = const plus_URI + let mult = const mult_URI + let pred = const pred_URI + end + +module BinPos = + struct + let positive_SURI = "cic:/Coq/NArith/BinPos/positive.ind" + let positive_URI = uri positive_SURI + let xI = mutconstruct positive_URI 0 1 + let xO = mutconstruct positive_URI 0 2 + let xH = mutconstruct positive_URI 0 3 + let pplus_SURI = "cic:/Coq/NArith/BinPos/Pplus.con" + let pplus_URI = uri pplus_SURI + let pplus = const pplus_URI + let pminus_SURI = "cic:/Coq/NArith/BinPos/Pminus.con" + let pminus_URI = uri pminus_SURI + let pminus = const pminus_URI + let pmult_SURI = "cic:/Coq/NArith/BinPos/Pmult.con" + let pmult_URI = uri pmult_SURI + let pmult = const pmult_URI + end + +module BinInt = + struct + let zmult_URI = uri "cic:/Coq/ZArith/BinInt/Zmult.con" + let zmult = const zmult_URI + let zplus_SURI = "cic:/Coq/ZArith/BinInt/Zplus.con" + let zplus_URI = uri zplus_SURI + let zplus = const zplus_URI + let zminus_SURI = "cic:/Coq/ZArith/BinInt/Zminus.con" + let zminus_URI = uri zminus_SURI + let zminus = const zminus_URI + let z_SURI = "cic:/Coq/ZArith/BinInt/Z.ind" + let z_URI = uri z_SURI + let z0 = mutconstruct z_URI 0 1 + let zpos = mutconstruct z_URI 0 2 + let zneg = mutconstruct z_URI 0 3 + let zopp_SURI = "cic:/Coq/ZArith/BinInt/Zopp.con" + let zopp_URI = uri zopp_SURI + let zopp = const zopp_URI + let zpower_URI = uri "cic:/Coq/ZArith/Zpower/Zpower.con" + end + +(** {2 Helpers for creating common terms} + * (e.g. numbers)} *) + +exception NegativeInteger + +let build_nat n = + if n < 0 then raise NegativeInteger; + let rec aux = function + | 0 -> Datatypes.zero + | n -> Cic.Appl [ Datatypes.succ; (aux (n - 1)) ] + in + aux n + +let build_real n = + if n < 0 then raise NegativeInteger; + let rec aux = function + | 0 -> Reals.r0 + | 1 -> Reals.r1 (* to avoid trailing "+ 0" *) + | n -> Cic.Appl [ Reals.rplus; Reals.r1; (aux (n - 1)) ] + in + aux n + +let build_bin_pos n = + if n < 1 then raise NegativeInteger; + let rec aux = function + | 1 -> BinPos.xH + | n when n mod 2 = 0 -> Cic.Appl [ BinPos.xO; aux (n / 2) ] + | n -> Cic.Appl [ BinPos.xI; aux (n / 2) ] + in + aux n + diff --git a/helm/software/components/cic/helmLibraryObjects.mli b/helm/software/components/cic/helmLibraryObjects.mli new file mode 100644 index 000000000..677879899 --- /dev/null +++ b/helm/software/components/cic/helmLibraryObjects.mli @@ -0,0 +1,182 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +module Logic : + sig + val absurd_URI : UriManager.uri + val and_ind_URI : UriManager.uri + val and_URI : UriManager.uri + val eq_ind_r_URI : UriManager.uri + val eq_ind_URI : UriManager.uri + val eq_URI : UriManager.uri + val ex_ind_URI : UriManager.uri + val ex_URI : UriManager.uri + val false_ind_URI : UriManager.uri + val false_URI : UriManager.uri + val iff_URI : UriManager.uri + val not_URI : UriManager.uri + val or_URI : UriManager.uri + val sym_eq_URI : UriManager.uri + val trans_eq_URI : UriManager.uri + val true_URI : UriManager.uri + + val and_SURI : string + val eq_SURI : string + val ex_SURI : string + val iff_SURI : string + val not_SURI : string + val or_SURI : string + + val and_XURI : string + val eq_XURI : string + val ex_XURI : string + val or_XURI : string + end + +module Datatypes : + sig + val bool_URI : UriManager.uri + val nat_URI : UriManager.uri + + val trueb : Cic.term + val falseb : Cic.term + val zero : Cic.term + val succ : Cic.term + end + +module Reals : + sig + val pow_URI : UriManager.uri + val r0_URI : UriManager.uri + val r1_URI : UriManager.uri + val rdiv_URI : UriManager.uri + val rge_URI : UriManager.uri + val rgt_URI : UriManager.uri + val rinv_r1_URI : UriManager.uri + val rinv_URI : UriManager.uri + val rle_URI : UriManager.uri + val rlt_URI : UriManager.uri + val rminus_URI : UriManager.uri + val rmult_URI : UriManager.uri + val ropp_URI : UriManager.uri + val rplus_URI : UriManager.uri + val rtheory_URI : UriManager.uri + val r_URI : UriManager.uri + + val r0_SURI : string + val r1_SURI : string + val rdiv_SURI : string + val rge_SURI : string + val rgt_SURI : string + val rinv_SURI : string + val rle_SURI : string + val rlt_SURI : string + val rminus_SURI : string + val rmult_SURI : string + val ropp_SURI : string + val rplus_SURI : string + + val r0 : Cic.term + val r1 : Cic.term + val r : Cic.term + val rmult : Cic.term + val ropp : Cic.term + val rplus : Cic.term + val rtheory : Cic.term + end + +module Peano : + sig + val ge_URI : UriManager.uri + val gt_URI : UriManager.uri + val le_URI : UriManager.uri + val lt_URI : UriManager.uri + val minus_URI : UriManager.uri + val mult_URI : UriManager.uri + val plus_URI : UriManager.uri + val pred_URI : UriManager.uri + + val ge_SURI : string + val gt_SURI : string + val le_SURI : string + val lt_SURI : string + val minus_SURI : string + val mult_SURI : string + val plus_SURI : string + + val le_XURI : string + + val mult : Cic.term + val plus : Cic.term + val pred : Cic.term + end + +module BinPos : + sig + val pminus_URI : UriManager.uri + val pmult_URI : UriManager.uri + val positive_URI : UriManager.uri + val pplus_URI : UriManager.uri + + val pminus_SURI : string + val pmult_SURI : string + val positive_SURI : string + val pplus_SURI : string + + val pminus : Cic.term + val pmult : Cic.term + val pplus : Cic.term + val xH : Cic.term + val xI : Cic.term + val xO : Cic.term + end + +module BinInt : + sig + val zminus_URI : UriManager.uri + val zmult_URI : UriManager.uri + val zopp_URI : UriManager.uri + val zplus_URI : UriManager.uri + val zpower_URI : UriManager.uri + val z_URI : UriManager.uri + + val zminus_SURI : string + val zopp_SURI : string + val zplus_SURI : string + val z_SURI : string + + val z0 : Cic.term + val zminus : Cic.term + val zmult : Cic.term + val zneg : Cic.term + val zopp : Cic.term + val zplus : Cic.term + val zpos : Cic.term + end + +val build_bin_pos : int -> Cic.term +val build_nat : int -> Cic.term +val build_real : int -> Cic.term + diff --git a/helm/software/components/cic/libraryObjects.ml b/helm/software/components/cic/libraryObjects.ml new file mode 100644 index 000000000..adbc219cc --- /dev/null +++ b/helm/software/components/cic/libraryObjects.ml @@ -0,0 +1,122 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +(**** TABLES ****) + +let default_eq_URIs = + [HelmLibraryObjects.Logic.eq_URI, + HelmLibraryObjects.Logic.sym_eq_URI, + HelmLibraryObjects.Logic.trans_eq_URI, + HelmLibraryObjects.Logic.eq_ind_URI, + HelmLibraryObjects.Logic.eq_ind_r_URI];; + +let default_true_URIs = [HelmLibraryObjects.Logic.true_URI] +let default_false_URIs = [HelmLibraryObjects.Logic.false_URI] +let default_absurd_URIs = [HelmLibraryObjects.Logic.absurd_URI] + +(* eq, sym_eq, trans_eq, eq_ind, eq_ind_R *) +let eq_URIs_ref = + ref [HelmLibraryObjects.Logic.eq_URI, + HelmLibraryObjects.Logic.sym_eq_URI, + HelmLibraryObjects.Logic.trans_eq_URI, + HelmLibraryObjects.Logic.eq_ind_URI, + HelmLibraryObjects.Logic.eq_ind_r_URI];; + +let true_URIs_ref = ref [HelmLibraryObjects.Logic.true_URI] +let false_URIs_ref = ref [HelmLibraryObjects.Logic.false_URI] +let absurd_URIs_ref = ref [HelmLibraryObjects.Logic.absurd_URI] + + +(**** SET_DEFAULT ****) + +exception NotRecognized;; + +(* insert an element in front of the list, removing from the list all the + previous elements with the same key associated *) +let insert_unique e extract l = + let uri = extract e in + let l' = + List.filter (fun x -> let uri' = extract x in not (UriManager.eq uri uri')) l + in + e :: l' + +let set_default what l = + match what,l with + "equality",[eq_URI;sym_eq_URI;trans_eq_URI;eq_ind_URI;eq_ind_r_URI] -> + eq_URIs_ref := + insert_unique (eq_URI,sym_eq_URI,trans_eq_URI,eq_ind_URI,eq_ind_r_URI) + (fun x,_,_,_,_ -> x) !eq_URIs_ref + | "true",[true_URI] -> + true_URIs_ref := insert_unique true_URI (fun x -> x) !true_URIs_ref + | "false",[false_URI] -> + false_URIs_ref := insert_unique false_URI (fun x -> x) !false_URIs_ref + | "absurd",[absurd_URI] -> + absurd_URIs_ref := insert_unique absurd_URI (fun x -> x) !absurd_URIs_ref + | _,_ -> raise NotRecognized + +let reset_defaults () = + eq_URIs_ref := default_eq_URIs; + true_URIs_ref := default_true_URIs; + false_URIs_ref := default_false_URIs; + absurd_URIs_ref := default_absurd_URIs + +(**** LOOKUP FUNCTIONS ****) + +let eq_URI () = let eq,_,_,_,_ = List.hd !eq_URIs_ref in eq + +let is_eq_URI uri = + List.exists (fun (eq,_,_,_,_) -> UriManager.eq eq uri) !eq_URIs_ref + +let is_eq_ind_URI uri = + List.exists (fun (_,_,_,eq_ind,_) -> UriManager.eq eq_ind uri) !eq_URIs_ref + +let is_eq_ind_r_URI uri = + List.exists (fun (_,_,_,_,eq_ind_r) -> UriManager.eq eq_ind_r uri) !eq_URIs_ref + +let sym_eq_URI ~eq:uri = + try + let _,x,_,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x + with Not_found -> raise NotRecognized + +let trans_eq_URI ~eq:uri = + try + let _,_,x,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x + with Not_found -> raise NotRecognized + +let eq_ind_URI ~eq:uri = + try + let _,_,_,x,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x + with Not_found -> raise NotRecognized + +let eq_ind_r_URI ~eq:uri = + try + let _,_,_,_,x = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x + with Not_found -> raise NotRecognized + +let true_URI () = List.hd !true_URIs_ref +let false_URI () = List.hd !false_URIs_ref +let absurd_URI () = List.hd !absurd_URIs_ref diff --git a/helm/software/components/cic/libraryObjects.mli b/helm/software/components/cic/libraryObjects.mli new file mode 100644 index 000000000..eca5a0d90 --- /dev/null +++ b/helm/software/components/cic/libraryObjects.mli @@ -0,0 +1,46 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val set_default : string -> UriManager.uri list -> unit +val reset_defaults : unit -> unit + +val eq_URI : unit -> UriManager.uri + +val is_eq_URI : UriManager.uri -> bool +val is_eq_ind_URI : UriManager.uri -> bool +val is_eq_ind_r_URI : UriManager.uri -> bool + +exception NotRecognized;; + +val eq_ind_URI : eq:UriManager.uri -> UriManager.uri +val eq_ind_r_URI : eq:UriManager.uri -> UriManager.uri +val trans_eq_URI : eq:UriManager.uri -> UriManager.uri +val sym_eq_URI : eq:UriManager.uri -> UriManager.uri + + +val false_URI : unit -> UriManager.uri +val true_URI : unit -> UriManager.uri +val absurd_URI : unit -> UriManager.uri + diff --git a/helm/software/components/cic/path_indexing.ml b/helm/software/components/cic/path_indexing.ml new file mode 100644 index 000000000..c0e4bb2be --- /dev/null +++ b/helm/software/components/cic/path_indexing.ml @@ -0,0 +1,227 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +(* path indexing implementation *) + +(* position of the subterm, subterm (Appl are not stored...) *) + +module PathIndexing = + functor(A:Set.S) -> + struct + +type path_string_elem = Index of int | Term of Cic.term;; +type path_string = path_string_elem list;; + + +let rec path_strings_of_term index = + let module C = Cic in function + | C.Meta _ -> [ [Index index; Term (C.Implicit None)] ] + | C.Appl (hd::tl) -> + let p = if index > 0 then [Index index; Term hd] else [Term hd] in + let _, res = + List.fold_left + (fun (i, r) t -> + let rr = path_strings_of_term i t in + (i+1, r @ (List.map (fun ps -> p @ ps) rr))) + (1, []) tl + in + res + | term -> [ [Index index; Term term] ] +;; + +(* +let string_of_path_string ps = + String.concat "." + (List.map + (fun e -> + let s = + match e with + | Index i -> "Index " ^ (string_of_int i) + | Term t -> "Term " ^ (CicPp.ppterm t) + in + "(" ^ s ^ ")") + ps) +;; +*) + +module OrderedPathStringElement = struct + type t = path_string_elem + + let compare t1 t2 = + match t1, t2 with + | Index i, Index j -> Pervasives.compare i j + | Term t1, Term t2 -> if t1 = t2 then 0 else Pervasives.compare t1 t2 + | Index _, Term _ -> -1 + | Term _, Index _ -> 1 +end + +module PSMap = Map.Make(OrderedPathStringElement);; + +module PSTrie = Trie.Make(PSMap);; + +type t = A.t PSTrie.t +type key = Cic.term +let empty = PSTrie.empty +let arities = Hashtbl.create 0 + +let index trie term info = + let ps = path_strings_of_term 0 term in + List.fold_left + (fun trie ps -> + let ps_set = try PSTrie.find ps trie with Not_found -> A.empty in + let trie = PSTrie.add ps (A.add info ps_set) trie in + trie) trie ps + +let remove_index trie term info= + let ps = path_strings_of_term 0 term in + List.fold_left + (fun trie ps -> + try + let ps_set = A.remove info (PSTrie.find ps trie) in + if A.is_empty ps_set then + PSTrie.remove ps trie + else + PSTrie.add ps ps_set trie + with Not_found -> trie) trie ps +;; + +let in_index trie term test = + let ps = path_strings_of_term 0 term in + let ok ps = + try + let set = PSTrie.find ps trie in + A.exists test set + with Not_found -> + false + in + List.exists ok ps +;; + + +let head_of_term = function + | Cic.Appl (hd::tl) -> hd + | term -> term +;; + + +let subterm_at_pos index term = + if index = 0 then + term + else + match term with + | Cic.Appl l -> + (try List.nth l index with Failure _ -> raise Not_found) + | _ -> raise Not_found +;; + + +let rec retrieve_generalizations trie term = + match trie with + | PSTrie.Node (value, map) -> + let res = + match term with + | Cic.Meta _ -> A.empty + | term -> + let hd_term = head_of_term term in + try + let n = PSMap.find (Term hd_term) map in + match n with + | PSTrie.Node (Some s, _) -> s + | PSTrie.Node (None, m) -> + let l = + PSMap.fold + (fun k v res -> + match k with + | Index i -> + let t = subterm_at_pos i term in + let s = retrieve_generalizations v t in + s::res + | _ -> res) + m [] + in + match l with + | hd::tl -> + List.fold_left (fun r s -> A.inter r s) hd tl + | _ -> A.empty + with Not_found -> + A.empty + in + try + let n = PSMap.find (Term (Cic.Implicit None)) map in + match n with + | PSTrie.Node (Some s, _) -> A.union res s + | _ -> res + with Not_found -> + res +;; + + +let rec retrieve_unifiables trie term = + match trie with + | PSTrie.Node (value, map) -> + let res = + match term with + | Cic.Meta _ -> + PSTrie.fold + (fun ps v res -> A.union res v) + (PSTrie.Node (None, map)) + A.empty + | _ -> + let hd_term = head_of_term term in + try + let n = PSMap.find (Term hd_term) map in + match n with + | PSTrie.Node (Some v, _) -> v + | PSTrie.Node (None, m) -> + let l = + PSMap.fold + (fun k v res -> + match k with + | Index i -> + let t = subterm_at_pos i term in + let s = retrieve_unifiables v t in + s::res + | _ -> res) + m [] + in + match l with + | hd::tl -> + List.fold_left (fun r s -> A.inter r s) hd tl + | _ -> A.empty + with Not_found -> + A.empty + in + try + let n = PSMap.find (Term (Cic.Implicit None)) map in + match n with + | PSTrie.Node (Some s, _) -> A.union res s + | _ -> res + with Not_found -> + res +;; + +end diff --git a/helm/software/components/cic/path_indexing.mli b/helm/software/components/cic/path_indexing.mli new file mode 100644 index 000000000..899901618 --- /dev/null +++ b/helm/software/components/cic/path_indexing.mli @@ -0,0 +1,42 @@ +(* Copyright (C) 2005, 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/. + *) + +module PathIndexing : + functor (A : Set.S) -> + sig + val arities : (Cic.term, int) Hashtbl.t + + type key = Cic.term + type t + + val empty : t + val index : t -> key -> A.elt -> t + val remove_index : t -> key -> A.elt -> t + val in_index : t -> key -> (A.elt -> bool) -> bool + val retrieve_generalizations : t -> key -> A.t + val retrieve_unifiables : t -> key -> A.t + end + + diff --git a/helm/software/components/cic/test.ml b/helm/software/components/cic/test.ml new file mode 100644 index 000000000..e15468f99 --- /dev/null +++ b/helm/software/components/cic/test.ml @@ -0,0 +1,88 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let _ = + Helm_registry.set "getter.mode" "remote"; + Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/" + +let body_RE = Str.regexp "^.*\\.body$" +let con_RE = Str.regexp "^.*\\.con$" + +let unlink f = + if Sys.file_exists f then + Unix.unlink f + +let rec parse uri tmpfile1 tmpfile2 = +(*prerr_endline (sprintf "%s %s" tmpfile1 (match tmpfile2 with None -> "None" | Some f -> "Some " ^ f));*) + (try + let uri' = UriManager.uri_of_string uri in + let time_new0 = Unix.gettimeofday () in +(* let obj_new = CicPushParser.CicParser.annobj_of_xml tmpfile1 tmpfile2 in*) + let obj_new = CicParser.annobj_of_xml uri' tmpfile1 tmpfile2 in + let time_new1 = Unix.gettimeofday () in + + let time_old0 = Unix.gettimeofday () in + ignore (Unix.system (sprintf "gunzip -c %s > test.tmp && mv test.tmp %s" + tmpfile1 tmpfile1)); + (match tmpfile2 with + | Some tmpfile2 -> + ignore (Unix.system (sprintf "gunzip -c %s > test.tmp && mv test.tmp %s" + tmpfile2 tmpfile2)); + | None -> ()); + let obj_old = CicPxpParser.CicParser.annobj_of_xml uri' tmpfile1 tmpfile2 in + let time_old1 = Unix.gettimeofday () in + + let time_old = time_old1 -. time_old0 in + let time_new = time_new1 -. time_new0 in + let are_equal = (obj_old = obj_new) in + printf "%s\t%b\t%f\t%f\t%f\n" + uri are_equal time_old time_new (time_new /. time_old *. 100.); + flush stdout; + with + | CicParser.Getter_failure ("key_not_found", uri) + when Str.string_match body_RE uri 0 -> + parse uri tmpfile1 None + | CicParser.Parser_failure msg -> + printf "%s FAILED (%s)\n" uri msg; flush stdout) + +let _ = + try + while true do + let uri = input_line stdin in + let tmpfile1 = Http_getter.getxml uri in + let tmpfile2 = + if Str.string_match con_RE uri 0 then begin + Some (Http_getter.getxml (uri ^ ".body")) + end else + None + in + parse uri tmpfile1 tmpfile2 + done + with End_of_file -> () + diff --git a/helm/software/components/cic/unshare.ml b/helm/software/components/cic/unshare.ml new file mode 100644 index 000000000..e198bcd49 --- /dev/null +++ b/helm/software/components/cic/unshare.ml @@ -0,0 +1,84 @@ +(* 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/. + *) + +(* $Id$ *) + +let rec unshare = + let module C = Cic in + function + C.Rel m -> C.Rel m + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (function (uri,t) -> (uri,unshare t)) exp_named_subst + in + C.Var (uri,exp_named_subst') + | C.Meta (i,l) -> + let l' = + List.map + (function + None -> None + | Some t -> Some (unshare t) + ) l + in + C.Meta(i,l') + | C.Sort s -> C.Sort s + | C.Implicit info -> C.Implicit info + | C.Cast (te,ty) -> C.Cast (unshare te, unshare ty) + | C.Prod (n,s,t) -> C.Prod (n, unshare s, unshare t) + | C.Lambda (n,s,t) -> C.Lambda (n, unshare s, unshare t) + | C.LetIn (n,s,t) -> C.LetIn (n, unshare s, unshare t) + | C.Appl l -> C.Appl (List.map unshare l) + | C.Const (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (function (uri,t) -> (uri,unshare 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,unshare 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,unshare t)) exp_named_subst + in + C.MutConstruct (uri,tyno,consno,exp_named_subst') + | C.MutCase (sp,i,outty,t,pl) -> + C.MutCase (sp, i, unshare outty, unshare t, + List.map unshare pl) + | C.Fix (i, fl) -> + let liftedfl = + List.map + (fun (name, i, ty, bo) -> (name, i, unshare ty, unshare bo)) + fl + in + C.Fix (i, liftedfl) + | C.CoFix (i, fl) -> + let liftedfl = + List.map + (fun (name, ty, bo) -> (name, unshare ty, unshare bo)) + fl + in + C.CoFix (i, liftedfl) diff --git a/helm/software/components/cic/unshare.mli b/helm/software/components/cic/unshare.mli new file mode 100644 index 000000000..5582abcbf --- /dev/null +++ b/helm/software/components/cic/unshare.mli @@ -0,0 +1,26 @@ +(* 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 unshare : Cic.term -> Cic.term diff --git a/helm/software/components/cic_acic/.depend b/helm/software/components/cic_acic/.depend new file mode 100644 index 000000000..3fc1e0dce --- /dev/null +++ b/helm/software/components/cic_acic/.depend @@ -0,0 +1,9 @@ +cic2Xml.cmi: cic2acic.cmi +eta_fixing.cmo: eta_fixing.cmi +eta_fixing.cmx: eta_fixing.cmi +doubleTypeInference.cmo: doubleTypeInference.cmi +doubleTypeInference.cmx: doubleTypeInference.cmi +cic2acic.cmo: eta_fixing.cmi doubleTypeInference.cmi cic2acic.cmi +cic2acic.cmx: eta_fixing.cmx doubleTypeInference.cmx cic2acic.cmi +cic2Xml.cmo: cic2acic.cmi cic2Xml.cmi +cic2Xml.cmx: cic2acic.cmx cic2Xml.cmi diff --git a/helm/software/components/cic_acic/Makefile b/helm/software/components/cic_acic/Makefile new file mode 100644 index 000000000..2669afb11 --- /dev/null +++ b/helm/software/components/cic_acic/Makefile @@ -0,0 +1,13 @@ +PACKAGE = cic_acic +PREDICATES = + +INTERFACE_FILES = \ + eta_fixing.mli \ + doubleTypeInference.mli \ + cic2acic.mli \ + cic2Xml.mli \ + $(NULL) +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/cic_acic/cic2Xml.ml b/helm/software/components/cic_acic/cic2Xml.ml new file mode 100644 index 000000000..7e97dea6f --- /dev/null +++ b/helm/software/components/cic_acic/cic2Xml.ml @@ -0,0 +1,483 @@ +(* Copyright (C) 2000-2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +(*CSC codice cut & paste da cicPp e xmlcommand *) + +exception NotImplemented;; + +let dtdname ~ask_dtd_to_the_getter dtd = + if ask_dtd_to_the_getter then + Helm_registry.get "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 ?ids_to_inner_sorts = + let find_sort name id = + match ids_to_inner_sorts with + None -> [] + | Some ids_to_inner_sorts -> + [None,name,Cic2acic.string_of_sort (Hashtbl.find ids_to_inner_sorts id)] + in + let rec aux = + let module C = Cic in + let module X = Xml in + let module U = UriManager in + function + C.ARel (id,idref,n,b) -> + let sort = find_sort "sort" id in + X.xml_empty "REL" + (sort @ + [None,"value",(string_of_int n) ; None,"binder",b ; None,"id",id ; + None,"idref",idref]) + | C.AVar (id,uri,exp_named_subst) -> + let sort = find_sort "sort" id in + aux_subst uri + (X.xml_empty "VAR" + (sort @ [None,"uri",U.string_of_uri uri;None,"id",id])) + exp_named_subst + | C.AMeta (id,n,l) -> + let sort = find_sort "sort" id in + X.xml_nempty "META" + (sort @ [None,"no",(string_of_int n) ; None,"id",id]) + (List.fold_left + (fun i t -> + match t with + Some t' -> + [< i ; X.xml_nempty "substitution" [] (aux t') >] + | None -> + [< i ; X.xml_empty "substitution" [] >] + ) [< >] l) + | C.ASort (id,s) -> + let string_of_sort s = + Cic2acic.string_of_sort (Cic2acic.sort_of_sort s) + in + X.xml_empty "SORT" [None,"value",(string_of_sort s) ; None,"id",id] + | C.AImplicit _ -> raise NotImplemented + | 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 = find_sort "type" last_id in + X.xml_nempty "PROD" sort + [< List.fold_left + (fun i (id,binder,s) -> + let sort = find_sort "type" (Cic2acic.source_id_of_id id) in + let attrs = + sort @ ((None,"id",id):: + match binder with + C.Anonymous -> [] + | C.Name b -> [None,"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 = find_sort "sort" id in + X.xml_nempty "CAST" (sort @ [None,"id",id]) + [< X.xml_nempty "term" [] (aux v) ; + X.xml_nempty "type" [] (aux 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 = find_sort "sort" last_id in + X.xml_nempty "LAMBDA" sort + [< List.fold_left + (fun i (id,binder,s) -> + let sort = find_sort "type" (Cic2acic.source_id_of_id id) in + let attrs = + sort @ ((None,"id",id):: + match binder with + C.Anonymous -> [] + | C.Name b -> [None,"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 (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 = find_sort "sort" last_id in + X.xml_nempty "LETIN" sort + [< List.fold_left + (fun i (id,binder,s) -> + let sort = find_sort "sort" id in + let attrs = + sort @ ((None,"id",id):: + match binder with + C.Anonymous -> [] + | C.Name b -> [None,"binder",b]) + in + [< i ; X.xml_nempty "def" attrs (aux s) >] + ) [< >] letins ; + X.xml_nempty "target" [] (aux t) + >] + | C.AAppl (id,li) -> + let sort = find_sort "sort" id in + X.xml_nempty "APPLY" (sort @ [None,"id",id]) + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]) + >] + | C.AConst (id,uri,exp_named_subst) -> + let sort = find_sort "sort" id in + aux_subst uri + (X.xml_empty "CONST" + (sort @ [None,"uri",(U.string_of_uri uri) ; None,"id",id]) + ) exp_named_subst + | C.AMutInd (id,uri,i,exp_named_subst) -> + aux_subst uri + (X.xml_empty "MUTIND" + [None, "uri", (U.string_of_uri uri) ; + None, "noType", (string_of_int i) ; + None, "id", id] + ) exp_named_subst + | C.AMutConstruct (id,uri,i,j,exp_named_subst) -> + let sort = find_sort "sort" id in + aux_subst uri + (X.xml_empty "MUTCONSTRUCT" + (sort @ + [None,"uri", (U.string_of_uri uri) ; + None,"noType",(string_of_int i) ; + None,"noConstr",(string_of_int j) ; + None,"id",id]) + ) exp_named_subst + | C.AMutCase (id,uri,typeno,ty,te,patterns) -> + let sort = find_sort "sort" id in + X.xml_nempty "MUTCASE" + (sort @ + [None,"uriType",(U.string_of_uri uri) ; + None,"noType", (string_of_int typeno) ; + None,"id", id]) + [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; + X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; + List.fold_right + (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>]) + patterns [<>] + >] + | C.AFix (id, no, funs) -> + let sort = find_sort "sort" id in + X.xml_nempty "FIX" + (sort @ [None,"noFun", (string_of_int no) ; None,"id",id]) + [< List.fold_right + (fun (id,fi,ai,ti,bi) i -> + [< X.xml_nempty "FixFunction" + [None,"id",id ; None,"name", fi ; + None,"recIndex", (string_of_int ai)] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] ; + i + >] + ) funs [<>] + >] + | C.ACoFix (id,no,funs) -> + let sort = find_sort "sort" id in + X.xml_nempty "COFIX" + (sort @ [None,"noFun", (string_of_int no) ; None,"id",id]) + [< List.fold_right + (fun (id,fi,ti,bi) i -> + [< X.xml_nempty "CofixFunction" [None,"id",id ; None,"name", fi] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] ; + i + >] + ) funs [<>] + >] + 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 -> [None,"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" [None,"relUri", relUri] (aux arg) >] + ) [<>] subst + >] + in + aux +;; + +let xml_of_attrs attributes = + let class_of = function + | `Coercion -> Xml.xml_empty "class" [None,"value","coercion"] + | `Elim s -> + Xml.xml_nempty "class" [None,"value","elim"] + [< Xml.xml_empty + "SORT" [None,"value", + (Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)) ; + None,"id","elimination_sort"] >] + | `Record field_names -> + Xml.xml_nempty "class" [None,"value","record"] + (List.fold_right + (fun (name,coercion) res -> + [< Xml.xml_empty "field" + [None,"name",if coercion then name ^ " coercion" else name]; + res >] + ) field_names [<>]) + | `Projection -> Xml.xml_empty "class" [None,"value","projection"] + in + let flavour_of = function + | `Definition -> Xml.xml_empty "flavour" [None, "value", "definition"] + | `Fact -> Xml.xml_empty "flavour" [None, "value", "fact"] + | `Lemma -> Xml.xml_empty "flavour" [None, "value", "lemma"] + | `Remark -> Xml.xml_empty "flavour" [None, "value", "remark"] + | `Theorem -> Xml.xml_empty "flavour" [None, "value", "theorem"] + | `Variant -> Xml.xml_empty "flavour" [None, "value", "variant"] + in + let xml_attr_of = function + | `Generated -> Xml.xml_empty "generated" [] + | `Class c -> class_of c + | `Flavour f -> flavour_of f + in + let xml_attrs = + List.fold_right + (fun attr res -> [< xml_attr_of attr ; res >]) attributes [<>] + in + Xml.xml_nempty "attributes" [] xml_attrs + +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,obj_attrs) -> + let params' = param_attribute_of_params params in + let xml_attrs = xml_of_attrs obj_attrs 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" + [None,"of",UriManager.string_of_uri uri ; None,"id", id] + [< xml_attrs; + List.fold_left + (fun i (cid,n,canonical_context,t) -> + [< i ; + X.xml_nempty "Conjecture" + [None,"id",cid ; None,"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' -> + [None,"id",hid;None,"name",n'] + | C.Anonymous -> [None,"id",hid]) + (print_term ?ids_to_inner_sorts t) + | Some (n,C.ADef t) -> + X.xml_nempty "Def" + (match n with + C.Name n' -> + [None,"id",hid;None,"name",n'] + | C.Anonymous -> [None,"id",hid]) + (print_term ?ids_to_inner_sorts t) + | None -> X.xml_empty "Hidden" [None,"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" + [None,"name",n ; None,"params",params' ; None,"id", id] + (print_term ?ids_to_inner_sorts ty) + in + let xmlbo = + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n"); + xml_for_current_proof_body + >] in + let xmlty = + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n"); + xml_for_current_proof_type + >] + in + xmlty, Some xmlbo + | C.AConstant (id,idbody,n,bo,ty,params,obj_attrs) -> + let params' = param_attribute_of_params params in + let xml_attrs = xml_of_attrs obj_attrs in + let xmlbo = + match bo with + None -> None + | Some bo -> + Some + [< X.xml_cdata + "\n" ; + X.xml_cdata + ("\n") ; + X.xml_nempty "ConstantBody" + [None,"for",UriManager.string_of_uri uri ; + None,"params",params' ; None,"id", id] + [< print_term ?ids_to_inner_sorts bo >] + >] + in + let xmlty = + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n"); + X.xml_nempty "ConstantType" + [None,"name",n ; None,"params",params' ; None,"id", id] + [< xml_attrs; print_term ?ids_to_inner_sorts ty >] + >] + in + xmlty, xmlbo + | C.AVariable (id,n,bo,ty,params,obj_attrs) -> + let params' = param_attribute_of_params params in + let xml_attrs = xml_of_attrs obj_attrs 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 "\n" ; + X.xml_cdata ("\n"); + X.xml_nempty "Variable" + [None,"name",n ; None,"params",params' ; None,"id", id] + [< xml_attrs; xmlbo; + X.xml_nempty "type" [] (print_term ?ids_to_inner_sorts ty) + >] + >] + in + aobj, None + | C.AInductiveDefinition (id,tys,params,nparams,obj_attrs) -> + let params' = param_attribute_of_params params in + let xml_attrs = xml_of_attrs obj_attrs in + [< X.xml_cdata "\n" ; + X.xml_cdata + ("\n") ; + X.xml_nempty "InductiveDefinition" + [None,"noParams",string_of_int nparams ; + None,"id",id ; + None,"params",params'] + [< xml_attrs; + (List.fold_left + (fun i (id,typename,finite,arity,cons) -> + [< i ; + X.xml_nempty "InductiveType" + [None,"id",id ; None,"name",typename ; + None,"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" + [None,"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 + ~ask_dtd_to_the_getter += + let module C2A = Cic2acic in + let module X = Xml in + let dtdname = dtdname ~ask_dtd_to_the_getter "cictypes.dtd" in + [< X.xml_cdata "\n" ; + X.xml_cdata + ("\n") ; + X.xml_nempty "InnerTypes" [None,"of",UriManager.string_of_uri curi] + (Hashtbl.fold + (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> + [< x ; + X.xml_nempty "TYPE" [None,"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 [<>] + ) + >] +;; diff --git a/helm/software/components/cic_acic/cic2Xml.mli b/helm/software/components/cic_acic/cic2Xml.mli new file mode 100644 index 000000000..22c5669df --- /dev/null +++ b/helm/software/components/cic_acic/cic2Xml.mli @@ -0,0 +1,46 @@ +(* 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 NotImplemented + +val print_term : + ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t -> + Cic.annterm -> + Xml.token Stream.t + +val print_object : + UriManager.uri -> + ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.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, Cic2acic.sort_kind) Hashtbl.t -> + ids_to_inner_types: (string, Cic2acic.anntypes) Hashtbl.t -> + ask_dtd_to_the_getter:bool -> + Xml.token Stream.t + diff --git a/helm/software/components/cic_acic/cic2acic.ml b/helm/software/components/cic_acic/cic2acic.ml new file mode 100644 index 000000000..8540e0e64 --- /dev/null +++ b/helm/software/components/cic_acic/cic2acic.ml @@ -0,0 +1,739 @@ +(* 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/. + *) + +(* $Id$ *) + +type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ] + +let string_of_sort = function + | `Prop -> "Prop" + | `Set -> "Set" + | `Type u -> "Type:" ^ string_of_int (CicUniv.univno u) + | `CProp -> "CProp" + +let sort_of_sort = function + | Cic.Prop -> `Prop + | Cic.Set -> `Set + | Cic.Type u -> `Type u + | Cic.CProp -> `CProp + +(* let hashtbl_add_time = ref 0.0;; *) + +let xxx_add h k v = +(* let t1 = Sys.time () in *) + Hashtbl.add h k v ; +(* let t2 = Sys.time () in + hashtbl_add_time := !hashtbl_add_time +. t2 -. t1 *) +;; + +(* let number_new_type_of_aux' = ref 0;; +let type_of_aux'_add_time = ref 0.0;; *) + +let xxx_type_of_aux' m c t = +(* let t1 = Sys.time () in *) + let res,_ = + try + CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph + with + | CicTypeChecker.AssertFailure _ + | CicTypeChecker.TypeCheckerFailure _ -> + Cic.Sort Cic.Prop, CicUniv.empty_ugraph + in +(* let t2 = Sys.time () in + type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ; *) + res +;; + +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 = gen_id seed in + xxx_add ids_to_father_ids res father ; + xxx_add ids_to_terms res t ; + res +;; + +let source_id_of_id id = "#source#" ^ id;; + +exception NotEnoughElements;; + +(*CSC: cut&paste da cicPp.ml *) +(* get_nth l n returns the nth element of the list l if it exists or *) +(* raises NotEnoughElements if l has less than n elements *) +let rec get_nth l n = + match (n,l) with + (1, he::_) -> he + | (n, he::tail) when n > 1 -> get_nth tail (n-1) + | (_,_) -> raise NotEnoughElements +;; + +let acic_of_cic_context' ~computeinnertypes:global_computeinnertypes + seed ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types + metasenv context idrefs t expectedty += + let module D = DoubleTypeInference in + let module C = Cic in + let fresh_id' = fresh_id seed ids_to_terms ids_to_father_ids in +(* let time1 = Sys.time () in *) + let terms_to_types = +(* + let time0 = Sys.time () in + let prova = CicTypeChecker.type_of_aux' metasenv context t in + let time1 = Sys.time () in + prerr_endline ("*** Fine type_inference:" ^ (string_of_float (time1 -. time0))); + let res = D.double_type_of metasenv context t expectedty in + let time2 = Sys.time () in + prerr_endline ("*** Fine double_type_inference:" ^ (string_of_float (time2 -. time1))); + res +*) + if global_computeinnertypes then + D.double_type_of metasenv context t expectedty + else + Cic.CicHash.create 1 (* empty table *) + in +(* + let time2 = Sys.time () in + prerr_endline + ("++++++++++++ Tempi della double_type_of: "^ string_of_float (time2 -. time1)) ; +*) + 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 + (* First of all we compute the inner type and the inner sort *) + (* of the term. They may be useful in what follows. *) + (*CSC: This is a very inefficient way of computing inner types *) + (*CSC: and inner sorts: very deep terms have their types/sorts *) + (*CSC: computed again and again. *) + let sort_of t = + match CicReduction.whd context t with + C.Sort C.Prop -> `Prop + | C.Sort C.Set -> `Set + | C.Sort (C.Type u) -> `Type u + | C.Meta _ -> `Type (CicUniv.fresh()) + | C.Sort C.CProp -> `CProp + | t -> + prerr_endline ("Cic2acic.sort_of applied to: " ^ CicPp.ppterm t) ; + assert false + in + let ainnertypes,innertype,innersort,expected_available = +(*CSC: Here we need the algorithm for Coscoy's double type-inference *) +(*CSC: (expected type + inferred type). Just for now we use the usual *) +(*CSC: type-inference, but the result is very poor. As a very weak *) +(*CSC: patch, I apply whd to the computed type. Full beta *) +(*CSC: reduction would be a much better option. *) +(*CSC: solo per testare i tempi *) +(*XXXXXXX *) + try +(* *) + let {D.synthesized = synthesized; D.expected = expected} = + if computeinnertypes then + Cic.CicHash.find terms_to_types tt + else + (* We are already in an inner-type and Coscoy's double *) + (* type inference algorithm has not been applied. *) + { D.synthesized = +(***CSC: patch per provare i tempi + CicReduction.whd context (xxx_type_of_aux' metasenv context tt) ; *) + if global_computeinnertypes then + Cic.Sort (Cic.Type (CicUniv.fresh())) + else + CicReduction.whd context (xxx_type_of_aux' metasenv context tt); + D.expected = None} + in +(* incr number_new_type_of_aux' ; *) + let innersort = (*XXXXX *) xxx_type_of_aux' metasenv context synthesized (* Cic.Sort Cic.Prop *) in + let ainnertypes,expected_available = + if computeinnertypes then + let annexpected,expected_available = + match expected with + None -> None,false + | Some expectedty' -> + Some + (aux false (Some fresh_id'') context idrefs expectedty'), + true + in + Some + {annsynthesized = + aux false (Some fresh_id'') context idrefs synthesized ; + annexpected = annexpected + }, expected_available + else + None,false + in + ainnertypes,synthesized, sort_of innersort, expected_available +(*XXXXXXXX *) + with + Not_found -> (* l'inner-type non e' nella tabella ==> sort <> Prop *) + (* CSC: Type or Set? I can not tell *) + let u = CicUniv.fresh() in + None,Cic.Sort (Cic.Type u),`Type u,false + (* TASSI non dovrebbe fare danni *) +(* *) + in + let add_inner_type id = + match ainnertypes with + None -> () + | Some ainnertypes -> xxx_add ids_to_inner_types id ainnertypes + in + match tt with + C.Rel n -> + let id = + match get_nth context n with + (Some (C.Name s,_)) -> s + | _ -> "__" ^ string_of_int n + in + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop && expected_available then + add_inner_type fresh_id'' ; + C.ARel (fresh_id'', List.nth idrefs (n-1), n, id) + | C.Var (uri,exp_named_subst) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop && expected_available then + add_inner_type fresh_id'' ; + 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,_) = CicUtil.lookup_meta n metasenv in + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop && expected_available then + add_inner_type fresh_id'' ; + C.AMeta (fresh_id'', n, + (List.map2 + (fun ct t -> + match (ct, t) with + | None, _ -> None + | _, 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) + | C.Implicit annotation -> C.AImplicit (fresh_id'', annotation) + | C.Cast (v,t) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop then + add_inner_type fresh_id'' ; + C.ACast (fresh_id'', aux' context idrefs v, aux' context idrefs t) + | C.Prod (n,s,t) -> + xxx_add ids_to_inner_sorts fresh_id'' + (sort_of innertype) ; + let sourcetype = xxx_type_of_aux' metasenv context s in + xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'') + (sort_of sourcetype) ; + let n' = + match n with + C.Anonymous -> n + | C.Name n' -> + if DoubleTypeInference.does_not_occur 1 t then + C.Anonymous + else + C.Name n' + in + 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) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + let sourcetype = xxx_type_of_aux' metasenv context s in + xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'') + (sort_of 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) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop then + add_inner_type fresh_id'' ; + C.ALetIn + (fresh_id'', n, aux' context idrefs s, + aux' ((Some (n, C.Def(s,None)))::context) (fresh_id''::idrefs) t) + | C.Appl l -> + xxx_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 idrefs) l) + | C.Const (uri,exp_named_subst) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop && expected_available then + add_inner_type fresh_id'' ; + 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) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop && expected_available then + add_inner_type fresh_id'' ; + 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) -> + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop then + add_inner_type fresh_id'' ; + 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 + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop then + add_inner_type fresh_id'' ; + C.AFix (fresh_id'', funno, + 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 + xxx_add ids_to_inner_sorts fresh_id'' innersort ; + if innersort = `Prop then + add_inner_type fresh_id'' ; + C.ACoFix (fresh_id'', funno, + List.map2 + (fun id (name, ty, bo) -> + (id, name, aux' context idrefs ty, + aux' (tys@context) new_idrefs bo) + ) fresh_idrefs funs + ) + in +(* + let timea = Sys.time () in + let res = aux true None context idrefs t in + let timeb = Sys.time () in + prerr_endline + ("+++++++++++++ Tempi della aux dentro alla acic_of_cic: "^ string_of_float (timeb -. timea)) ; + res +*) + aux global_computeinnertypes None context idrefs t +;; + +let acic_of_cic_context ~computeinnertypes 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' ~computeinnertypes seed ids_to_terms ids_to_father_ids ids_to_inner_sorts + ids_to_inner_types metasenv context idrefs t, + ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types +;; + +let aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids + ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed + metasenv (metano,context,goal) += + let computeinnertypes = false in + let acic_of_cic_context = + acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts + ids_to_inner_types metasenv in + let _, acontext,final_idrefs = + (List.fold_right + (fun binding (context, acontext,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,_)) -> + let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in + Hashtbl.replace ids_to_father_ids (CicUtil.id_of_annterm acic) + (Some hid); + (binding::context), + ((hid,Some (n,Cic.ADef acic))::acontext),(hid::idrefs) + | Some (n,Cic.Decl t) -> + let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in + Hashtbl.replace ids_to_father_ids (CicUtil.id_of_annterm acic) + (Some hid); + (binding::context), + ((hid,Some (n,Cic.ADecl acic))::acontext),(hid::idrefs) + | None -> + (* Invariant: "" is never looked up *) + (None::context),((hid,None)::acontext),""::idrefs + ) context ([],[],[]) + ) + in + let agoal = acic_of_cic_context ~computeinnertypes context final_idrefs goal None in + (metano,acontext,agoal) +;; + +let asequent_of_sequent (metasenv:Cic.metasenv) (sequent:Cic.conjecture) = + 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 ids_to_hypotheses = Hashtbl.create 23 in + let hypotheses_seed = ref 0 in + let seed = ref 1 in (* 'i0' is used for the whole sequent *) + let unsh_sequent = + let i,canonical_context,term = sequent in + let canonical_context' = + List.fold_right + (fun d canonical_context' -> + let d = + match d with + None -> None + | Some (n, Cic.Decl t)-> + Some (n, Cic.Decl (Unshare.unshare t)) + | Some (n, Cic.Def (t,None)) -> + Some (n, Cic.Def ((Unshare.unshare t),None)) + | Some (n,Cic.Def (bo,Some ty)) -> + Some (n, Cic.Def (Unshare.unshare bo,Some (Unshare.unshare ty))) + in + d::canonical_context' + ) canonical_context [] + in + let term' = Unshare.unshare term in + (i,canonical_context',term') + in + let (metano,acontext,agoal) = + aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids + ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed + metasenv unsh_sequent in + (unsh_sequent, + (("i0",metano,acontext,agoal), + ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses)) +;; + +let acic_object_of_cic_object ?(eta_fix=true) obj = + let module C = Cic in + let module E = Eta_fixing in + 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 ids_to_conjectures = Hashtbl.create 11 in + let ids_to_hypotheses = Hashtbl.create 127 in + let hypotheses_seed = ref 0 in + let conjectures_seed = ref 0 in + let seed = ref 0 in + 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 aconjecture_of_conjecture' = aconjecture_of_conjecture seed + ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types + ids_to_hypotheses hypotheses_seed in + let eta_fix metasenv context t = + let t = if eta_fix then E.eta_fix metasenv context t else t in + Unshare.unshare t in + let aobj = + match obj with + C.Constant (id,Some bo,ty,params,attrs) -> + let bo' = eta_fix [] [] bo in + let ty' = eta_fix [] [] ty in + let abo = acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty') in + let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in + C.AConstant + ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs) + | C.Constant (id,None,ty,params,attrs) -> + let ty' = eta_fix [] [] ty in + let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in + C.AConstant + ("mettereaposto",None,id,None,aty,params,attrs) + | C.Variable (id,bo,ty,params,attrs) -> + let ty' = eta_fix [] [] ty in + let abo = + match bo with + None -> None + | Some bo -> + let bo' = eta_fix [] [] bo in + Some (acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty')) + in + let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in + C.AVariable + ("mettereaposto",id,abo,aty,params,attrs) + | C.CurrentProof (id,conjectures,bo,ty,params,attrs) -> + let conjectures' = + List.map + (function (i,canonical_context,term) -> + let canonical_context' = + List.fold_right + (fun d canonical_context' -> + let d = + match d with + None -> None + | Some (n, C.Decl t)-> + Some (n, C.Decl (eta_fix conjectures canonical_context' t)) + | Some (n, C.Def (t,None)) -> + Some (n, + C.Def ((eta_fix conjectures canonical_context' t),None)) + | Some (_,C.Def (_,Some _)) -> assert false + in + d::canonical_context' + ) canonical_context [] + in + let term' = eta_fix conjectures canonical_context' term in + (i,canonical_context',term') + ) conjectures + in + let aconjectures = + List.map + (function (i,canonical_context,term) as conjecture -> + let cid = "c" ^ string_of_int !conjectures_seed in + xxx_add ids_to_conjectures cid conjecture ; + incr conjectures_seed ; + let (i,acanonical_context,aterm) + = aconjecture_of_conjecture' conjectures conjecture in + (cid,i,acanonical_context,aterm)) + conjectures' in +(* let time1 = Sys.time () in *) + let bo' = eta_fix conjectures' [] bo in + let ty' = eta_fix conjectures' [] ty in +(* + let time2 = Sys.time () in + prerr_endline + ("++++++++++ Tempi della eta_fix: "^ string_of_float (time2 -. time1)) ; + hashtbl_add_time := 0.0 ; + type_of_aux'_add_time := 0.0 ; + DoubleTypeInference.syntactic_equality_add_time := 0.0 ; +*) + let abo = + acic_term_of_cic_term_context' ~computeinnertypes:true conjectures' [] [] bo' (Some ty') in + let aty = acic_term_of_cic_term_context' ~computeinnertypes:false conjectures' [] [] ty' None in +(* + let time3 = Sys.time () in + prerr_endline + ("++++++++++++ Tempi della hashtbl_add_time: " ^ string_of_float !hashtbl_add_time) ; + prerr_endline + ("++++++++++++ Tempi della type_of_aux'_add_time(" ^ string_of_int !number_new_type_of_aux' ^ "): " ^ string_of_float !type_of_aux'_add_time) ; + prerr_endline + ("++++++++++++ Tempi della type_of_aux'_add_time nella double_type_inference(" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_double_work ^ ";" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_prop ^ "/" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux' ^ "): " ^ string_of_float !DoubleTypeInference.type_of_aux'_add_time) ; + prerr_endline + ("++++++++++++ Tempi della syntactic_equality_add_time: " ^ string_of_float !DoubleTypeInference.syntactic_equality_add_time) ; + prerr_endline + ("++++++++++ Tempi della acic_of_cic: " ^ string_of_float (time3 -. time2)) ; + prerr_endline + ("++++++++++ Numero di iterazioni della acic_of_cic: " ^ string_of_int !seed) ; +*) + C.ACurrentProof + ("mettereaposto","mettereaposto2",id,aconjectures,abo,aty,params,attrs) + | C.InductiveDefinition (tys,params,paramsno,attrs) -> + let tys = + List.map + (fun (name,i,arity,cl) -> + (name,i,Unshare.unshare arity, + List.map (fun (name,ty) -> name,Unshare.unshare ty) cl)) tys in + let context = + List.map + (fun (name,_,arity,_) -> + Some (C.Name name, C.Decl (Unshare.unshare 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' ~computeinnertypes:false [] context idrefs ty None) + ) cons + in + (id,name,inductive, + acic_term_of_cic_term' ~computeinnertypes:false ty None,acons) + ) (List.rev idrefs) tys + in + C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs) + in + aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types, + ids_to_conjectures,ids_to_hypotheses +;; + +let plain_acic_term_of_cic_term = + let module C = Cic in + let mk_fresh_id = + let id = ref 0 in + function () -> incr id; "i" ^ string_of_int !id in + let rec aux context t = + let fresh_id = mk_fresh_id () in + match t with + C.Rel n -> + let idref,id = + match get_nth context n with + idref,(Some (C.Name s,_)) -> idref,s + | idref,_ -> idref,"__" ^ string_of_int n + in + C.ARel (fresh_id, idref, n, id) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map + (function i,t -> i, (aux context t)) exp_named_subst + in + C.AVar (fresh_id,uri,exp_named_subst') + | C.Implicit _ + | C.Meta _ -> assert false + | C.Sort s -> C.ASort (fresh_id, s) + | C.Cast (v,t) -> + C.ACast (fresh_id, aux context v, aux context t) + | C.Prod (n,s,t) -> + C.AProd + (fresh_id, n, aux context s, + aux ((fresh_id, Some (n, C.Decl s))::context) t) + | C.Lambda (n,s,t) -> + C.ALambda + (fresh_id,n, aux context s, + aux ((fresh_id, Some (n, C.Decl s))::context) t) + | C.LetIn (n,s,t) -> + C.ALetIn + (fresh_id, n, aux context s, + aux ((fresh_id, Some (n, C.Def(s,None)))::context) t) + | C.Appl l -> + C.AAppl (fresh_id, List.map (aux context) l) + | C.Const (uri,exp_named_subst) -> + let exp_named_subst' = + List.map + (function i,t -> i, (aux context 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 t)) exp_named_subst + in + C.AMutInd (fresh_id, uri, tyno, exp_named_subst') + | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> + let exp_named_subst' = + List.map + (function i,t -> i, (aux context t)) exp_named_subst + in + C.AMutConstruct (fresh_id, uri, tyno, consno, exp_named_subst') + | C.MutCase (uri, tyno, outty, term, patterns) -> + C.AMutCase (fresh_id, uri, tyno, aux context outty, + aux context term, List.map (aux context) patterns) + | C.Fix (funno, funs) -> + let tys = + List.map + (fun (name,_,ty,_) -> mk_fresh_id (), Some (C.Name name, C.Decl ty)) funs + in + C.AFix (fresh_id, funno, + List.map2 + (fun (id,_) (name, indidx, ty, bo) -> + (id, name, indidx, aux context ty, aux (tys@context) bo) + ) tys funs + ) + | C.CoFix (funno, funs) -> + let tys = + List.map (fun (name,ty,_) -> + mk_fresh_id (),Some (C.Name name, C.Decl ty)) funs + in + C.ACoFix (fresh_id, funno, + List.map2 + (fun (id,_) (name, ty, bo) -> + (id, name, aux context ty, aux (tys@context) bo) + ) tys funs + ) + in + aux +;; + +let plain_acic_object_of_cic_object obj = + let module C = Cic in + let mk_fresh_id = + let id = ref 0 in + function () -> incr id; "it" ^ string_of_int !id + in + match obj with + C.Constant (id,Some bo,ty,params,attrs) -> + let abo = plain_acic_term_of_cic_term [] bo in + let aty = plain_acic_term_of_cic_term [] ty in + C.AConstant + ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs) + | C.Constant (id,None,ty,params,attrs) -> + let aty = plain_acic_term_of_cic_term [] ty in + C.AConstant + ("mettereaposto",None,id,None,aty,params,attrs) + | C.Variable (id,bo,ty,params,attrs) -> + let abo = + match bo with + None -> None + | Some bo -> Some (plain_acic_term_of_cic_term [] bo) + in + let aty = plain_acic_term_of_cic_term [] ty in + C.AVariable + ("mettereaposto",id,abo,aty,params,attrs) + | C.CurrentProof _ -> assert false + | C.InductiveDefinition (tys,params,paramsno,attrs) -> + let context = + List.map + (fun (name,_,arity,_) -> + mk_fresh_id (), Some (C.Name name, C.Decl arity)) tys in + let atys = + List.map2 + (fun (id,_) (name,inductive,ty,cons) -> + let acons = + List.map + (function (name,ty) -> + (name, + plain_acic_term_of_cic_term context ty) + ) cons + in + (id,name,inductive,plain_acic_term_of_cic_term [] ty,acons) + ) context tys + in + C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs) +;; diff --git a/helm/software/components/cic_acic/cic2acic.mli b/helm/software/components/cic_acic/cic2acic.mli new file mode 100644 index 000000000..e6379283d --- /dev/null +++ b/helm/software/components/cic_acic/cic2acic.mli @@ -0,0 +1,61 @@ +(* 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 NotEnoughElements + +val source_id_of_id : string -> string + +type anntypes = + {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option} +;; + +type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp ] + +val string_of_sort: sort_kind -> string +(*val sort_of_string: string -> sort_kind*) +val sort_of_sort: Cic.sort -> sort_kind + +val acic_object_of_cic_object : + ?eta_fix: bool -> (* perform eta_fixing; default: true*) + Cic.obj -> (* object *) + Cic.annobj * (* annotated object *) + (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *) + (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *) + (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) + (Cic.id, anntypes) Hashtbl.t * (* ids_to_inner_types *) + (Cic.id, Cic.conjecture) Hashtbl.t * (* ids_to_conjectures *) + (Cic.id, Cic.hypothesis) Hashtbl.t (* ids_to_hypotheses *) + +val asequent_of_sequent : + Cic.metasenv -> (* metasenv *) + Cic.conjecture -> (* sequent *) + Cic.conjecture * (* unshared sequent *) + (Cic.annconjecture * (* annotated sequent *) + (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *) + (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *) + (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) + (Cic.id, Cic.hypothesis) Hashtbl.t) (* ids_to_hypotheses *) + +val plain_acic_object_of_cic_object : Cic.obj -> Cic.annobj diff --git a/helm/software/components/cic_acic/doubleTypeInference.ml b/helm/software/components/cic_acic/doubleTypeInference.ml new file mode 100644 index 000000000..30a8f5c29 --- /dev/null +++ b/helm/software/components/cic_acic/doubleTypeInference.ml @@ -0,0 +1,734 @@ +(* 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/. + *) + +(* $Id$ *) + +exception Impossible of int;; +exception NotWellTyped of string;; +exception WrongUriToConstant of string;; +exception WrongUriToVariable of string;; +exception WrongUriToMutualInductiveDefinitions of string;; +exception ListTooShort;; +exception RelToHiddenHypothesis;; + +let syntactic_equality_add_time = ref 0.0;; +let type_of_aux'_add_time = ref 0.0;; +let number_new_type_of_aux'_double_work = ref 0;; +let number_new_type_of_aux' = ref 0;; +let number_new_type_of_aux'_prop = ref 0;; + +let double_work = ref 0;; + +let xxx_type_of_aux' m c t = + let t1 = Sys.time () in + let res,_ = CicTypeChecker.type_of_aux' m c t CicUniv.empty_ugraph in + let t2 = Sys.time () in + type_of_aux'_add_time := !type_of_aux'_add_time +. t2 -. t1 ; + res +;; + +type types = {synthesized : Cic.term ; expected : Cic.term option};; + +(* does_not_occur n te *) +(* returns [true] if [Rel n] does not occur in [te] *) +let rec does_not_occur n = + let module C = Cic in + function + C.Rel m when m = n -> false + | C.Rel _ + | C.Meta _ + | C.Sort _ + | C.Implicit _ -> true + | C.Cast (te,ty) -> + does_not_occur n te && does_not_occur n ty + | C.Prod (name,so,dest) -> + does_not_occur n so && + does_not_occur (n + 1) dest + | C.Lambda (name,so,dest) -> + does_not_occur n so && + does_not_occur (n + 1) dest + | C.LetIn (name,so,dest) -> + does_not_occur n so && + does_not_occur (n + 1) dest + | C.Appl l -> + List.fold_right (fun x i -> i && does_not_occur n x) l true + | 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 n x) + exp_named_subst true + | C.MutCase (_,_,out,te,pl) -> + does_not_occur n out && does_not_occur n te && + List.fold_right (fun x i -> i && does_not_occur n x) pl true + | C.Fix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len in + List.fold_right + (fun (_,_,ty,bo) i -> + i && does_not_occur n ty && + does_not_occur n_plus_len bo + ) fl true + | C.CoFix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len in + List.fold_right + (fun (_,ty,bo) i -> + i && does_not_occur n ty && + does_not_occur n_plus_len bo + ) fl true +;; + +let rec beta_reduce = + let module S = CicSubstitution in + let module C = Cic in + function + C.Rel _ as t -> t + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (function (i,t) -> i, beta_reduce t) exp_named_subst + in + C.Var (uri,exp_named_subst') + | C.Meta (n,l) -> + C.Meta (n, + List.map + (function None -> None | Some t -> Some (beta_reduce t)) l + ) + | C.Sort _ as t -> t + | C.Implicit _ -> assert false + | C.Cast (te,ty) -> + C.Cast (beta_reduce te, beta_reduce ty) + | C.Prod (n,s,t) -> + C.Prod (n, beta_reduce s, beta_reduce t) + | C.Lambda (n,s,t) -> + C.Lambda (n, beta_reduce s, beta_reduce t) + | C.LetIn (n,s,t) -> + C.LetIn (n, beta_reduce s, beta_reduce t) + | C.Appl ((C.Lambda (name,s,t))::he::tl) -> + let he' = S.subst he t in + if tl = [] then + beta_reduce he' + else + (match he' with + C.Appl l -> beta_reduce (C.Appl (l@tl)) + | _ -> beta_reduce (C.Appl (he'::tl))) + | C.Appl l -> + C.Appl (List.map beta_reduce l) + | C.Const (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (function (i,t) -> i, 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, 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, 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,beta_reduce outt,beta_reduce t, + List.map beta_reduce pl) + | C.Fix (i,fl) -> + let fl' = + List.map + (function (name,i,ty,bo) -> + name,i,beta_reduce ty,beta_reduce bo + ) fl + in + C.Fix (i,fl') + | C.CoFix (i,fl) -> + let fl' = + List.map + (function (name,ty,bo) -> + name,beta_reduce ty,beta_reduce bo + ) fl + in + C.CoFix (i,fl') +;; + +(* syntactic_equality up to the *) +(* distinction between fake dependent products *) +(* and non-dependent products, alfa-conversion *) +(*CSC: must alfa-conversion be considered or not? *) +let syntactic_equality t t' = + let module C = Cic in + let rec syntactic_equality t t' = + if t = t' then true + else + match t, t' with + 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' + | C.Prod (_,s,t), C.Prod (_,s',t') -> + syntactic_equality s s' && + syntactic_equality t t' + | C.Lambda (_,s,t), C.Lambda (_,s',t') -> + syntactic_equality s s' && + syntactic_equality t t' + | C.LetIn (_,s,t), C.LetIn(_,s',t') -> + syntactic_equality s s' && + 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,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' && + List.fold_left2 + (fun b t1 t2 -> b && syntactic_equality t1 t2) true pl pl' + | C.Fix (i,fl), C.Fix (i',fl') -> + i = i' && + List.fold_left2 + (fun b (_,i,ty,bo) (_,i',ty',bo') -> + b && i = i' && + syntactic_equality ty ty' && + syntactic_equality bo bo') true fl fl' + | C.CoFix (i,fl), C.CoFix (i',fl') -> + i = i' && + List.fold_left2 + (fun b (_,ty,bo) (_,ty',bo') -> + b && + syntactic_equality ty ty' && + syntactic_equality bo bo') true fl fl' + | _, _ -> 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' + with + _ -> false +;; + +let xxx_syntactic_equality t t' = + let t1 = Sys.time () in + let res = syntactic_equality t t' in + let t2 = Sys.time () in + syntactic_equality_add_time := !syntactic_equality_add_time +. t2 -. t1 ; + res +;; + + +let rec split l n = + match (l,n) with + (l,0) -> ([], l) + | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) + | (_,_) -> raise ListTooShort +;; + +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 CicUniv.empty_ugraph uri with + CicEnvironment.CheckedObj (cobj,_) -> cobj + | CicEnvironment.UncheckedObj uobj -> + raise (NotWellTyped "Reference to an unchecked constant") + in + match cobj with + C.Constant (_,_,ty,_,_) -> ty + | C.CurrentProof (_,_,_,ty,_,_) -> ty + | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) +;; + +let type_of_variable uri = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + match CicEnvironment.is_type_checked CicUniv.empty_ugraph 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 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 CicUniv.empty_ugraph uri with + CicEnvironment.CheckedObj (cobj,_) -> cobj + | CicEnvironment.UncheckedObj uobj -> + raise (NotWellTyped "Reference to an unchecked inductive type") + in + match cobj with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,arity,_) = List.nth dl i in + arity + | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) +;; + +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 CicUniv.empty_ugraph uri with + CicEnvironment.CheckedObj (cobj,_) -> cobj + | CicEnvironment.UncheckedObj uobj -> + raise (NotWellTyped "Reference to an unchecked constructor") + in + match cobj 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 *) +let rec type_of_aux' subterms_to_types metasenv context t expectedty = + (* Coscoy's double type-inference algorithm *) + (* It computes the inner-types of every subterm of [t], *) + (* even when they are not needed to compute the types *) + (* of other terms. *) + let rec type_of_aux context t expectedty = + let module C = Cic in + let module R = CicReduction in + let module S = CicSubstitution in + let module U = UriManager in + let synthesized = + match t with + C.Rel n -> + (try + match List.nth context (n - 1) with + Some (_,C.Decl t) -> S.lift n t + | Some (_,C.Def (_,Some ty)) -> S.lift n ty + | Some (_,C.Def (bo,None)) -> + type_of_aux context (S.lift n bo) expectedty + | None -> raise RelToHiddenHypothesis + with + _ -> raise (NotWellTyped "Not a close term") + ) + | 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,_) = CicUtil.lookup_meta n metasenv in + let lifted_canonical_context = + let rec aux i = + function + [] -> [] + | (Some (n,C.Decl t))::tl -> + (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl) + | (Some (n,C.Def (t,None)))::tl -> + (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None))):: + (aux (i+1) tl) + | None::tl -> None::(aux (i+1) tl) + | (Some (_,C.Def (_,Some _)))::_ -> assert false + in + aux 1 canonical_context + in + let _ = + List.iter2 + (fun t ct -> + match t,ct with + _,None -> () + | Some t,Some (_,C.Def (ct,_)) -> + let expected_type = + R.whd context + (xxx_type_of_aux' metasenv context ct) + in + (* Maybe I am a bit too paranoid, because *) + (* if the term is well-typed than t and ct *) + (* are convertible. Nevertheless, I compute *) + (* the expected type. *) + ignore (type_of_aux context t (Some expected_type)) + | Some t,Some (_,C.Decl ct) -> + ignore (type_of_aux context t (Some ct)) + | _,_ -> assert false (* the term is not well typed!!! *) + ) l lifted_canonical_context + in + let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in + (* Checks suppressed *) + CicSubstitution.subst_meta l ty + | C.Sort (C.Type t) -> (* TASSI: CONSTRAINT *) + C.Sort (C.Type (CicUniv.fresh())) + | C.Sort _ -> C.Sort (C.Type (CicUniv.fresh())) (* TASSI: CONSTRAINT *) + | C.Implicit _ -> raise (Impossible 21) + | C.Cast (te,ty) -> + (* Let's visit all the subterms that will not be visited later *) + let _ = type_of_aux context te (Some (beta_reduce ty)) in + let _ = type_of_aux context ty None in + (* Checks suppressed *) + ty + | C.Prod (name,s,t) -> + let sort1 = type_of_aux context s None + and sort2 = type_of_aux ((Some (name,(C.Decl s)))::context) t None in + sort_of_prod context (name,s) (sort1,sort2) + | C.Lambda (n,s,t) -> + (* Let's visit all the subterms that will not be visited later *) + let _ = type_of_aux context s None in + let expected_target_type = + match expectedty with + None -> None + | Some expectedty' -> + let ty = + match R.whd context expectedty' with + C.Prod (_,_,expected_target_type) -> + beta_reduce expected_target_type + | _ -> assert false + in + Some ty + in + let type2 = + type_of_aux ((Some (n,(C.Decl s)))::context) t expected_target_type + in + (* Checks suppressed *) + C.Prod (n,s,type2) + | C.LetIn (n,s,t) -> +(*CSC: What are the right expected types for the source and *) +(*CSC: target of a LetIn? None used. *) + (* Let's visit all the subterms that will not be visited later *) + let ty = type_of_aux context s None in + let t_typ = + (* Checks suppressed *) + type_of_aux ((Some (n,(C.Def (s,Some ty))))::context) t None + in (* CicSubstitution.subst s t_typ *) + if does_not_occur 1 t_typ then + (* since [Rel 1] does not occur in typ, substituting any term *) + (* in place of [Rel 1] is equivalent to delifting once *) + CicSubstitution.subst (C.Implicit None) t_typ + else + C.LetIn (n,s,t_typ) + | C.Appl (he::tl) when List.length tl > 0 -> + (* + let expected_hetype = + (* Inefficient, the head is computed twice. But I know *) + (* of no other solution. *) + (beta_reduce + (R.whd context (xxx_type_of_aux' metasenv context he))) + in + let hetype = type_of_aux context he (Some expected_hetype) in + let tlbody_and_type = + let rec aux = + function + _,[] -> [] + | C.Prod (n,s,t),he::tl -> + (he, type_of_aux context he (Some (beta_reduce s))):: + (aux (R.whd context (S.subst he t), tl)) + | _ -> assert false + in + aux (expected_hetype, tl) *) + let hetype = R.whd context (type_of_aux context he None) in + let tlbody_and_type = + let rec aux = + function + _,[] -> [] + | C.Prod (n,s,t),he::tl -> + (he, type_of_aux context he (Some (beta_reduce s))):: + (aux (R.whd context (S.subst he t), tl)) + | _ -> assert false + in + aux (hetype, tl) + in + eat_prods context hetype tlbody_and_type + | C.Appl _ -> raise (NotWellTyped "Appl: no arguments") + | 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 = + match CicReduction.whd context t with + C.Sort _ -> (true, 0) + | C.Prod (name, s, t) -> + let (b, n) = guess_args ((Some (name,(C.Decl s)))::context) t in + if n = 0 then + (* last prod before sort *) + match CicReduction.whd context s with + C.MutInd (uri',i',_) when U.eq uri' uri && i' = i -> + (false, 1) + | 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") + in + let (b, k) = guess_args context outsort in + if not b then (b, k - 1) else (b, k) + in + let (parameters, arguments,exp_named_subst) = + let type_of_term = + xxx_type_of_aux' metasenv context term + in + match + R.whd context (type_of_aux context term + (Some (beta_reduce type_of_term))) + with + (*CSC manca il caso dei CAST *) + C.MutInd (uri',i',exp_named_subst) -> + (* Checks suppressed *) + [],[],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) = + let obj,_ = + try + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + with Not_found -> assert false + in + match obj with + C.InductiveDefinition (tl,_,parsno,_) -> + let (_,_,_,cl) = List.nth tl i in (cl,parsno) + | _ -> + raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) + in + let _ = + List.fold_left + (fun j (p,(_,c)) -> + let cons = + if parameters = [] then + (C.MutConstruct (uri,i,j,exp_named_subst)) + else + (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters)) + in + let expectedtype = + type_of_branch context parsno need_dummy outtype cons + (xxx_type_of_aux' metasenv context cons) + in + ignore (type_of_aux context p + (Some (beta_reduce expectedtype))) ; + j+1 + ) 1 (List.combine pl cl) + in + if not need_dummy then + C.Appl ((outtype::arguments)@[term]) + else if arguments = [] then + outtype + else + C.Appl (outtype::arguments) + | C.Fix (i,fl) -> + (* Let's visit all the subterms that will not be visited later *) + let context' = + List.rev + (List.map + (fun (n,_,ty,_) -> + let _ = type_of_aux context ty None in + (Some (C.Name n,(C.Decl ty))) + ) fl + ) @ + context + in + let _ = + List.iter + (fun (_,_,ty,bo) -> + let expectedty = + beta_reduce (CicSubstitution.lift (List.length fl) ty) + in + ignore (type_of_aux context' bo (Some expectedty)) + ) fl + in + (* Checks suppressed *) + let (_,_,ty,_) = List.nth fl i in + ty + | C.CoFix (i,fl) -> + (* Let's visit all the subterms that will not be visited later *) + let context' = + List.rev + (List.map + (fun (n,ty,_) -> + let _ = type_of_aux context ty None in + (Some (C.Name n,(C.Decl ty))) + ) fl + ) @ + context + in + let _ = + List.iter + (fun (_,ty,bo) -> + let expectedty = + beta_reduce (CicSubstitution.lift (List.length fl) ty) + in + ignore (type_of_aux context' bo (Some expectedty)) + ) fl + in + (* Checks suppressed *) + let (_,ty,_) = List.nth fl i in + ty + in + let synthesized' = beta_reduce synthesized in + let types,res = + match expectedty with + None -> + (* No expected type *) + {synthesized = synthesized' ; expected = None}, synthesized + | Some ty when xxx_syntactic_equality synthesized' ty -> + (* The expected type is synthactically equal to *) + (* the synthesized type. Let's forget it. *) + {synthesized = synthesized' ; expected = None}, synthesized + | Some expectedty' -> + {synthesized = synthesized' ; expected = Some expectedty'}, + expectedty' + in + assert (not (Cic.CicHash.mem subterms_to_types t)); + Cic.CicHash.add subterms_to_types t types ; + res + + and visit_exp_named_subst context uri exp_named_subst = + let uris_and_types = + let obj,_ = + try + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + with Not_found -> assert false + in + let params = CicUtil.params_of_obj obj in + List.map + (function uri -> + let obj,_ = + try + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + with Not_found -> assert false + in + match obj 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 + let t2' = CicReduction.whd ((Some (name,C.Decl s))::context) t2 in + match (t1', t2') with + (C.Sort _, C.Sort s2) + when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) -> + (* different from Coq manual!!! *) + C.Sort s2 + | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> + C.Sort (C.Type (CicUniv.fresh())) + | (C.Sort _,C.Sort (C.Type t1)) -> + (* TASSI: CONSRTAINTS: the same in cictypechecker,cicrefine *) + C.Sort (C.Type t1) (* c'e' bisogno di un fresh? *) + | (C.Meta _, C.Sort _) -> t2' + | (C.Meta _, (C.Meta (_,_) as t)) + | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t -> + t2' + | (_,_) -> + raise + (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 *) + (*CSC: cucinati *) + function + [] -> hetype + | (hete, hety)::tl -> + (match (CicReduction.whd context hetype) with + Cic.Prod (n,s,t) -> + (* Checks suppressed *) + eat_prods context (CicSubstitution.subst hete t) tl + | _ -> raise (NotWellTyped "Appl: wrong Prod-type") + ) + +and type_of_branch context argsno need_dummy outtype term constype = + let module C = Cic in + let module R = CicReduction in + match R.whd context constype with + C.MutInd (_,_,_) -> + if need_dummy then + outtype + else + C.Appl [outtype ; term] + | C.Appl (C.MutInd (_,_,_)::tl) -> + let (_,arguments) = split tl argsno + in + if need_dummy && arguments = [] then + outtype + else + C.Appl (outtype::arguments@(if need_dummy then [] else [term])) + | C.Prod (name,so,de) -> + let term' = + match CicSubstitution.lift 1 term with + C.Appl l -> C.Appl (l@[C.Rel 1]) + | t -> C.Appl [t ; C.Rel 1] + in + 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) + + in + type_of_aux context t expectedty +;; + +let double_type_of metasenv context t expectedty = + let subterms_to_types = Cic.CicHash.create 503 in + ignore (type_of_aux' subterms_to_types metasenv context t expectedty) ; + subterms_to_types +;; diff --git a/helm/software/components/cic_acic/doubleTypeInference.mli b/helm/software/components/cic_acic/doubleTypeInference.mli new file mode 100644 index 000000000..892e09f8a --- /dev/null +++ b/helm/software/components/cic_acic/doubleTypeInference.mli @@ -0,0 +1,25 @@ +exception Impossible of int +exception NotWellTyped of string +exception WrongUriToConstant of string +exception WrongUriToVariable of string +exception WrongUriToMutualInductiveDefinitions of string +exception ListTooShort +exception RelToHiddenHypothesis + +val syntactic_equality_add_time: float ref +val type_of_aux'_add_time: float ref +val number_new_type_of_aux'_double_work: int ref +val number_new_type_of_aux': int ref +val number_new_type_of_aux'_prop: int ref + +type types = {synthesized : Cic.term ; expected : Cic.term option};; + +val double_type_of : + Cic.metasenv -> Cic.context -> Cic.term -> Cic.term option -> + types Cic.CicHash.t + +(** Auxiliary functions **) + +(* does_not_occur n te *) +(* returns [true] if [Rel n] does not occur in [te] *) +val does_not_occur : int -> Cic.term -> bool diff --git a/helm/software/components/cic_acic/eta_fixing.ml b/helm/software/components/cic_acic/eta_fixing.ml new file mode 100644 index 000000000..22d26e1bd --- /dev/null +++ b/helm/software/components/cic_acic/eta_fixing.ml @@ -0,0 +1,313 @@ +(* 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/. + *) + +(* $Id$ *) + +exception ReferenceToNonVariable;; + +let prerr_endline _ = ();; + +(* +let rec fix_lambdas_wrt_type ty te = + let module C = Cic in + let module S = CicSubstitution in +(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) + match ty with + C.Prod (_,_,ty') -> + (match CicReduction.whd [] te with + C.Lambda (n,s,te') -> + C.Lambda (n,s,fix_lambdas_wrt_type ty' te') + | t -> + let rec get_sources = + function + C.Prod (_,s,ty) -> s::(get_sources ty) + | _ -> [] in + let sources = get_sources ty in + let no_sources = List.length sources in + let rec mk_rels n shift = + if n = 0 then [] + else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in + let t' = S.lift no_sources t in + let t2 = + match t' with + C.Appl l -> + C.LetIn + (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1))) + | _ -> + C.Appl (t'::(mk_rels no_sources 0)) in + List.fold_right + (fun source t -> C.Lambda (C.Name "y",source,t)) + sources t2) + | _ -> te +;; *) + +let rec fix_lambdas_wrt_type ty te = + let module C = Cic in + let module S = CicSubstitution in +(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) + match ty,te with + C.Prod (_,_,ty'), C.Lambda (n,s,te') -> + C.Lambda (n,s,fix_lambdas_wrt_type ty' te') + | C.Prod (_,s,ty'), t -> + let rec get_sources = + function + C.Prod (_,s,ty) -> s::(get_sources ty) + | _ -> [] in + let sources = get_sources ty in + let no_sources = List.length sources in + let rec mk_rels n shift = + if n = 0 then [] + else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in + let t' = S.lift no_sources t in + let t2 = + match t' with + C.Appl l -> + C.LetIn (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1))) + | _ -> C.Appl (t'::(mk_rels no_sources 0)) in + List.fold_right + (fun source t -> C.Lambda (C.Name "y",CicReduction.whd [] source,t)) sources t2 + | _, _ -> te +;; + +(* +let rec fix_lambdas_wrt_type ty te = + let module C = Cic in + let module S = CicSubstitution in +(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) + match ty,te with + C.Prod (_,_,ty'), C.Lambda (n,s,te') -> + C.Lambda (n,s,fix_lambdas_wrt_type ty' te') + | C.Prod (_,s,ty'), ((C.Appl (C.Const _ ::_)) as t) -> + (* const have a fixed arity *) + (* prerr_endline ("******** fl - eta expansion 0: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) + let t' = S.lift 1 t in + C.Lambda (C.Name "x",s, + C.LetIn + (C.Name "H", fix_lambdas_wrt_type ty' t', + C.Appl [C.Rel 1;C.Rel 2])) + | C.Prod (_,s,ty'), C.Appl l -> + (* prerr_endline ("******** fl - eta expansion 1: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) + let l' = List.map (S.lift 1) l in + C.Lambda (C.Name "x",s, + fix_lambdas_wrt_type ty' (C.Appl (l'@[C.Rel 1]))) + | C.Prod (_,s,ty'), _ -> + (* prerr_endline ("******** fl - eta expansion 2: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) + flush stderr ; + let te' = S.lift 1 te in + C.Lambda (C.Name "x",s, + fix_lambdas_wrt_type ty' (C.Appl [te';C.Rel 1])) + | _, _ -> te +;;*) + +let fix_according_to_type ty hd tl = + let module C = Cic in + let module S = CicSubstitution in + let rec count_prods = + function + C.Prod (_,_,t) -> 1 + (count_prods t) + | _ -> 0 in + let expected_arity = count_prods ty in + let rec aux n ty tl res = + if n = 0 then + (match tl with + [] -> + (match res with + [] -> assert false + | [res] -> res + | _ -> C.Appl res) + | _ -> + match res with + [] -> assert false + | [a] -> C.Appl (a::tl) + | _ -> + (* prerr_endline ("******* too many args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *) + C.LetIn + (C.Name "H", + C.Appl res, C.Appl (C.Rel 1::(List.map (S.lift 1) tl)))) + else + let name,source,target = + (match ty with + C.Prod (C.Name _ as n,s,t) -> n,s,t + | C.Prod (C.Anonymous, s,t) -> C.Name "z",s,t + | _ -> (* prods number may only increase for substitution *) + assert false) in + match tl with + [] -> + (* prerr_endline ("******* too few args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *) + let res' = List.map (S.lift 1) res in + C.Lambda + (name, source, aux (n-1) target [] (res'@[C.Rel 1])) + | hd::tl' -> + let hd' = fix_lambdas_wrt_type source hd in + (* (prerr_endline ("++++++prima :" ^(CicPp.ppterm hd)); + prerr_endline ("++++++dopo :" ^(CicPp.ppterm hd'))); *) + aux (n-1) (S.subst hd' target) tl' (res@[hd']) in + aux expected_arity ty tl [hd] +;; + +let eta_fix metasenv context t = + let rec eta_fix' context t = + (* prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t); + flush stderr ; *) + let module C = Cic in + let module S = CicSubstitution in + match t with + C.Rel n -> C.Rel n + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = fix_exp_named_subst context exp_named_subst in + C.Var (uri,exp_named_subst') + | C.Meta (n,l) -> + let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in + let l' = + List.map2 + (fun ct t -> + match (ct, t) with + None, _ -> None + | _, Some t -> Some (eta_fix' context t) + | Some _, None -> assert false (* due to typing rules *)) + canonical_context l + in + C.Meta (n,l') + | C.Sort s -> C.Sort s + | C.Implicit _ as t -> t + | C.Cast (v,t) -> C.Cast (eta_fix' context v, eta_fix' context t) + | C.Prod (n,s,t) -> + C.Prod + (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t) + | C.Lambda (n,s,t) -> + C.Lambda + (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t) + | C.LetIn (n,s,t) -> + C.LetIn + (n,eta_fix' context s,eta_fix' ((Some (n,(C.Def (s,None))))::context) t) + | C.Appl l -> + let l' = List.map (eta_fix' context) l + in + (match l' with + [] -> assert false + | he::tl -> + let ty,_ = + CicTypeChecker.type_of_aux' metasenv context he + CicUniv.empty_ugraph + in + fix_according_to_type ty he tl +(* + C.Const(uri,exp_named_subst)::l'' -> + let constant_type = + (match CicEnvironment.get_obj uri with + C.Constant (_,_,ty,_) -> ty + | C.Variable _ -> raise ReferenceToVariable + | C.CurrentProof (_,_,_,_,params) -> raise ReferenceToCurrentProof + | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + ) in + fix_according_to_type + constant_type (C.Const(uri,exp_named_subst)) l'' + | _ -> C.Appl l' *)) + | C.Const (uri,exp_named_subst) -> + let exp_named_subst' = fix_exp_named_subst context exp_named_subst in + C.Const (uri,exp_named_subst') + | C.MutInd (uri,tyno,exp_named_subst) -> + let exp_named_subst' = fix_exp_named_subst context exp_named_subst in + C.MutInd (uri, tyno, exp_named_subst') + | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> + let exp_named_subst' = fix_exp_named_subst context exp_named_subst in + C.MutConstruct (uri, tyno, consno, exp_named_subst') + | C.MutCase (uri, tyno, outty, term, patterns) -> + let outty' = eta_fix' context outty in + let term' = eta_fix' context term in + let patterns' = List.map (eta_fix' context) patterns in + let inductive_types,noparams = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match o with + Cic.Constant _ -> assert false + | Cic.Variable _ -> assert false + | Cic.CurrentProof _ -> assert false + | Cic.InductiveDefinition (l,_,n,_) -> l,n + ) in + let (_,_,_,constructors) = List.nth inductive_types tyno in + let constructor_types = + let rec clean_up t = + function + [] -> t + | a::tl -> + (match t with + Cic.Prod (_,_,t') -> clean_up (S.subst a t') tl + | _ -> assert false) in + if noparams = 0 then + List.map (fun (_,t) -> t) constructors + else + let term_type,_ = + CicTypeChecker.type_of_aux' metasenv context term + CicUniv.empty_ugraph + in + (match term_type with + C.Appl (hd::params) -> + let rec first_n n l = + if n = 0 then [] + else + (match l with + a::tl -> a::(first_n (n-1) tl) + | _ -> assert false) in + List.map + (fun (_,t) -> + clean_up t (first_n noparams params)) constructors + | _ -> prerr_endline ("QUA"); assert false) in + let patterns2 = + List.map2 fix_lambdas_wrt_type + constructor_types patterns' in + C.MutCase (uri, tyno, outty',term',patterns2) + | C.Fix (funno, funs) -> + let fun_types = + List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in + C.Fix (funno, + List.map + (fun (name, no, ty, bo) -> + (name, no, eta_fix' context ty, eta_fix' (fun_types@context) bo)) + funs) + | C.CoFix (funno, funs) -> + let fun_types = + List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in + C.CoFix (funno, + List.map + (fun (name, ty, bo) -> + (name, eta_fix' context ty, eta_fix' (fun_types@context) bo)) funs) + and fix_exp_named_subst context exp_named_subst = + List.rev + (List.fold_left + (fun newsubst (uri,t) -> + let t' = eta_fix' context t in + let ty = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + Cic.Variable (_,_,ty,_,_) -> + CicSubstitution.subst_vars newsubst ty + | _ -> raise ReferenceToNonVariable + in + let t'' = fix_according_to_type ty t' [] in + (uri,t'')::newsubst + ) [] exp_named_subst) + in + eta_fix' context t +;; diff --git a/helm/software/components/cic_acic/eta_fixing.mli b/helm/software/components/cic_acic/eta_fixing.mli new file mode 100644 index 000000000..c6c68119d --- /dev/null +++ b/helm/software/components/cic_acic/eta_fixing.mli @@ -0,0 +1,28 @@ +(* 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 eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term + + diff --git a/helm/software/components/cic_disambiguation/.depend b/helm/software/components/cic_disambiguation/.depend new file mode 100644 index 000000000..ca4124461 --- /dev/null +++ b/helm/software/components/cic_disambiguation/.depend @@ -0,0 +1,12 @@ +disambiguateChoices.cmi: disambiguateTypes.cmi +disambiguate.cmi: disambiguateTypes.cmi +disambiguateTypes.cmo: disambiguateTypes.cmi +disambiguateTypes.cmx: disambiguateTypes.cmi +disambiguateChoices.cmo: disambiguateTypes.cmi disambiguateChoices.cmi +disambiguateChoices.cmx: disambiguateTypes.cmx disambiguateChoices.cmi +disambiguate.cmo: disambiguateTypes.cmi disambiguateChoices.cmi \ + disambiguate.cmi +disambiguate.cmx: disambiguateTypes.cmx disambiguateChoices.cmx \ + disambiguate.cmi +number_notation.cmo: disambiguateTypes.cmi disambiguateChoices.cmi +number_notation.cmx: disambiguateTypes.cmx disambiguateChoices.cmx diff --git a/helm/software/components/cic_disambiguation/Makefile b/helm/software/components/cic_disambiguation/Makefile new file mode 100644 index 000000000..cd03e8281 --- /dev/null +++ b/helm/software/components/cic_disambiguation/Makefile @@ -0,0 +1,32 @@ + +PACKAGE = cic_disambiguation +NOTATIONS = number +INTERFACE_FILES = \ + disambiguateTypes.mli \ + disambiguateChoices.mli \ + disambiguate.mli +IMPLEMENTATION_FILES = \ + $(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \ + $(patsubst %,%_notation.ml,$(NOTATIONS)) + +all: + +clean: +distclean: + rm -f macro_table.dump + +include ../../Makefile.defs +include ../Makefile.common + +OCAMLARCHIVEOPTIONS += -linkall + +disambiguateTypes.cmi: disambiguateTypes.mli + @echo " OCAMLC -rectypes $<" + @$(OCAMLC) -c -rectypes $< +disambiguateTypes.cmo: disambiguateTypes.ml disambiguateTypes.cmi + @echo " OCAMLC -rectypes $<" + @$(OCAMLC) -c -rectypes $< +disambiguateTypes.cmx: disambiguateTypes.ml disambiguateTypes.cmi + @echo " OCAMLOPT -rectypes $<" + @$(OCAMLOPT) -c -rectypes $< + diff --git a/helm/software/components/cic_disambiguation/disambiguate.ml b/helm/software/components/cic_disambiguation/disambiguate.ml new file mode 100644 index 000000000..667c50770 --- /dev/null +++ b/helm/software/components/cic_disambiguation/disambiguate.ml @@ -0,0 +1,1009 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open DisambiguateTypes +open UriManager + +(* the integer is an offset to be added to each location *) +exception NoWellTypedInterpretation of + int * (Token.flocation option * string Lazy.t) list +exception PathNotWellFormed + + (** raised when an environment is not enough informative to decide *) +exception Try_again of string Lazy.t + +type aliases = bool * DisambiguateTypes.environment + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) else () + +(* + (** print benchmark information *) +let benchmark = true +let max_refinements = ref 0 (* benchmarking is not thread safe *) +let actual_refinements = ref 0 +let domain_size = ref 0 +let choices_avg = ref 0. +*) + +let descr_of_domain_item = function + | Id s -> s + | Symbol (s, _) -> s + | Num i -> string_of_int i + +type 'a test_result = + | Ok of 'a * Cic.metasenv + | Ko of Token.flocation option * string Lazy.t + | Uncertain of Token.flocation option * string Lazy.t + +let refine_term metasenv context uri term ugraph ~localization_tbl = +(* if benchmark then incr actual_refinements; *) + assert (uri=None); + debug_print (lazy (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppterm term))); + try + let term', _, metasenv',ugraph1 = + CicRefine.type_of_aux' metasenv context term ugraph ~localization_tbl in + (Ok (term', metasenv')),ugraph1 + with + exn -> + let rec process_exn loc = + function + HExtlib.Localized (loc,exn) -> process_exn (Some loc) exn + | CicRefine.Uncertain msg -> + debug_print (lazy ("UNCERTAIN!!! [" ^ (Lazy.force msg) ^ "] " ^ CicPp.ppterm term)) ; + Uncertain (loc,msg),ugraph + | CicRefine.RefineFailure msg -> + debug_print (lazy (sprintf "PRUNED!!!\nterm%s\nmessage:%s" + (CicPp.ppterm term) (Lazy.force msg))); + Ko (loc,msg),ugraph + | exn -> raise exn + in + process_exn None exn + +let refine_obj metasenv context uri obj ugraph ~localization_tbl = + assert (context = []); + debug_print (lazy (sprintf "TEST_INTERPRETATION: %s" (CicPp.ppobj obj))) ; + try + let obj', metasenv,ugraph = + CicRefine.typecheck metasenv uri obj ~localization_tbl + in + (Ok (obj', metasenv)),ugraph + with + exn -> + let rec process_exn loc = + function + HExtlib.Localized (loc,exn) -> process_exn (Some loc) exn + | CicRefine.Uncertain msg -> + debug_print (lazy ("UNCERTAIN!!! [" ^ (Lazy.force msg) ^ "] " ^ CicPp.ppobj obj)) ; + Uncertain (loc,msg),ugraph + | CicRefine.RefineFailure msg -> + debug_print (lazy (sprintf "PRUNED!!!\nterm%s\nmessage:%s" + (CicPp.ppobj obj) (Lazy.force msg))) ; + Ko (loc,msg),ugraph + | exn -> raise exn + in + process_exn None exn + +let resolve (env: codomain_item Environment.t) (item: domain_item) ?(num = "") ?(args = []) () = + try + snd (Environment.find item env) env num args + with Not_found -> + failwith ("Domain item not found: " ^ + (DisambiguateTypes.string_of_domain_item item)) + + (* TODO move it to Cic *) +let find_in_context name context = + let rec aux acc = function + | [] -> raise Not_found + | Cic.Name hd :: tl when hd = name -> acc + | _ :: tl -> aux (acc + 1) tl + in + aux 1 context + +let interpretate_term ~(context: Cic.name list) ~env ~uri ~is_path ast + ~localization_tbl += + assert (uri = None); + let rec aux ~localize loc (context: Cic.name list) = function + | CicNotationPt.AttributedTerm (`Loc loc, term) -> + let res = aux ~localize loc context term in + if localize then Cic.CicHash.add localization_tbl res loc; + res + | CicNotationPt.AttributedTerm (_, term) -> aux ~localize loc context term + | CicNotationPt.Appl (CicNotationPt.Symbol (symb, i) :: args) -> + let cic_args = List.map (aux ~localize loc context) args in + resolve env (Symbol (symb, i)) ~args:cic_args () + | CicNotationPt.Appl terms -> + Cic.Appl (List.map (aux ~localize loc context) terms) + | CicNotationPt.Binder (binder_kind, (var, typ), body) -> + let cic_type = aux_option ~localize loc context (Some `Type) typ in + let cic_name = CicNotationUtil.cic_name_of_name var in + let cic_body = aux ~localize loc (cic_name :: context) body in + (match binder_kind with + | `Lambda -> Cic.Lambda (cic_name, cic_type, cic_body) + | `Pi + | `Forall -> Cic.Prod (cic_name, cic_type, cic_body) + | `Exists -> + resolve env (Symbol ("exists", 0)) + ~args:[ cic_type; Cic.Lambda (cic_name, cic_type, cic_body) ] ()) + | CicNotationPt.Case (term, indty_ident, outtype, branches) -> + let cic_term = aux ~localize loc context term in + let cic_outtype = aux_option ~localize loc context None outtype in + let do_branch ((head, _, args), term) = + let rec do_branch' context = function + | [] -> aux ~localize loc context term + | (name, typ) :: tl -> + let cic_name = CicNotationUtil.cic_name_of_name name in + let cic_body = do_branch' (cic_name :: context) tl in + let typ = + match typ with + | None -> Cic.Implicit (Some `Type) + | Some typ -> aux ~localize loc context typ + in + Cic.Lambda (cic_name, typ, cic_body) + in + do_branch' context args + in + let (indtype_uri, indtype_no) = + match indty_ident with + | Some (indty_ident, _) -> + (match resolve env (Id indty_ident) () with + | Cic.MutInd (uri, tyno, _) -> (uri, tyno) + | Cic.Implicit _ -> + raise (Try_again (lazy "The type of the term to be matched + is still unknown")) + | _ -> + raise (Invalid_choice (lazy "The type of the term to be matched is not (co)inductive!"))) + | None -> + let fst_constructor = + match branches with + | ((head, _, _), _) :: _ -> head + | [] -> raise (Invalid_choice (lazy "The type of the term to be matched is an inductive type without constructors that cannot be determined")) + in + (match resolve env (Id fst_constructor) () with + | Cic.MutConstruct (indtype_uri, indtype_no, _, _) -> + (indtype_uri, indtype_no) + | Cic.Implicit _ -> + raise (Try_again (lazy "The type of the term to be matched + is still unknown")) + | _ -> + raise (Invalid_choice (lazy "The type of the term to be matched is not (co)inductive!"))) + in + Cic.MutCase (indtype_uri, indtype_no, cic_outtype, cic_term, + (List.map do_branch branches)) + | CicNotationPt.Cast (t1, t2) -> + let cic_t1 = aux ~localize loc context t1 in + let cic_t2 = aux ~localize loc context t2 in + Cic.Cast (cic_t1, cic_t2) + | CicNotationPt.LetIn ((name, typ), def, body) -> + let cic_def = aux ~localize loc context def in + let cic_name = CicNotationUtil.cic_name_of_name name in + let cic_def = + match typ with + | None -> cic_def + | Some t -> Cic.Cast (cic_def, aux ~localize loc context t) + in + let cic_body = aux ~localize loc (cic_name :: context) body in + Cic.LetIn (cic_name, cic_def, cic_body) + | CicNotationPt.LetRec (kind, defs, body) -> + let context' = + List.fold_left + (fun acc ((name, _), _, _) -> + CicNotationUtil.cic_name_of_name name :: acc) + context defs + in + let cic_body = + let unlocalized_body = aux ~localize:false loc context' body in + match unlocalized_body with + Cic.Rel 1 -> `AvoidLetInNoAppl + | Cic.Appl (Cic.Rel 1::l) -> + (try + let l' = + List.map + (function t -> + let t',subst,metasenv = + CicMetaSubst.delift_rels [] [] 1 t + in + assert (subst=[]); + assert (metasenv=[]); + t') l + in + (* We can avoid the LetIn. But maybe we need to recompute l' + so that it is localized *) + if localize then + match body with + CicNotationPt.AttributedTerm (_,CicNotationPt.Appl(_::l)) -> + let l' = List.map (aux ~localize loc context) l in + `AvoidLetIn l' + | _ -> assert false + else + `AvoidLetIn l' + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + if localize then + `AddLetIn (aux ~localize loc context' body) + else + `AddLetIn unlocalized_body) + | _ -> + if localize then + `AddLetIn (aux ~localize loc context' body) + else + `AddLetIn unlocalized_body + in + let inductiveFuns = + List.map + (fun ((name, typ), body, decr_idx) -> + let cic_body = aux ~localize loc context' body in + let cic_type = + aux_option ~localize loc context (Some `Type) typ in + let name = + match CicNotationUtil.cic_name_of_name name with + | Cic.Anonymous -> + CicNotationPt.fail loc + "Recursive functions cannot be anonymous" + | Cic.Name name -> name + in + (name, decr_idx, cic_type, cic_body)) + defs + in + let counter = ref ~-1 in + let build_term funs = + (* this is the body of the fold_right function below. Rationale: Fix + * and CoFix cases differs only in an additional index in the + * inductiveFun list, see Cic.term *) + match kind with + | `Inductive -> + (fun (var, _, _, _) cic -> + incr counter; + let fix = Cic.Fix (!counter,funs) in + match cic with + `Recipe (`AddLetIn cic) -> + `Term (Cic.LetIn (Cic.Name var, fix, cic)) + | `Recipe (`AvoidLetIn l) -> `Term (Cic.Appl (fix::l)) + | `Recipe `AvoidLetInNoAppl -> `Term fix + | `Term t -> `Term (Cic.LetIn (Cic.Name var, fix, t))) + | `CoInductive -> + let funs = + List.map (fun (name, _, typ, body) -> (name, typ, body)) funs + in + (fun (var, _, _, _) cic -> + incr counter; + let cofix = Cic.CoFix (!counter,funs) in + match cic with + `Recipe (`AddLetIn cic) -> + `Term (Cic.LetIn (Cic.Name var, cofix, cic)) + | `Recipe (`AvoidLetIn l) -> `Term (Cic.Appl (cofix::l)) + | `Recipe `AvoidLetInNoAppl -> `Term cofix + | `Term t -> `Term (Cic.LetIn (Cic.Name var, cofix, t))) + in + (match + List.fold_right (build_term inductiveFuns) inductiveFuns + (`Recipe cic_body) + with + `Recipe _ -> assert false + | `Term t -> t) + | CicNotationPt.Ident _ + | CicNotationPt.Uri _ when is_path -> raise PathNotWellFormed + | CicNotationPt.Ident (name, subst) + | CicNotationPt.Uri (name, subst) as ast -> + let is_uri = function CicNotationPt.Uri _ -> true | _ -> false in + (try + if is_uri ast then raise Not_found;(* don't search the env for URIs *) + let index = find_in_context name context in + if subst <> None then + CicNotationPt.fail loc "Explicit substitutions not allowed here"; + Cic.Rel index + with Not_found -> + let cic = + if is_uri ast then (* we have the URI, build the term out of it *) + try + CicUtil.term_of_uri (UriManager.uri_of_string name) + with UriManager.IllFormedUri _ -> + CicNotationPt.fail loc "Ill formed URI" + else + resolve env (Id name) () + in + let mk_subst uris = + let ids_to_uris = + List.map (fun uri -> UriManager.name_of_uri uri, uri) uris + in + (match subst with + | Some subst -> + List.map + (fun (s, term) -> + (try + List.assoc s ids_to_uris, aux ~localize loc context term + with Not_found -> + raise (Invalid_choice (lazy "The provided explicit named substitution is trying to instantiate a named variable the object is not abstracted on")))) + subst + | None -> List.map (fun uri -> uri, Cic.Implicit None) uris) + in + (try + match cic with + | Cic.Const (uri, []) -> + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + let uris = CicUtil.params_of_obj o in + Cic.Const (uri, mk_subst uris) + | Cic.Var (uri, []) -> + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + let uris = CicUtil.params_of_obj o in + Cic.Var (uri, mk_subst uris) + | Cic.MutInd (uri, i, []) -> + (try + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + let uris = CicUtil.params_of_obj o in + Cic.MutInd (uri, i, mk_subst uris) + with + CicEnvironment.Object_not_found _ -> + (* if we are here it is probably the case that during the + definition of a mutual inductive type we have met an + occurrence of the type in one of its constructors. + However, the inductive type is not yet in the environment + *) + (*here the explicit_named_substituion is assumed to be of length 0 *) + Cic.MutInd (uri,i,[])) + | Cic.MutConstruct (uri, i, j, []) -> + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + let uris = CicUtil.params_of_obj o in + Cic.MutConstruct (uri, i, j, mk_subst uris) + | Cic.Meta _ | Cic.Implicit _ as t -> +(* + debug_print (lazy (sprintf + "Warning: %s must be instantiated with _[%s] but we do not enforce it" + (CicPp.ppterm t) + (String.concat "; " + (List.map + (fun (s, term) -> s ^ " := " ^ CicNotationPtPp.pp_term term) + subst)))); +*) + t + | _ -> + raise (Invalid_choice (lazy "??? Can this happen?")) + with + CicEnvironment.CircularDependency _ -> + raise (Invalid_choice (lazy "Circular dependency in the environment")))) + | CicNotationPt.Implicit -> Cic.Implicit None + | CicNotationPt.UserInput -> Cic.Implicit (Some `Hole) + | CicNotationPt.Num (num, i) -> resolve env (Num i) ~num () + | CicNotationPt.Meta (index, subst) -> + let cic_subst = + List.map + (function + None -> None + | Some term -> Some (aux ~localize loc context term)) + subst + in + Cic.Meta (index, cic_subst) + | CicNotationPt.Sort `Prop -> Cic.Sort Cic.Prop + | CicNotationPt.Sort `Set -> Cic.Sort Cic.Set + | CicNotationPt.Sort (`Type u) -> Cic.Sort (Cic.Type u) + | CicNotationPt.Sort `CProp -> Cic.Sort Cic.CProp + | CicNotationPt.Symbol (symbol, instance) -> + resolve env (Symbol (symbol, instance)) () + | _ -> assert false (* god bless Bologna *) + and aux_option ~localize loc (context: Cic.name list) annotation = function + | None -> Cic.Implicit annotation + | Some term -> aux ~localize loc context term + in + aux ~localize:true HExtlib.dummy_floc context ast + +let interpretate_path ~context path = + let localization_tbl = Cic.CicHash.create 23 in + (* here we are throwing away useful localization informations!!! *) + fst ( + interpretate_term ~context ~env:Environment.empty ~uri:None ~is_path:true + path ~localization_tbl, localization_tbl) + +let interpretate_obj ~context ~env ~uri ~is_path obj ~localization_tbl = + assert (context = []); + assert (is_path = false); + let interpretate_term = interpretate_term ~localization_tbl in + match obj with + | CicNotationPt.Inductive (params,tyl) -> + let uri = match uri with Some uri -> uri | None -> assert false in + let context,params = + let context,res = + List.fold_left + (fun (context,res) (name,t) -> + Cic.Name name :: context, + (name, interpretate_term context env None false t)::res + ) ([],[]) params + in + context,List.rev res in + let add_params = + List.fold_right + (fun (name,ty) t -> Cic.Prod (Cic.Name name,ty,t)) params in + let name_to_uris = + snd ( + List.fold_left + (*here the explicit_named_substituion is assumed to be of length 0 *) + (fun (i,res) (name,_,_,_) -> + i + 1,(name,name,Cic.MutInd (uri,i,[]))::res + ) (0,[]) tyl) in + let con_env = DisambiguateTypes.env_of_list name_to_uris env in + let tyl = + List.map + (fun (name,b,ty,cl) -> + let ty' = add_params (interpretate_term context env None false ty) in + let cl' = + List.map + (fun (name,ty) -> + let ty' = + add_params (interpretate_term context con_env None false ty) + in + name,ty' + ) cl + in + name,b,ty',cl' + ) tyl + in + Cic.InductiveDefinition (tyl,[],List.length params,[]) + | CicNotationPt.Record (params,name,ty,fields) -> + let uri = match uri with Some uri -> uri | None -> assert false in + let context,params = + let context,res = + List.fold_left + (fun (context,res) (name,t) -> + (Cic.Name name :: context), + (name, interpretate_term context env None false t)::res + ) ([],[]) params + in + context,List.rev res in + let add_params = + List.fold_right + (fun (name,ty) t -> Cic.Prod (Cic.Name name,ty,t)) params in + let ty' = add_params (interpretate_term context env None false ty) in + let fields' = + snd ( + List.fold_left + (fun (context,res) (name,ty,_coercion) -> + let context' = Cic.Name name :: context in + context',(name,interpretate_term context env None false ty)::res + ) (context,[]) fields) in + let concl = + (*here the explicit_named_substituion is assumed to be of length 0 *) + let mutind = Cic.MutInd (uri,0,[]) in + if params = [] then mutind + else + Cic.Appl + (mutind::CicUtil.mk_rels (List.length params) (List.length fields)) in + let con = + List.fold_left + (fun t (name,ty) -> Cic.Prod (Cic.Name name,ty,t)) + concl fields' in + let con' = add_params con in + let tyl = [name,true,ty',["mk_" ^ name,con']] in + let field_names = List.map (fun (x,_,y) -> x,y) fields in + Cic.InductiveDefinition + (tyl,[],List.length params,[`Class (`Record field_names)]) + | CicNotationPt.Theorem (flavour, name, ty, bo) -> + let attrs = [`Flavour flavour] in + let ty' = interpretate_term [] env None false ty in + (match bo with + None -> + Cic.CurrentProof (name,[],Cic.Implicit None,ty',[],attrs) + | Some bo -> + let bo' = Some (interpretate_term [] env None false bo) in + Cic.Constant (name,bo',ty',[],attrs)) + + + (* e.g. [5;1;1;1;2;3;4;1;2] -> [2;1;4;3;5] *) +let rev_uniq = + let module SortedItem = + struct + type t = DisambiguateTypes.domain_item + let compare = Pervasives.compare + end + in + let module Set = Set.Make (SortedItem) in + fun l -> + let rev_l = List.rev l in + let (_, uniq_rev_l) = + List.fold_left + (fun (members, rev_l) elt -> + if Set.mem elt members then + (members, rev_l) + else + Set.add elt members, elt :: rev_l) + (Set.empty, []) rev_l + in + List.rev uniq_rev_l + +(* "aux" keeps domain in reverse order and doesn't care about duplicates. + * Domain item more in deep in the list will be processed first. + *) +let rec domain_rev_of_term ?(loc = HExtlib.dummy_floc) context = function + | CicNotationPt.AttributedTerm (`Loc loc, term) -> + domain_rev_of_term ~loc context term + | CicNotationPt.AttributedTerm (_, term) -> + domain_rev_of_term ~loc context term + | CicNotationPt.Appl terms -> + List.fold_left + (fun dom term -> domain_rev_of_term ~loc context term @ dom) [] terms + | CicNotationPt.Binder (kind, (var, typ), body) -> + let kind_dom = + match kind with + | `Exists -> [ Symbol ("exists", 0) ] + | _ -> [] + in + let type_dom = domain_rev_of_term_option loc context typ in + let body_dom = + domain_rev_of_term ~loc + (CicNotationUtil.cic_name_of_name var :: context) body + in + body_dom @ type_dom @ kind_dom + | CicNotationPt.Case (term, indty_ident, outtype, branches) -> + let term_dom = domain_rev_of_term ~loc context term in + let outtype_dom = domain_rev_of_term_option loc context outtype in + let get_first_constructor = function + | [] -> [] + | ((head, _, _), _) :: _ -> [ Id head ] + in + let do_branch ((head, _, args), term) = + let (term_context, args_domain) = + List.fold_left + (fun (cont, dom) (name, typ) -> + (CicNotationUtil.cic_name_of_name name :: cont, + (match typ with + | None -> dom + | Some typ -> domain_rev_of_term ~loc cont typ @ dom))) + (context, []) args + in + args_domain @ domain_rev_of_term ~loc term_context term + in + let branches_dom = + List.fold_left (fun dom branch -> do_branch branch @ dom) [] branches + in + branches_dom @ outtype_dom @ term_dom @ + (match indty_ident with + | None -> get_first_constructor branches + | Some (ident, _) -> [ Id ident ]) + | CicNotationPt.Cast (term, ty) -> + let term_dom = domain_rev_of_term ~loc context term in + let ty_dom = domain_rev_of_term ~loc context ty in + ty_dom @ term_dom + | CicNotationPt.LetIn ((var, typ), body, where) -> + let body_dom = domain_rev_of_term ~loc context body in + let type_dom = domain_rev_of_term_option loc context typ in + let where_dom = + domain_rev_of_term ~loc + (CicNotationUtil.cic_name_of_name var :: context) where + in + where_dom @ type_dom @ body_dom + | CicNotationPt.LetRec (kind, defs, where) -> + let context' = + List.fold_left + (fun acc ((var, typ), _, _) -> + CicNotationUtil.cic_name_of_name var :: acc) + context defs + in + let where_dom = domain_rev_of_term ~loc context' where in + let defs_dom = + List.fold_left + (fun dom ((_, typ), body, _) -> + domain_rev_of_term ~loc context' body @ + domain_rev_of_term_option loc context typ) + [] defs + in + where_dom @ defs_dom + | CicNotationPt.Ident (name, subst) -> + (try + (* the next line can raise Not_found *) + ignore(find_in_context name context); + if subst <> None then + CicNotationPt.fail loc "Explicit substitutions not allowed here" + else + [] + with Not_found -> + (match subst with + | None -> [Id name] + | Some subst -> + List.fold_left + (fun dom (_, term) -> + let dom' = domain_rev_of_term ~loc context term in + dom' @ dom) + [Id name] subst)) + | CicNotationPt.Uri _ -> [] + | CicNotationPt.Implicit -> [] + | CicNotationPt.Num (num, i) -> [ Num i ] + | CicNotationPt.Meta (index, local_context) -> + List.fold_left + (fun dom term -> domain_rev_of_term_option loc context term @ dom) [] + local_context + | CicNotationPt.Sort _ -> [] + | CicNotationPt.Symbol (symbol, instance) -> [ Symbol (symbol, instance) ] + | CicNotationPt.UserInput + | CicNotationPt.Literal _ + | CicNotationPt.Layout _ + | CicNotationPt.Magic _ + | CicNotationPt.Variable _ -> assert false + +and domain_rev_of_term_option loc context = function + | None -> [] + | Some t -> domain_rev_of_term ~loc context t + +let domain_of_term ~context ast = rev_uniq (domain_rev_of_term context ast) + +let domain_of_obj ~context ast = + assert (context = []); + let domain_rev = + match ast with + | CicNotationPt.Theorem (_,_,ty,bo) -> + (match bo with + None -> [] + | Some bo -> domain_rev_of_term [] bo) @ + domain_of_term [] ty + | CicNotationPt.Inductive (params,tyl) -> + let dom = + List.flatten ( + List.rev_map + (fun (_,_,ty,cl) -> + List.flatten ( + List.rev_map + (fun (_,ty) -> domain_rev_of_term [] ty) cl) @ + domain_rev_of_term [] ty) tyl) in + let dom = + List.fold_left + (fun dom (_,ty) -> + domain_rev_of_term [] ty @ dom + ) dom params + in + List.filter + (fun name -> + not ( List.exists (fun (name',_) -> name = Id name') params + || List.exists (fun (name',_,_,_) -> name = Id name') tyl) + ) dom + | CicNotationPt.Record (params,_,ty,fields) -> + let dom = + List.flatten + (List.rev_map (fun (_,ty,_) -> domain_rev_of_term [] ty) fields) in + let dom = + List.fold_left + (fun dom (_,ty) -> + domain_rev_of_term [] ty @ dom + ) (dom @ domain_rev_of_term [] ty) params + in + List.filter + (fun name-> + not ( List.exists (fun (name',_) -> name = Id name') params + || List.exists (fun (name',_,_) -> name = Id name') fields) + ) dom + in + rev_uniq domain_rev + + (* dom1 \ dom2 *) +let domain_diff dom1 dom2 = +(* let domain_diff = Domain.diff *) + let is_in_dom2 = + List.fold_left (fun pred elt -> (fun elt' -> elt' = elt || pred elt')) + (fun _ -> false) dom2 + in + List.filter (fun elt -> not (is_in_dom2 elt)) dom1 + +module type Disambiguator = +sig + val disambiguate_term : + ?fresh_instances:bool -> + dbd:HMysql.dbd -> + context:Cic.context -> + metasenv:Cic.metasenv -> + ?initial_ugraph:CicUniv.universe_graph -> + aliases:DisambiguateTypes.environment ->(* previous interpretation status *) + universe:DisambiguateTypes.multiple_environment option -> + CicNotationPt.term -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * + Cic.metasenv * (* new metasenv *) + Cic.term* + CicUniv.universe_graph) list * (* disambiguated term *) + bool + + val disambiguate_obj : + ?fresh_instances:bool -> + dbd:HMysql.dbd -> + aliases:DisambiguateTypes.environment ->(* previous interpretation status *) + universe:DisambiguateTypes.multiple_environment option -> + uri:UriManager.uri option -> (* required only for inductive types *) + CicNotationPt.obj -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * + Cic.metasenv * (* new metasenv *) + Cic.obj * + CicUniv.universe_graph) list * (* disambiguated obj *) + bool +end + +module Make (C: Callbacks) = + struct + let choices_of_id dbd id = + let uris = Whelp.locate ~dbd id in + let uris = + match uris with + | [] -> + [(C.input_or_locate_uri + ~title:("URI matching \"" ^ id ^ "\" unknown.") ~id ())] + | [uri] -> [uri] + | _ -> + C.interactive_user_uri_choice ~selection_mode:`MULTIPLE + ~ok:"Try selected." ~enable_button_for_non_vars:true + ~title:"Ambiguous input." ~id + ~msg: ("Ambiguous input \"" ^ id ^ + "\". Please, choose one or more interpretations:") + uris + in + List.map + (fun uri -> + (UriManager.string_of_uri uri, + let term = + try + CicUtil.term_of_uri uri + with exn -> + debug_print (lazy (UriManager.string_of_uri uri)); + debug_print (lazy (Printexc.to_string exn)); + assert false + in + fun _ _ _ -> term)) + uris + +let refine_profiler = HExtlib.profile "disambiguate_thing.refine_thing" + + let disambiguate_thing ~dbd ~context ~metasenv + ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases ~universe + ~uri ~pp_thing ~domain_of_thing ~interpretate_thing ~refine_thing thing + = + debug_print (lazy "DISAMBIGUATE INPUT"); + let disambiguate_context = (* cic context -> disambiguate context *) + List.map + (function None -> Cic.Anonymous | Some (name, _) -> name) + context + in + debug_print (lazy ("TERM IS: " ^ (pp_thing thing))); + let thing_dom = domain_of_thing ~context:disambiguate_context thing in + debug_print (lazy (sprintf "DISAMBIGUATION DOMAIN: %s" + (string_of_domain thing_dom))); +(* + debug_print (lazy (sprintf "DISAMBIGUATION ENVIRONMENT: %s" + (DisambiguatePp.pp_environment aliases))); + debug_print (lazy (sprintf "DISAMBIGUATION UNIVERSE: %s" + (match universe with None -> "None" | Some _ -> "Some _"))); +*) + let current_dom = + Environment.fold (fun item _ dom -> item :: dom) aliases [] + in + let todo_dom = domain_diff thing_dom current_dom in + (* (2) lookup function for any item (Id/Symbol/Num) *) + let lookup_choices = + fun item -> + let choices = + let lookup_in_library () = + match item with + | Id id -> choices_of_id dbd id + | Symbol (symb, _) -> + List.map DisambiguateChoices.mk_choice + (TermAcicContent.lookup_interpretations symb) + | Num instance -> + DisambiguateChoices.lookup_num_choices () + in + match universe with + | None -> lookup_in_library () + | Some e -> + (try + let item = + match item with + | Symbol (symb, _) -> Symbol (symb, 0) + | item -> item + in + Environment.find item e + with Not_found -> []) + in + choices + in +(* + (* *) + let _ = + if benchmark then begin + let per_item_choices = + List.map + (fun dom_item -> + try + let len = List.length (lookup_choices dom_item) in + debug_print (lazy (sprintf "BENCHMARK %s: %d" + (string_of_domain_item dom_item) len)); + len + with No_choices _ -> 0) + thing_dom + in + max_refinements := List.fold_left ( * ) 1 per_item_choices; + actual_refinements := 0; + domain_size := List.length thing_dom; + choices_avg := + (float_of_int !max_refinements) ** (1. /. float_of_int !domain_size) + end + in + (* *) +*) + + (* (3) test an interpretation filling with meta uninterpreted identifiers + *) + let test_env aliases todo_dom ugraph = + let filled_env = + List.fold_left + (fun env item -> + Environment.add item + ("Implicit", + (match item with + | Id _ | Num _ -> (fun _ _ _ -> Cic.Implicit (Some `Closed)) + | Symbol _ -> (fun _ _ _ -> Cic.Implicit None))) env) + aliases todo_dom + in + try + let localization_tbl = Cic.CicHash.create 503 in + let cic_thing = + interpretate_thing ~context:disambiguate_context ~env:filled_env + ~uri ~is_path:false thing ~localization_tbl + in +let foo () = + let k,ugraph1 = + refine_thing metasenv context uri cic_thing ugraph ~localization_tbl + in + (k , ugraph1 ) +in refine_profiler.HExtlib.profile foo () + with + | Try_again msg -> Uncertain (None,msg), ugraph + | Invalid_choice msg -> Ko (None,msg), ugraph + in + (* (4) build all possible interpretations *) + let (@@) (l1,l2) (l1',l2') = l1@l1', l2@l2' in + let rec aux aliases diff lookup_in_todo_dom todo_dom base_univ = + match todo_dom with + | [] -> + assert (lookup_in_todo_dom = None); + (match test_env aliases [] base_univ with + | Ok (thing, metasenv),new_univ -> + [ aliases, diff, metasenv, thing, new_univ ], [] + | Ko (loc,msg),_ | Uncertain (loc,msg),_ -> [],[loc,msg]) + | item :: remaining_dom -> + debug_print (lazy (sprintf "CHOOSED ITEM: %s" + (string_of_domain_item item))); + let choices = + match lookup_in_todo_dom with + None -> lookup_choices item + | Some choices -> choices in + match choices with + [] -> + [], [None,lazy ("No choices for " ^ string_of_domain_item item)] + | [codomain_item] -> + (* just one choice. We perform a one-step look-up and + if the next set of choices is also a singleton we + skip this refinement step *) + debug_print(lazy (sprintf "%s CHOSEN" (fst codomain_item))); + let new_env = Environment.add item codomain_item aliases in + let new_diff = (item,codomain_item)::diff in + let lookup_in_todo_dom,next_choice_is_single = + match remaining_dom with + [] -> None,false + | he::_ -> + let choices = lookup_choices he in + Some choices,List.length choices = 1 + in + if next_choice_is_single then + aux new_env new_diff lookup_in_todo_dom remaining_dom + base_univ + else + (match test_env new_env remaining_dom base_univ with + | Ok (thing, metasenv),new_univ -> + (match remaining_dom with + | [] -> + [ new_env, new_diff, metasenv, thing, new_univ ], [] + | _ -> + aux new_env new_diff lookup_in_todo_dom + remaining_dom new_univ) + | Uncertain (loc,msg),new_univ -> + (match remaining_dom with + | [] -> [], [loc,msg] + | _ -> + aux new_env new_diff lookup_in_todo_dom + remaining_dom new_univ) + | Ko (loc,msg),_ -> [], [loc,msg]) + | _::_ -> + let rec filter univ = function + | [] -> [],[] + | codomain_item :: tl -> + debug_print(lazy (sprintf "%s CHOSEN" (fst codomain_item))); + let new_env = Environment.add item codomain_item aliases in + let new_diff = (item,codomain_item)::diff in + (match test_env new_env remaining_dom univ with + | Ok (thing, metasenv),new_univ -> + (match remaining_dom with + | [] -> [ new_env, new_diff, metasenv, thing, new_univ ], [] + | _ -> aux new_env new_diff None remaining_dom new_univ + ) @@ + filter univ tl + | Uncertain (loc,msg),new_univ -> + (match remaining_dom with + | [] -> [],[loc,msg] + | _ -> aux new_env new_diff None remaining_dom new_univ + ) @@ + filter univ tl + | Ko (loc,msg),_ -> ([],[loc,msg]) @@ filter univ tl) + in + filter base_univ choices + in + let base_univ = initial_ugraph in + try + let res = + match aux aliases [] None todo_dom base_univ with + | [],errors -> raise (NoWellTypedInterpretation (0,errors)) + | [_,diff,metasenv,t,ugraph],_ -> + debug_print (lazy "SINGLE INTERPRETATION"); + [diff,metasenv,t,ugraph], false + | l,_ -> + debug_print (lazy (sprintf "MANY INTERPRETATIONS (%d)" (List.length l))); + let choices = + List.map + (fun (env, _, _, _, _) -> + List.map + (fun domain_item -> + let description = + fst (Environment.find domain_item env) + in + (descr_of_domain_item domain_item, description)) + thing_dom) + l + in + let choosed = C.interactive_interpretation_choice choices in + (List.map (fun n->let _,d,m,t,u= List.nth l n in d,m,t,u) choosed), + true + in + res + with + CicEnvironment.CircularDependency s -> + failwith "Disambiguate: circular dependency" + + let disambiguate_term ?(fresh_instances=false) ~dbd ~context ~metasenv + ?(initial_ugraph = CicUniv.empty_ugraph) ~aliases ~universe term + = + let term = + if fresh_instances then CicNotationUtil.freshen_term term else term + in + disambiguate_thing ~dbd ~context ~metasenv ~initial_ugraph ~aliases + ~universe ~uri:None ~pp_thing:CicNotationPp.pp_term + ~domain_of_thing:domain_of_term ~interpretate_thing:interpretate_term + ~refine_thing:refine_term term + + let disambiguate_obj ?(fresh_instances=false) ~dbd ~aliases ~universe ~uri + obj + = + let obj = + if fresh_instances then CicNotationUtil.freshen_obj obj else obj + in + disambiguate_thing ~dbd ~context:[] ~metasenv:[] ~aliases ~universe ~uri + ~pp_thing:CicNotationPp.pp_obj ~domain_of_thing:domain_of_obj + ~interpretate_thing:interpretate_obj ~refine_thing:refine_obj + obj + end + diff --git a/helm/software/components/cic_disambiguation/disambiguate.mli b/helm/software/components/cic_disambiguation/disambiguate.mli new file mode 100644 index 000000000..a2cc0d0e7 --- /dev/null +++ b/helm/software/components/cic_disambiguation/disambiguate.mli @@ -0,0 +1,73 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(** {2 Disambiguation interface} *) + +(* the integer is an offset to be added to each location *) +exception NoWellTypedInterpretation of + int * (Token.flocation option * string Lazy.t) list +exception PathNotWellFormed + +val interpretate_path : + context:Cic.name list -> CicNotationPt.term -> + Cic.term + +module type Disambiguator = +sig + (** @param fresh_instances when set to true fresh instances will be generated + * for each number _and_ symbol in the disambiguation domain. Instances of the + * input AST will be ignored. Defaults to false. *) + val disambiguate_term : + ?fresh_instances:bool -> + dbd:HMysql.dbd -> + context:Cic.context -> + metasenv:Cic.metasenv -> + ?initial_ugraph:CicUniv.universe_graph -> + aliases:DisambiguateTypes.environment ->(* previous interpretation status *) + universe:DisambiguateTypes.multiple_environment option -> + CicNotationPt.term -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * + Cic.metasenv * (* new metasenv *) + Cic.term * + CicUniv.universe_graph) list * (* disambiguated term *) + bool (* has interactive_interpretation_choice been invoked? *) + + (** @param fresh_instances as per disambiguate_term *) + val disambiguate_obj : + ?fresh_instances:bool -> + dbd:HMysql.dbd -> + aliases:DisambiguateTypes.environment ->(* previous interpretation status *) + universe:DisambiguateTypes.multiple_environment option -> + uri:UriManager.uri option -> (* required only for inductive types *) + CicNotationPt.obj -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * + Cic.metasenv * (* new metasenv *) + Cic.obj * + CicUniv.universe_graph) list * (* disambiguated obj *) + bool (* has interactive_interpretation_choice been invoked? *) +end + +module Make (C : DisambiguateTypes.Callbacks) : Disambiguator + diff --git a/helm/software/components/cic_disambiguation/disambiguateChoices.ml b/helm/software/components/cic_disambiguation/disambiguateChoices.ml new file mode 100644 index 000000000..bdbc93179 --- /dev/null +++ b/helm/software/components/cic_disambiguation/disambiguateChoices.ml @@ -0,0 +1,69 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open DisambiguateTypes + +exception Choice_not_found of string Lazy.t + +let num_choices = ref [] + +let add_num_choice choice = num_choices := choice :: !num_choices + +let has_description dsc = (fun x -> fst x = dsc) + +let lookup_num_choices () = !num_choices + +let lookup_num_by_dsc dsc = + try + List.find (has_description dsc) !num_choices + with Not_found -> raise (Choice_not_found (lazy ("Num with dsc " ^ dsc))) + +let mk_choice (dsc, args, appl_pattern) = + dsc, + (fun env _ cic_args -> + let env' = + let names = + List.map (function CicNotationPt.IdentArg (_, name) -> name) args + in + try + List.combine names cic_args + with Invalid_argument _ -> + raise (Invalid_choice (lazy "The notation expects a different number of arguments")) + in + TermAcicContent.instantiate_appl_pattern env' appl_pattern) + +let lookup_symbol_by_dsc symbol dsc = + try + mk_choice + (List.find + (fun (dsc', _, _) -> dsc = dsc') + (TermAcicContent.lookup_interpretations symbol)) + with TermAcicContent.Interpretation_not_found | Not_found -> + raise (Choice_not_found (lazy (sprintf "Symbol %s, dsc %s" symbol dsc))) + diff --git a/helm/software/components/cic_disambiguation/disambiguateChoices.mli b/helm/software/components/cic_disambiguation/disambiguateChoices.mli new file mode 100644 index 000000000..0ad498106 --- /dev/null +++ b/helm/software/components/cic_disambiguation/disambiguateChoices.mli @@ -0,0 +1,53 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +open DisambiguateTypes + +(** {2 Choice registration low-level interface} *) + + (** raised by lookup_XXXX below *) +exception Choice_not_found of string Lazy.t + + (** register a new number choice *) +val add_num_choice: codomain_item -> unit + +(** {2 Choices lookup} + * for user defined aliases *) + +val lookup_num_choices: unit -> codomain_item list + + (** @param dsc description (1st component of codomain_item) *) +val lookup_num_by_dsc: string -> codomain_item + + (** @param symbol symbol as per AST + * @param dsc description (1st component of codomain_item) + *) +val lookup_symbol_by_dsc: string -> string -> codomain_item + +val mk_choice: + string * CicNotationPt.argument_pattern list * + CicNotationPt.cic_appl_pattern -> + codomain_item + diff --git a/helm/software/components/cic_disambiguation/disambiguateTypes.ml b/helm/software/components/cic_disambiguation/disambiguateTypes.ml new file mode 100644 index 000000000..4a2e43a20 --- /dev/null +++ b/helm/software/components/cic_disambiguation/disambiguateTypes.ml @@ -0,0 +1,119 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +(* +type term = CicNotationPt.term +type tactic = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactic +type tactical = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactical +type script_entry = + | Command of tactical + | Comment of CicNotationPt.location * string +type script = CicNotationPt.location * script_entry list +*) + +type domain_item = + | Id of string (* literal *) + | Symbol of string * int (* literal, instance num *) + | Num of int (* instance num *) + +exception Invalid_choice of string Lazy.t + +module OrderedDomain = + struct + type t = domain_item + let compare = Pervasives.compare + end + +(* module Domain = Set.Make (OrderedDomain) *) +module Environment = +struct + module Environment' = Map.Make (OrderedDomain) + + include Environment' + + let cons k v env = + try + let current = find k env in + let dsc, _ = v in + add k (v :: (List.filter (fun (dsc', _) -> dsc' <> dsc) current)) env + with Not_found -> + add k [v] env + + let hd list_env = + try + map List.hd list_env + with Failure _ -> assert false + + let fold_flatten f env base = + fold + (fun k l acc -> List.fold_right (fun v acc -> f k v acc) l acc) + env base + +end + +type codomain_item = + string * (* description *) + (environment -> string -> Cic.term list -> Cic.term) + (* environment, literal number, arguments as needed *) + +and environment = codomain_item Environment.t + +type multiple_environment = codomain_item list Environment.t + + +(** adds a (name,uri) list l to a disambiguation environment e **) +let multiple_env_of_list l e = + List.fold_left + (fun e (name,descr,t) -> Environment.cons (Id name) (descr,fun _ _ _ -> t) e) + e l + +let env_of_list l e = + List.fold_left + (fun e (name,descr,t) -> Environment.add (Id name) (descr,fun _ _ _ -> t) e) + e l + +module type Callbacks = + sig + val interactive_user_uri_choice: + selection_mode:[`SINGLE | `MULTIPLE] -> + ?ok:string -> + ?enable_button_for_non_vars:bool -> + title:string -> msg:string -> id:string -> UriManager.uri list -> + UriManager.uri list + val interactive_interpretation_choice: + (string * string) list list -> int list + val input_or_locate_uri: + title:string -> ?id:string -> unit -> UriManager.uri + end + +let string_of_domain_item = function + | Id s -> Printf.sprintf "ID(%s)" s + | Symbol (s, i) -> Printf.sprintf "SYMBOL(%s,%d)" s i + | Num i -> Printf.sprintf "NUM(instance %d)" i + +let string_of_domain dom = + String.concat "; " (List.map string_of_domain_item dom) diff --git a/helm/software/components/cic_disambiguation/disambiguateTypes.mli b/helm/software/components/cic_disambiguation/disambiguateTypes.mli new file mode 100644 index 000000000..4f4b3c3ec --- /dev/null +++ b/helm/software/components/cic_disambiguation/disambiguateTypes.mli @@ -0,0 +1,96 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +type domain_item = + | Id of string (* literal *) + | Symbol of string * int (* literal, instance num *) + | Num of int (* instance num *) + +(* module Domain: Set.S with type elt = domain_item *) +module Environment: +sig + include Map.S with type key = domain_item + val cons: domain_item -> ('a * 'b) -> ('a * 'b) list t -> ('a * 'b) list t + val hd: 'a list t -> 'a t + + (** last alias cons-ed will be processed first *) + val fold_flatten: (domain_item -> 'a -> 'b -> 'b) -> 'a list t -> 'b -> 'b +end + + (** to be raised when a choice is invalid due to some given parameter (e.g. + * wrong number of Cic.term arguments received) *) +exception Invalid_choice of string Lazy.t + +type codomain_item = + string * (* description *) + (environment -> string -> Cic.term list -> Cic.term) + (* environment, literal number, arguments as needed *) + +and environment = codomain_item Environment.t + +type multiple_environment = codomain_item list Environment.t + +(* a simple case of extension of a disambiguation environment *) +val env_of_list: + (string * string * Cic.term) list -> environment -> environment + +val multiple_env_of_list: + (string * string * Cic.term) list -> multiple_environment -> + multiple_environment + +module type Callbacks = + sig + + val interactive_user_uri_choice : + selection_mode:[`SINGLE | `MULTIPLE] -> + ?ok:string -> + ?enable_button_for_non_vars:bool -> + title:string -> msg:string -> id:string -> UriManager.uri list -> + UriManager.uri list + + val interactive_interpretation_choice : + (string * string) list list -> int list + + (** @param title gtk window title for user prompting + * @param id unbound identifier which originated this callback invocation *) + val input_or_locate_uri: + title:string -> ?id:string -> unit -> UriManager.uri + end + +val string_of_domain_item: domain_item -> string +val string_of_domain: domain_item list -> string + +(** {3 type shortands} *) + +(* +type term = CicNotationPt.term +type tactic = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactic +type tactical = (term, term, GrafiteAst.reduction, string) GrafiteAst.tactical + +type script_entry = + | Command of tactical + | Comment of CicNotationPt.location * string +type script = CicNotationPt.location * script_entry list +*) diff --git a/helm/software/components/cic_disambiguation/doc/precedence.txt b/helm/software/components/cic_disambiguation/doc/precedence.txt new file mode 100644 index 000000000..09efea853 --- /dev/null +++ b/helm/software/components/cic_disambiguation/doc/precedence.txt @@ -0,0 +1,32 @@ + +Input Should be parsed as Derived constraint + on precedence +-------------------------------------------------------------------------------- +\lambda x.x y \lambda x.(x y) lambda > apply +S x = y (= (S x) y) apply > infix operators +\forall x.x=x (\forall x.(= x x)) infix operators > binders +\lambda x.x \to x \lambda. (x \to x) \to > \lambda +-------------------------------------------------------------------------------- + +Precedence total order: + + apply > infix operators > to > binders + +where binders are all binders except lambda (i.e. \forall, \pi, \exists) + +to test: + +./test_parser term << EOT + \lambda x.x y + S x = y + \forall x.x=x + \lambda x.x \to x +EOT + +should respond with: + + \lambda x.(x y) + (eq (S x) y) + \forall x.(eq x x) + \lambda x.(x \to x) + diff --git a/helm/software/components/cic_disambiguation/number_notation.ml b/helm/software/components/cic_disambiguation/number_notation.ml new file mode 100644 index 000000000..2b3ce2d60 --- /dev/null +++ b/helm/software/components/cic_disambiguation/number_notation.ml @@ -0,0 +1,55 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let _ = + DisambiguateChoices.add_num_choice + ("natural number", + (fun _ num _ -> HelmLibraryObjects.build_nat (int_of_string num))); + DisambiguateChoices.add_num_choice + ("real number", + (fun _ num _ -> HelmLibraryObjects.build_real (int_of_string num))); + DisambiguateChoices.add_num_choice + ("binary positive number", + (fun _ num _ -> + let num = int_of_string num in + if num = 0 then + raise (DisambiguateTypes.Invalid_choice (lazy "0 is not a valid positive number")) + else + HelmLibraryObjects.build_bin_pos num)); + DisambiguateChoices.add_num_choice + ("binary integer number", + (fun _ num _ -> + let num = int_of_string num in + if num = 0 then + HelmLibraryObjects.BinInt.z0 + else if num > 0 then + Cic.Appl [ + HelmLibraryObjects.BinInt.zpos; + HelmLibraryObjects.build_bin_pos num ] + else + assert false)) + diff --git a/helm/software/components/cic_disambiguation/tests/aliases.txt b/helm/software/components/cic_disambiguation/tests/aliases.txt new file mode 100644 index 000000000..12b09fff1 --- /dev/null +++ b/helm/software/components/cic_disambiguation/tests/aliases.txt @@ -0,0 +1,6 @@ +alias id foo = cic:/a.con +alias id bar = cic:/b.con +alias symbol "plus" (instance 0) = "real plus" +alias symbol "plus" (instance 1) = "natural plus" +alias num (instance 0) = "real number" +alias num (instance 1) = "natural number" diff --git a/helm/software/components/cic_disambiguation/tests/eq.txt b/helm/software/components/cic_disambiguation/tests/eq.txt new file mode 100644 index 000000000..6a826fc71 --- /dev/null +++ b/helm/software/components/cic_disambiguation/tests/eq.txt @@ -0,0 +1 @@ +\forall n. \forall m. n + m = n diff --git a/helm/software/components/cic_disambiguation/tests/match.txt b/helm/software/components/cic_disambiguation/tests/match.txt new file mode 100644 index 000000000..87bb0159b --- /dev/null +++ b/helm/software/components/cic_disambiguation/tests/match.txt @@ -0,0 +1,49 @@ +[\lambda x:nat. + [\lambda y:nat. Set] + match x:nat with [ O \Rightarrow nat | (S x) \Rightarrow bool ]] +match (S O):nat with +[ O \Rightarrow O +| (S x) \Rightarrow false ] + +[\lambda z:nat. \lambda h:(le O z). (eq nat O O)] +match (le_n O): le with +[ le_n \Rightarrow (refl_equal nat O) +| (le_S x y) \Rightarrow (refl_equal nat O) ] + +[\lambda z:nat. \lambda h:(le (plus (plus O O) (plus O O)) z). (eq nat (plus (plus O O) (plus O O)) (plus (plus O O) (plus O O)))] +match (le_n (plus (plus O O) (plus O O))): le with +[ le_n \Rightarrow (refl_equal nat (plus (plus O O) (plus O O))) +| (le_S x y) \Rightarrow (refl_equal nat (plus (plus O O) (plus O O))) ] + +(* +[\lambda z:nat. \lambda h:(le 1 z). (le 0 z)] +match (le_S 2 (le_n 1)): le with +[ le_n \Rightarrow (le_S 1 (le_n 0)) +| (le_S x y) \Rightarrow y ] +*) + +[\lambda z:nat. \lambda h:(le 0 z). (le 0 (S z))] +match (le_S 0 0 (le_n 0)): le with +[ le_n \Rightarrow (le_S 0 0 (le_n 0)) +| (le_S x y) \Rightarrow (le_S 0 (S x) (le_S 0 x y)) ] + + +[\lambda x:bool. nat] +match true:bool with +[ true \Rightarrow O +| false \Rightarrow (S O) ] + +[\lambda x:nat. nat] +match O:nat with +[ O \Rightarrow O +| (S x) \Rightarrow (S (S x)) ] + +[\lambda x:list. list] +match nil:list with +[ nil \Rightarrow nil +| (cons x y) \Rightarrow (cons x y) ] + +\lambda x:False. + [\lambda h:False. True] + match x:False with [] + diff --git a/helm/software/components/cic_proof_checking/.depend b/helm/software/components/cic_proof_checking/.depend new file mode 100644 index 000000000..06b9188a0 --- /dev/null +++ b/helm/software/components/cic_proof_checking/.depend @@ -0,0 +1,24 @@ +cicLogger.cmo: cicLogger.cmi +cicLogger.cmx: cicLogger.cmi +cicEnvironment.cmo: cicEnvironment.cmi +cicEnvironment.cmx: cicEnvironment.cmi +cicPp.cmo: cicEnvironment.cmi cicPp.cmi +cicPp.cmx: cicEnvironment.cmx cicPp.cmi +cicUnivUtils.cmo: cicEnvironment.cmi cicUnivUtils.cmi +cicUnivUtils.cmx: cicEnvironment.cmx cicUnivUtils.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 +cicReduction.cmo: cicSubstitution.cmi cicPp.cmi cicEnvironment.cmi \ + cicReduction.cmi +cicReduction.cmx: cicSubstitution.cmx cicPp.cmx cicEnvironment.cmx \ + cicReduction.cmi +cicTypeChecker.cmo: cicUnivUtils.cmi cicSubstitution.cmi cicReduction.cmi \ + cicPp.cmi cicLogger.cmi cicEnvironment.cmi cicTypeChecker.cmi +cicTypeChecker.cmx: cicUnivUtils.cmx cicSubstitution.cmx cicReduction.cmx \ + cicPp.cmx cicLogger.cmx cicEnvironment.cmx cicTypeChecker.cmi +freshNamesGenerator.cmo: cicTypeChecker.cmi cicSubstitution.cmi \ + freshNamesGenerator.cmi +freshNamesGenerator.cmx: cicTypeChecker.cmx cicSubstitution.cmx \ + freshNamesGenerator.cmi diff --git a/helm/software/components/cic_proof_checking/Makefile b/helm/software/components/cic_proof_checking/Makefile new file mode 100644 index 000000000..8e2f99a15 --- /dev/null +++ b/helm/software/components/cic_proof_checking/Makefile @@ -0,0 +1,43 @@ + +PACKAGE = cic_proof_checking +PREDICATES = + +REDUCTION_IMPLEMENTATION = cicReductionMachine.ml + +INTERFACE_FILES = \ + cicLogger.mli \ + cicEnvironment.mli \ + cicPp.mli \ + cicUnivUtils.mli \ + cicSubstitution.mli \ + cicMiniReduction.mli \ + cicReduction.mli \ + cicTypeChecker.mli \ + freshNamesGenerator.mli \ + $(NULL) +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +# Metadata tools only need zeta-reduction +EXTRA_OBJECTS_TO_INSTALL = \ + cicSubstitution.cmo cicSubstitution.cmx cicSubstitution.o \ + cicMiniReduction.cmo cicMiniReduction.cmx cicMiniReduction.o +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common + +cicReduction.cmo: OCAMLOPTIONS+=-rectypes +cicReduction.cmx: OCAMLOPTIONS+=-rectypes + +all: all_utilities +opt: opt_utilities + +all_utilities: + @$(MAKE) -C utilities/ all +opt_utilities: + @$(MAKE) -C utilities/ opt + +clean: clean_utilities +clean_utilities: + @$(MAKE) -C utilities/ clean + diff --git a/helm/software/components/cic_proof_checking/cicEnvironment.ml b/helm/software/components/cic_proof_checking/cicEnvironment.ml new file mode 100644 index 000000000..1f6789e76 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicEnvironment.ml @@ -0,0 +1,545 @@ +(* 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 *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a trival cache system (an hash-table) for cic *) +(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +(* ************************************************************************** * + CicEnvironment SETTINGS (trust and clean_tmp) + * ************************************************************************** *) + +let cleanup_tmp = true;; +let trust = ref (fun _ -> true);; +let set_trust f = trust := f +let trust_obj uri = !trust uri +let debug_print = fun x -> prerr_endline (Lazy.force x) + +(* ************************************************************************** * + TYPES + * ************************************************************************** *) + +type type_checked_obj = + CheckedObj of (Cic.obj * CicUniv.universe_graph) (* cooked obj *) + | UncheckedObj of Cic.obj (* uncooked obj to proof-check *) +;; + +exception AlreadyCooked of string;; +exception CircularDependency of string Lazy.t;; +exception CouldNotFreeze of string;; +exception CouldNotUnfreeze of string;; +exception Object_not_found of UriManager.uri;; + + +(* ************************************************************************** * + HERE STARTS THE CACHE MODULE + * ************************************************************************** *) + +(* I think this should be the right place to implement mecanisms and + * invasriants + *) + +(* Cache that uses == instead of = for testing equality *) +(* Invariant: an object is always in at most one of the *) +(* following states: unchecked, frozen and cooked. *) +module Cache : + sig + val find_or_add_to_unchecked : + UriManager.uri -> + get_object_to_add: + (UriManager.uri -> + Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option) -> + Cic.obj * CicUniv.universe_graph * CicUniv.universe list + val can_be_cooked: + UriManager.uri -> bool + val unchecked_to_frozen : + UriManager.uri -> unit + val frozen_to_cooked : + uri:UriManager.uri -> unit + val hack_univ: + UriManager.uri -> CicUniv.universe_graph * CicUniv.universe list -> unit + val find_cooked : + key:UriManager.uri -> + Cic.obj * CicUniv.universe_graph * CicUniv.universe list + val add_cooked : + key:UriManager.uri -> + (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit + val remove: UriManager.uri -> unit + val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit + val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit + val empty : unit -> unit + val is_in_frozen: UriManager.uri -> bool + val is_in_unchecked: UriManager.uri -> bool + val is_in_cooked: UriManager.uri -> bool + val list_all_cooked_uris: unit -> UriManager.uri list + end += + struct + (************************************************************************* + TASSI: invariant + The cacheOfCookedObjects will contain only objects with a valid universe + graph. valid means that not None (used if there is no universe file + in the universe generation phase). + **************************************************************************) + + (* DATA: the data structure that implements the CACHE *) + module HashedType = + struct + type t = UriManager.uri + let equal = UriManager.eq + let hash = Hashtbl.hash + end + ;; + + module HT = Hashtbl.Make(HashedType);; + + let cacheOfCookedObjects = HT.create 1009;; + + (* DATA: The parking lists + * the lists elements are (uri * (obj * universe_graph option)) + * ( u, ( o, None )) means that the object has no universes file, this + * should happen only in the universe generation phase. + * FIXME: if the universe generation is integrated in the library + * exportation phase, the 'option' MUST be removed. + * ( u, ( o, Some g)) means that the object has a universes file, + * the usual case. + *) + + (* frozen is used to detect circular dependency. *) + let frozen_list = ref [];; + (* unchecked is used to store objects just fetched, nothing more. *) + let unchecked_list = ref [];; + + let empty () = + HT.clear cacheOfCookedObjects; + unchecked_list := [] ; + frozen_list := [] + ;; + + (* FIX: universe stuff?? *) + let dump_to_channel ?(callback = ignore) oc = + HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) + cacheOfCookedObjects; + Marshal.to_channel oc cacheOfCookedObjects [] + ;; + + (* FIX: universes stuff?? *) + let restore_from_channel ?(callback = ignore) ic = + let restored = Marshal.from_channel ic in + (* FIXME: should this empty clean the frozen and unchecked? + * if not, the only-one-empty-end-not-3 patch is wrong + *) + empty (); + HT.iter + (fun k (v,u,l) -> + callback (UriManager.string_of_uri k); + let reconsed_entry = + CicUtil.rehash_obj v, + CicUniv.recons_graph u, + List.map CicUniv.recons_univ l + in + HT.add cacheOfCookedObjects + (UriManager.uri_of_string (UriManager.string_of_uri k)) + reconsed_entry) + restored + ;; + + + let is_in_frozen uri = + List.mem_assoc uri !frozen_list + ;; + + let is_in_unchecked uri = + List.mem_assoc uri !unchecked_list + ;; + + let is_in_cooked uri = + HT.mem cacheOfCookedObjects uri + ;; + + + (******************************************************************* + TASSI: invariant + we need, in the universe generation phase, to traverse objects + that are not yet committed, so we search them in the frozen list. + Only uncommitted objects without a universe file (see the assertion) + can be searched with method + *******************************************************************) + + let find_or_add_to_unchecked uri ~get_object_to_add = + try + let o,g_and_l = List.assq uri !unchecked_list in + match g_and_l with + (* FIXME: we accept both cases, as at the end of this function + * maybe the None universe outside the cache module should be + * avoided elsewhere. + * + * another thing that should be removed if univ generation phase + * and lib exportation are unified. + *) + | None -> o,CicUniv.empty_ugraph,[] + | Some (g,l) -> o,g,l + with + Not_found -> + if List.mem_assq uri !frozen_list then + (* CIRCULAR DEPENDENCY DETECTED, print the error and raise *) + begin + print_endline "\nCircularDependency!\nfrozen list: \n"; + List.iter ( + fun (u,(_,o)) -> + let su = UriManager.string_of_uri u in + let univ = if o = None then "NO_UNIV" else "" in + print_endline (su^" "^univ)) + !frozen_list; + raise (CircularDependency (lazy (UriManager.string_of_uri uri))) + end + else + if HT.mem cacheOfCookedObjects uri then + (* DOUBLE COOK DETECTED, raise the exception *) + raise (AlreadyCooked (UriManager.string_of_uri uri)) + else + (* OK, it is not already frozen nor cooked *) + let obj,ugraph_and_univlist = get_object_to_add uri in + let ugraph_real, univlist_real = + match ugraph_and_univlist with + (* FIXME: not sure it is OK*) + None -> CicUniv.empty_ugraph, [] + | Some ((g,l) as g_and_l) -> g_and_l + in + unchecked_list := + (uri,(obj,ugraph_and_univlist))::!unchecked_list ; + obj, ugraph_real, univlist_real + ;; + + let unchecked_to_frozen uri = + try + let obj,ugraph_and_univlist = List.assq uri !unchecked_list in + unchecked_list := List.remove_assq uri !unchecked_list ; + frozen_list := (uri,(obj,ugraph_and_univlist))::!frozen_list + with + Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri)) + ;; + + + (************************************************************ + TASSI: invariant + only object with a valid universe graph can be committed + + this should disappear if the universe generation phase and the + library exportation are unified. + *************************************************************) + let frozen_to_cooked ~uri = + try + let obj,ugraph_and_univlist = List.assq uri !frozen_list in + match ugraph_and_univlist with + | None -> assert false (* only NON dummy universes can be committed *) + | Some (g,l) -> + CicUniv.assert_univs_have_uri g l; + frozen_list := List.remove_assq uri !frozen_list ; + HT.add cacheOfCookedObjects uri (obj,g,l) + with + Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri)) + ;; + + let can_be_cooked uri = + try + let obj,ugraph_and_univlist = List.assq uri !frozen_list in + (* FIXME: another thing to remove if univ generation phase and lib + * exportation are unified. + *) + match ugraph_and_univlist with + None -> false + | Some _ -> true + with + Not_found -> false + ;; + + (* this function injects a real universe graph in a (uri, (obj, None)) + * element of the frozen list. + * + * FIXME: another thing to remove if univ generation phase and lib + * exportation are unified. + *) + let hack_univ uri (real_ugraph, real_univlist) = + try + let o,ugraph_and_univlist = List.assq uri !frozen_list in + match ugraph_and_univlist with + None -> + frozen_list := List.remove_assoc uri !frozen_list; + frozen_list := + (uri,(o,Some (real_ugraph, real_univlist)))::!frozen_list; + | Some g -> + debug_print (lazy ( + "You are probably hacking an object already hacked or an"^ + " object that has the universe file but is not"^ + " yet committed.")); + assert false + with + Not_found -> + debug_print (lazy ( + "You are hacking an object that is not in the"^ + " frozen_list, this means you are probably generating an"^ + " universe file for an object that already"^ + " as an universe file")); + assert false + ;; + + let find_cooked ~key:uri = HT.find cacheOfCookedObjects uri ;; + + let add_cooked ~key:uri (obj,ugraph,univlist) = + HT.add cacheOfCookedObjects uri (obj,ugraph,univlist) + ;; + + (* invariant + * + * an object can be romeved from the cache only if we are not typechecking + * something. this means check and frozen must be empty. + *) + let remove uri = + if !frozen_list <> [] then + failwith "CicEnvironment.remove while type checking" + else + begin + HT.remove cacheOfCookedObjects uri; + unchecked_list := + List.filter (fun (uri',_) -> not (UriManager.eq uri uri')) !unchecked_list + end + ;; + + let list_all_cooked_uris () = + HT.fold (fun u _ l -> u::l) cacheOfCookedObjects [] + ;; + + end +;; + +(* ************************************************************************ + HERE ENDS THE CACHE MODULE + * ************************************************************************ *) + +(* exported cache functions *) +let dump_to_channel = Cache.dump_to_channel;; +let restore_from_channel = Cache.restore_from_channel;; +let empty = Cache.empty;; + +let total_parsing_time = ref 0.0 + +let get_object_to_add uri = + try + let filename = Http_getter.getxml' uri in + let bodyfilename = + match UriManager.bodyuri_of_uri uri with + None -> None + | Some bodyuri -> + if Http_getter.exists' bodyuri then + Some (Http_getter.getxml' bodyuri) + else + None + in + let obj = + try + let time = Unix.gettimeofday() in + let rc = CicParser.obj_of_xml uri filename bodyfilename in + total_parsing_time := + !total_parsing_time +. ((Unix.gettimeofday()) -. time ); + rc + with exn -> + (match exn with + | CicParser.Getter_failure ("key_not_found", uri) -> + raise (Object_not_found (UriManager.uri_of_string uri)) + | _ -> raise exn) + in + let ugraph_and_univlist,filename_univ = + try + let filename_univ = + let univ_uri = UriManager.univgraphuri_of_uri uri in + Http_getter.getxml' univ_uri + in + Some (CicUniv.ugraph_and_univlist_of_xml filename_univ), + Some filename_univ + with + | Http_getter_types.Key_not_found _ + | Http_getter_types.Unresolvable_URI _ -> + debug_print (lazy ( + "WE HAVE NO UNIVERSE FILE FOR " ^ (UriManager.string_of_uri uri))); + (* WE SHOULD FAIL (or return None, None *) + Some (CicUniv.empty_ugraph, []), None + in + obj, ugraph_and_univlist + with Http_getter_types.Key_not_found _ -> raise (Object_not_found uri) +;; + +(* this is the function to fetch the object in the unchecked list and + * nothing more (except returning it) + *) +let find_or_add_to_unchecked uri = + Cache.find_or_add_to_unchecked uri ~get_object_to_add + +(* set_type_checking_info uri *) +(* must be called once the type-checking of uri is finished *) +(* The object whose uri is uri is unfreezed *) +(* *) +(* the replacement ugraph must be the one returned by the *) +(* typechecker, restricted with the CicUnivUtils.clean_and_fill *) +let set_type_checking_info ?(replace_ugraph_and_univlist=None) uri = +(* + if not (Cache.can_be_cooked uri) && replace_ugraph <> None then begin + debug_print (lazy ( + "?replace_ugraph must be None if you are not committing an "^ + "object that has a universe graph associated "^ + "(can happen only in the fase of universes graphs generation).")); + assert false + else +*) + match Cache.can_be_cooked uri, replace_ugraph_and_univlist with + | true, Some _ + | false, None -> + debug_print (lazy ( + "?replace_ugraph must be (Some ugraph) when committing an object that "^ + "has no associated universe graph. If this is in make_univ phase you "^ + "should drop this exception and let univ_make commit thi object with "^ + "proper arguments")); + assert false + | _ -> + (match replace_ugraph_and_univlist with + | None -> () + | Some g_and_l -> Cache.hack_univ uri g_and_l); + Cache.frozen_to_cooked uri +;; + +(* fetch, unfreeze and commit an uri to the cacheOfCookedObjects and + * return the object,ugraph + *) +let add_trusted_uri_to_cache uri = + let _ = find_or_add_to_unchecked uri in + Cache.unchecked_to_frozen uri; + set_type_checking_info uri; + try + Cache.find_cooked uri + with Not_found -> assert false +;; + +(* get the uri, if we trust it will be added to the cacheOfCookedObjects *) +let get_cooked_obj_with_univlist ?(trust=true) base_ugraph uri = + try + (* the object should be in the cacheOfCookedObjects *) + let o,u,l = Cache.find_cooked uri in + o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l + with Not_found -> + (* this should be an error case, but if we trust the uri... *) + if trust && trust_obj uri then + (* trusting means that we will fetch cook it on the fly *) + let o,u,l = add_trusted_uri_to_cache uri in + o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l + else + (* we don't trust the uri, so we fail *) + begin + debug_print (lazy ("CACHE MISS: " ^ (UriManager.string_of_uri uri))); + raise Not_found + end + +let get_cooked_obj ?trust base_ugraph uri = + let o,g,_ = get_cooked_obj_with_univlist ?trust base_ugraph uri in + o,g + +(* This has not the old semantic :( but is what the name suggests + * + * let is_type_checked ?(trust=true) uri = + * try + * let _ = Cache.find_cooked uri in + * true + * with + * Not_found -> + * trust && trust_obj uri + * ;; + * + * as the get_cooked_obj but returns a type_checked_obj + * + *) +let is_type_checked ?(trust=true) base_ugraph uri = + try + let o,u,_ = Cache.find_cooked uri in + CheckedObj (o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))) + with Not_found -> + (* this should return UncheckedObj *) + if trust && trust_obj uri then + (* trusting means that we will fetch cook it on the fly *) + let o,u,_ = add_trusted_uri_to_cache uri in + CheckedObj ( o, CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)) + else + let o,u,_ = find_or_add_to_unchecked uri in + Cache.unchecked_to_frozen uri; + UncheckedObj o +;; + +(* as the get cooked, but if not present the object is only fetched, + * not unfreezed and committed + *) +let get_obj base_ugraph uri = + try + (* the object should be in the cacheOfCookedObjects *) + let o,u,_ = Cache.find_cooked uri in + o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)) + with Not_found -> + (* this should be an error case, but if we trust the uri... *) + let o,u,_ = find_or_add_to_unchecked uri in + o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)) +;; + +let in_cache uri = + Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri + +let add_type_checked_obj uri (obj,ugraph,univlist) = + Cache.add_cooked ~key:uri (obj,ugraph,univlist) + +let in_library uri = in_cache uri || Http_getter.exists' uri + +let remove_obj = Cache.remove + +let list_uri () = + Cache.list_all_cooked_uris () +;; + +let list_obj () = + try + List.map (fun u -> + let o,ug = get_obj CicUniv.empty_ugraph u in + (u,o,ug)) + (list_uri ()) + with + Not_found -> + debug_print (lazy "Who has removed the uri in the meanwhile?"); + raise Not_found +;; diff --git a/helm/software/components/cic_proof_checking/cicEnvironment.mli b/helm/software/components/cic_proof_checking/cicEnvironment.mli new file mode 100644 index 000000000..55566a614 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicEnvironment.mli @@ -0,0 +1,136 @@ +(* 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 *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a trival cache system (an hash-table) for cic *) +(* ^^^^^^ *) +(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) +(* *) +(****************************************************************************) + +exception CircularDependency of string Lazy.t;; +exception Object_not_found of UriManager.uri;; + +(* as the get cooked, but if not present the object is only fetched, + * not unfreezed and committed + *) +val get_obj : + CicUniv.universe_graph -> UriManager.uri -> + Cic.obj * CicUniv.universe_graph + +type type_checked_obj = + CheckedObj of (Cic.obj * CicUniv.universe_graph) (* cooked obj *) + | UncheckedObj of Cic.obj (* uncooked obj *) + +(* + * I think this should be the real semantic: + * + * val is_type_checked: + * ?trust:bool -> UriManager.uri -> bool + * + * but the old semantic is similar to get_cooked_obj, but + * returns an unchecked object intead of a Not_found + *) +val is_type_checked : + ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> + type_checked_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 and won't be type-checked *) +(* again in the future (is_type_checked will return true) *) +(* *) +(* Since the universes are not exported directly, but generated *) +(* typecheking the library, we can't find them in the library as we *) +(* do for the types. This means that when we commit uris during *) +(* univ generation we can't associate the uri with the universe graph *) +(* we find in the library, we have to calculate it and then inject it *) +(* in the cacke. This is an orrible backdoor used by univ_maker. *) +(* see the .ml file for some reassuring invariants *) +(* WARNING: THIS FUNCTION MUST BE CALLED ONLY BY CicTypeChecker *) +val set_type_checking_info : + ?replace_ugraph_and_univlist: + ((CicUniv.universe_graph * CicUniv.universe list) option) -> + UriManager.uri -> unit + +(* this function is called by CicTypeChecker.typecheck_obj to add to the *) +(* environment a new well typed object that is not yet in the library *) +(* WARNING: THIS FUNCTION MUST BE CALLED ONLY BY CicTypeChecker *) +val add_type_checked_obj : + UriManager.uri -> + (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit + + (** remove a type checked object + * @raise Object_not_found when given term is not in the environment + * @raise Failure when remove_term is invoked while type checking *) +val remove_obj: UriManager.uri -> unit + +(* 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 -> CicUniv.universe_graph -> UriManager.uri -> + Cic.obj * CicUniv.universe_graph + +(* get_cooked_obj_with_univlist ~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_with_univlist : + ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> + Cic.obj * CicUniv.universe_graph * CicUniv.universe list + +(* FUNCTIONS USED ONLY IN THE TOPLEVEL/PROOF-ENGINE *) + +(* (de)serialization *) +val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit +val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit +val empty : unit -> unit + +(** Set trust function. Per default this function is set to (fun _ -> true) *) +val set_trust: (UriManager.uri -> bool) -> unit + + (** @return true for objects currently cooked/frozend/unchecked, false + * otherwise (i.e. objects already parsed from XML) *) +val in_cache : UriManager.uri -> bool + +(* to debug the matitac batch compiler *) +val list_obj: unit -> (UriManager.uri * Cic.obj * CicUniv.universe_graph) list +val list_uri: unit -> UriManager.uri list + + (** @return true for objects available in the library *) +val in_library: UriManager.uri -> bool + + (** total parsing time, only to benchmark the parser *) +val total_parsing_time: float ref + +(* EOF *) diff --git a/helm/software/components/cic_proof_checking/cicLogger.ml b/helm/software/components/cic_proof_checking/cicLogger.ml new file mode 100644 index 000000000..5921c61b0 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicLogger.ml @@ -0,0 +1,62 @@ +(* 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/. + *) + +(* $Id$ *) + +type msg = + [ `Start_type_checking of UriManager.uri + | `Type_checking_completed of UriManager.uri + | `Trusting of UriManager.uri + ] + +let log ?(level = 1) = + let module U = UriManager in + function + | `Start_type_checking uri -> + HelmLogger.log (`Msg (`DIV (level, None, `T + ("Type-Checking of " ^ (U.string_of_uri uri) ^ " started")))) + | `Type_checking_completed uri -> + HelmLogger.log (`Msg (`DIV (level, Some "green", `T + ("Type-Checking of " ^ (U.string_of_uri uri) ^ " completed")))) + | `Trusting uri -> + HelmLogger.log (`Msg (`DIV (level, Some "blue", `T + ((U.string_of_uri uri) ^ " is trusted.")))) + +class logger = + object + val mutable level = 0 (* indentation level *) + method log (msg: msg) = + match msg with + | `Start_type_checking _ -> + level <- level + 1; + log ~level msg + | `Type_checking_completed _ -> + log ~level msg; + level <- level - 1; + | _ -> log ~level msg + end + +let log msg = log ~level:1 msg + diff --git a/helm/software/components/cic_proof_checking/cicLogger.mli b/helm/software/components/cic_proof_checking/cicLogger.mli new file mode 100644 index 000000000..408bc8879 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicLogger.mli @@ -0,0 +1,42 @@ +(* 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/. + *) + +type msg = + [ `Start_type_checking of UriManager.uri + | `Type_checking_completed of UriManager.uri + | `Trusting of UriManager.uri + ] + + (** Stateless logging. Each message is logged with indentation level 1 *) +val log: msg -> unit + + (** Stateful logging. Each `Start_type_checing message increase the + * indentation level by 1, each `Type_checking_completed message decrease it by + * the same amount. *) +class logger: + object + method log: msg -> unit + end + diff --git a/helm/software/components/cic_proof_checking/cicMiniReduction.ml b/helm/software/components/cic_proof_checking/cicMiniReduction.ml new file mode 100644 index 000000000..5c88713c5 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicMiniReduction.ml @@ -0,0 +1,76 @@ +(* 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/. + *) + +(* $Id$ *) + +let rec letin_nf = + let module C = Cic in + function + C.Rel _ 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.Cast (te,ty) -> C.Cast (letin_nf te, letin_nf ty) + | C.Prod (n,s,t) -> C.Prod (n, letin_nf s, letin_nf 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 (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 + (fun (name,i,ty,bo) -> (name, i, letin_nf ty, letin_nf bo)) + fl + in + C.Fix (i, substitutedfl) + | C.CoFix (i,fl) -> + let substitutedfl = + List.map + (fun (name,ty,bo) -> (name, letin_nf ty, letin_nf bo)) + fl + in + C.CoFix (i, substitutedfl) +;; diff --git a/helm/software/components/cic_proof_checking/cicMiniReduction.mli b/helm/software/components/cic_proof_checking/cicMiniReduction.mli new file mode 100644 index 000000000..c923c6acf --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicMiniReduction.mli @@ -0,0 +1,26 @@ +(* 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 letin_nf : Cic.term -> Cic.term diff --git a/helm/software/components/cic_proof_checking/cicPp.ml b/helm/software/components/cic_proof_checking/cicPp.ml new file mode 100644 index 000000000..954134584 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicPp.ml @@ -0,0 +1,480 @@ +(* 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 *) +(* *) +(* This module implements a very simple Coq-like pretty printer that, given *) +(* an object of cic (internal representation) returns a string describing *) +(* the object in a syntax similar to that of coq *) +(* *) +(* It also contains the utility functions to check a name w.r.t the Matita *) +(* naming policy *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +exception CicPpInternalError;; +exception NotEnoughElements;; + +(* Utility functions *) + +let ppname = + function + Cic.Name s -> s + | Cic.Anonymous -> "_" +;; + +(* get_nth l n returns the nth element of the list l if it exists or *) +(* raises NotEnoughElements if l has less than n elements *) +let rec get_nth l n = + match (n,l) with + (1, he::_) -> he + | (n, he::tail) when n > 1 -> get_nth tail (n-1) + | (_,_) -> raise NotEnoughElements +;; + +(* pp t l *) +(* pretty-prints a term t of cic in an environment l where l is a list of *) +(* identifier names used to resolve DeBrujin indexes. The head of l is the *) +(* name associated to the greatest DeBrujin index in t *) +let rec pp t l = + let module C = Cic in + match t with + C.Rel n -> + begin + try + (match get_nth l n with + Some (C.Name s) -> s + | Some C.Anonymous -> "__" ^ string_of_int n + | None -> "_hidden_" ^ string_of_int n + ) + with + NotEnoughElements -> string_of_int (List.length l - n) + end + | 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 " ; " + (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^ + "]" + | C.Sort s -> + (match s with + C.Prop -> "Prop" + | C.Set -> "Set" + | C.Type _ -> "Type" + (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*) + | C.CProp -> "CProp" + ) + | C.Implicit (Some `Hole) -> "%" + | C.Implicit _ -> "?" + | C.Prod (b,s,t) -> + (match b with + C.Name n -> "(" ^ n ^ ":" ^ 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 ^ ":" ^ pp t l ^ ")" + | C.Lambda (b,s,t) -> + "(\\lambda " ^ ppname b ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")" + | C.LetIn (b,s,t) -> + "[" ^ ppname b ^ ":=" ^ pp s l ^ "]" ^ pp t ((Some b)::l) + | C.Appl li -> + "(" ^ + (List.fold_right + (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i) + li "" + ) ^ ")" + | 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 fst(CicEnvironment.get_obj CicUniv.empty_ugraph 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 + _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1) + ) + | C.MutConstruct (uri,n1,n2,exp_named_subst) -> + (try + match fst(CicEnvironment.get_obj CicUniv.empty_ugraph 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 + _ -> + UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^ + string_of_int n2 + ) + | C.MutCase (uri,n1,ty,te,patterns) -> + let connames = + (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,_,cons) = get_nth dl (n1+1) in + List.map (fun (id,_) -> id) cons + | _ -> raise CicPpInternalError + ) + in + let connames_and_patterns = + let rec combine = + function + [],[] -> [] + | [],l -> List.map (fun x -> "???",Some x) l + | l,[] -> List.map (fun x -> x,None) l + | x::tlx,y::tly -> (x,Some y)::(combine (tlx,tly)) + in + combine (connames,patterns) + in + "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^ + List.fold_right + (fun (x,y) i -> "\n " ^ x ^ " => " ^ + (match y with None -> "" | Some y -> pp y l) ^ i) + connames_and_patterns "" ^ + "\nend" + | C.Fix (no, funs) -> + let snames = List.map (fun (name,_,_,_) -> name) funs in + let names = + List.rev (List.map (function name -> Some (C.Name name)) snames) + in + "\nFix " ^ get_nth snames (no + 1) ^ " {" ^ + List.fold_right + (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^ + " : " ^ pp ty l ^ " := \n" ^ + pp bo (names@l) ^ i) + funs "" ^ + "}\n" + | C.CoFix (no,funs) -> + let snames = List.map (fun (name,_,_) -> name) funs in + let names = + List.rev (List.map (function name -> Some (C.Name name)) snames) + in + "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^ + List.fold_right + (fun (name,ty,bo) i -> "\n" ^ name ^ + " : " ^ pp ty l ^ " := \n" ^ + pp bo (names@l) ^ i) + funs "" ^ + "}\n" +and pp_exp_named_subst exp_named_subst l = + if exp_named_subst = [] then "" else + "\\subst[" ^ + String.concat " ; " ( + List.map + (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp t l) + exp_named_subst + ) ^ "]" +;; + +let ppterm t = + pp t [] +;; + +(* 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 ^ ": " ^ + pp arity [] ^ " =\n " ^ + List.fold_right + (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^ + (if i = "" then "\n" else "\n | ") ^ i) + cons "" +;; + +let ppcontext ?(sep = "\n") context = + let separate s = if s = "" then "" else s ^ sep in + fst (List.fold_right + (fun context_entry (i,name_context) -> + match context_entry with + Some (n,Cic.Decl t) -> + Printf.sprintf "%s%s : %s" (separate i) (ppname n) + (pp t name_context), (Some n)::name_context + | Some (n,Cic.Def (bo,ty)) -> + Printf.sprintf "%s%s : %s := %s" (separate i) (ppname n) + (match ty with + None -> "_" + | Some ty -> pp ty name_context) + (pp bo name_context), (Some n)::name_context + | None -> + Printf.sprintf "%s_ :? _" (separate i), None::name_context + ) context ("",[])) + +(* ppobj obj returns a string with describing the cic object obj in a syntax *) +(* similar to the one used by Coq *) +let ppobj obj = + let module C = Cic in + let module U = UriManager in + match obj with + 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 -> + let conjectures',name_context = + List.fold_right + (fun context_entry (i,name_context) -> + (match context_entry with + Some (n,C.Decl at) -> + (separate i) ^ + ppname n ^ ":" ^ pp at name_context ^ " ", + (Some n)::name_context + | Some (n,C.Def (at,None)) -> + (separate i) ^ + ppname n ^ ":= " ^ pp at name_context ^ " ", + (Some n)::name_context + | None -> + (separate i) ^ "_ :? _ ", None::name_context + | _ -> assert false) + ) context ("",[]) + in + conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^ + pp t name_context ^ "\n" ^ i + ) conjectures "" ^ + "\n" ^ pp value [] ^ " : " ^ pp ty [] + | C.InductiveDefinition (l, params, nparams, _) -> + "Parameters = " ^ + 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 "" +;; + +let ppsort = function + | Cic.Prop -> "Prop" + | Cic.Set -> "Set" + | Cic.Type _ -> "Type" + | Cic.CProp -> "CProp" + + +(* MATITA NAMING CONVENTION *) + +let is_prefix prefix string = + let len = String.length prefix in + let len1 = String.length string in + if len <= len1 then + begin + let head = String.sub string 0 len in + if + (String.compare (String.lowercase head) (String.lowercase prefix)=0) then + begin + let diff = len1-len in + let tail = String.sub string len diff in + if ((diff > 0) && (String.rcontains_from tail 0 '_')) then + Some (String.sub tail 1 (diff-1)) + else Some tail + end + else None + end + else None + +let remove_prefix prefix (last,string) = + if prefix="append" then + begin + prerr_endline last; + prerr_endline string; + end; + if string = "" then (last,string) + else + match is_prefix prefix string with + None -> + if last <> "" then + match is_prefix last prefix with + None -> (last,string) + | Some _ -> + (match is_prefix prefix (last^string) with + None -> (last,string) + | Some tail -> (prefix,tail)) + else (last,string) + | Some tail -> (prefix, tail) + +let legal_suffix string = + if string = "" then true else + begin + let legal_s = Str.regexp "_?\\([0-9]+\\|r\\|l\\|'\\|\"\\)" in + (Str.string_match legal_s string 0) && (Str.matched_string string = string) + end + +(** check if a prefix of string_name is legal for term and returns the tail. + chec_rec cannot fail: at worst it return string_name. + The algorithm is greedy, but last contains the last name matched, providing + a one slot buffer. + string_name is here a pair (last,string_name).*) + +let rec check_rec ctx string_name = + function + | Cic.Rel m -> + (match List.nth ctx (m-1) with + Cic.Name name -> + remove_prefix name string_name + | Cic.Anonymous -> string_name) + | Cic.Meta _ -> string_name + | Cic.Sort sort -> remove_prefix (ppsort sort) string_name + | Cic.Implicit _ -> string_name + | Cic.Cast (te,ty) -> check_rec ctx string_name te + | Cic.Prod (name,so,dest) -> + let l_string_name = check_rec ctx string_name so in + check_rec (name::ctx) string_name dest + | Cic.Lambda (name,so,dest) -> + let string_name = + match name with + Cic.Anonymous -> string_name + | Cic.Name name -> remove_prefix name string_name in + let l_string_name = check_rec ctx string_name so in + check_rec (name::ctx) l_string_name dest + | Cic.LetIn (name,so,dest) -> + let string_name = check_rec ctx string_name so in + check_rec (name::ctx) string_name dest + | Cic.Appl l -> + List.fold_left (check_rec ctx) string_name l + | Cic.Var (uri,exp_named_subst) -> + let name = UriManager.name_of_uri uri in + remove_prefix name string_name + | Cic.Const (uri,exp_named_subst) -> + let name = UriManager.name_of_uri uri in + remove_prefix name string_name + | Cic.MutInd (uri,_,exp_named_subst) -> + let name = UriManager.name_of_uri uri in + remove_prefix name string_name + | Cic.MutConstruct (uri,n,m,exp_named_subst) -> + let name = + (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + Cic.InductiveDefinition (dl,_,_,_) -> + let (_,_,_,cons) = get_nth dl (n+1) in + let (id,_) = get_nth cons m in + id + | _ -> assert false) in + remove_prefix name string_name + | Cic.MutCase (_,_,_,te,pl) -> + let strig_name = remove_prefix "match" string_name in + let string_name = check_rec ctx string_name te in + List.fold_right (fun t s -> check_rec ctx s t) pl string_name + | Cic.Fix (_,fl) -> + let strig_name = remove_prefix "fix" string_name in + let names = List.map (fun (name,_,_,_) -> name) fl in + let onames = + List.rev (List.map (function name -> Cic.Name name) names) + in + List.fold_right + (fun (_,_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name + | Cic.CoFix (_,fl) -> + let strig_name = remove_prefix "cofix" string_name in + let names = List.map (fun (name,_,_) -> name) fl in + let onames = + List.rev (List.map (function name -> Cic.Name name) names) + in + List.fold_right + (fun (_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name + +let check_name ?(allow_suffix=false) ctx name term = + let (_,tail) = check_rec ctx ("",name) term in + if (not allow_suffix) then (String.length tail = 0) + else legal_suffix tail + +let check_elim ctx conclusion_name = + let elim = Str.regexp "_elim\\|_case" in + if (Str.string_match elim conclusion_name 0) then + let len = String.length conclusion_name in + let tail = String.sub conclusion_name 5 (len-5) in + legal_suffix tail + else false + +let rec check_names ctx hyp_names conclusion_name t = + match t with + | Cic.Prod (name,s,t) -> + (match hyp_names with + [] -> check_names (name::ctx) hyp_names conclusion_name t + | hd::tl -> + if check_name ctx hd s then + check_names (name::ctx) tl conclusion_name t + else + check_names (name::ctx) hyp_names conclusion_name t) + | Cic.Appl ((Cic.Rel n)::args) -> + (match hyp_names with + | [] -> + (check_name ~allow_suffix:true ctx conclusion_name t) || + (check_elim ctx conclusion_name) + | [what_to_elim] -> + (* what to elim could be an argument + of the predicate: e.g. leb_elim *) + let (last,tail) = + List.fold_left (check_rec ctx) ("",what_to_elim) args in + (tail = "" && check_elim ctx conclusion_name) + | _ -> false) + | Cic.MutCase (_,_,Cic.Lambda(name,so,ty),te,_) -> + (match hyp_names with + | [] -> + (match is_prefix "match" conclusion_name with + None -> check_name ~allow_suffix:true ctx conclusion_name t + | Some tail -> check_name ~allow_suffix:true ctx tail t) + | [what_to_match] -> + (* what to match could be the term te or its type so; in this case the + conclusion name should match ty *) + check_name ~allow_suffix:true (name::ctx) conclusion_name ty && + (check_name ctx what_to_match te || check_name ctx what_to_match so) + | _ -> false) + | _ -> + hyp_names=[] && check_name ~allow_suffix:true ctx conclusion_name t + +let check name term = +(* prerr_endline name; + prerr_endline (ppterm term); *) + let names = Str.split (Str.regexp_string "_to_") name in + let hyp_names,conclusion_name = + match List.rev names with + [] -> assert false + | hd::tl -> + let elim = Str.regexp "_elim\\|_case" in + let len = String.length hd in + try + let pos = Str.search_backward elim hd len in + let hyp = String.sub hd 0 pos in + let concl = String.sub hd pos (len-pos) in + List.rev (hyp::tl),concl + with Not_found -> (List.rev tl),hd in + check_names [] hyp_names conclusion_name term +;; + + diff --git a/helm/software/components/cic_proof_checking/cicPp.mli b/helm/software/components/cic_proof_checking/cicPp.mli new file mode 100644 index 000000000..e84ae4fed --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicPp.mli @@ -0,0 +1,55 @@ +(* 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 *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a very simple Coq-like pretty printer that, given *) +(* an object of cic (internal representation) returns a string describing the*) +(* object in a syntax similar to that of coq *) +(* *) +(*****************************************************************************) + +(* ppobj obj returns a string with describing the cic object obj in a syntax*) +(* similar to the one used by Coq *) +val ppobj : Cic.obj -> string + +val ppterm : Cic.term -> string + +val ppcontext : ?sep:string -> Cic.context -> string + +(* Required only by the topLevel. It is the generalization of ppterm to *) +(* work with environments. *) +val pp : Cic.term -> (Cic.name option) list -> string + +val ppname : Cic.name -> string + +val ppsort: Cic.sort -> string + +val check: string -> Cic.term -> bool diff --git a/helm/software/components/cic_proof_checking/cicReduction.ml b/helm/software/components/cic_proof_checking/cicReduction.ml new file mode 100644 index 000000000..56e98775f --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicReduction.ml @@ -0,0 +1,1074 @@ +(* 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/. + *) + +(* $Id$ *) + +(* TODO unify exceptions *) + +exception WrongUriToInductiveDefinition;; +exception Impossible of int;; +exception ReferenceToConstant;; +exception ReferenceToVariable;; +exception ReferenceToCurrentProof;; +exception ReferenceToInductiveDefinition;; + +let debug = false +let profile = false +let debug_print s = if debug then prerr_endline (Lazy.force s) + +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 + in + if !fdebug = 0 then + debug_print (lazy (s ^ "\n" ^ List.fold_right debug_aux (t::env) "")) +;; + +module type Strategy = + sig + type stack_term + type env_term + type ens_term + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + val to_env : config -> env_term + val to_ens : config -> ens_term + val from_stack : stack_term -> config + val from_stack_list_for_unwind : + unwind: (config -> Cic.term) -> + stack_term list -> Cic.term list + val from_env : env_term -> config + val from_env_for_unwind : + unwind: (config -> Cic.term) -> + env_term -> Cic.term + val from_ens : ens_term -> config + val from_ens_for_unwind : + unwind: (config -> Cic.term) -> + ens_term -> Cic.term + val stack_to_env : + reduce: (config -> config) -> + unwind: (config -> Cic.term) -> + stack_term -> env_term + val compute_to_env : + reduce: (config -> config) -> + unwind: (config -> Cic.term) -> + int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> env_term + val compute_to_stack : + reduce: (config -> config) -> + unwind: (config -> Cic.term) -> + config -> stack_term + end +;; + +module CallByValueByNameForUnwind = + struct + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + and stack_term = config + and env_term = config * config (* cbv, cbn *) + and ens_term = config * config (* cbv, cbn *) + + let to_env c = c,c + let to_ens c = c,c + let from_stack config = config + let from_stack_list_for_unwind ~unwind l = List.map unwind l + let from_env (c,_) = c + let from_ens (c,_) = c + let from_env_for_unwind ~unwind (_,c) = unwind c + let from_ens_for_unwind ~unwind (_,c) = unwind c + let stack_to_env ~reduce ~unwind config = reduce config, (0,[],[],unwind config,[]) + let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]), (k,e,ens,t,[]) + let compute_to_stack ~reduce ~unwind config = config + end +;; + + +module CallByNameStrategy = + struct + type stack_term = Cic.term + type env_term = Cic.term + type ens_term = Cic.term + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = v + let from_ens_for_unwind ~unwind 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 +;; + +module CallByValueStrategy = + struct + type stack_term = Cic.term + type env_term = Cic.term + type ens_term = Cic.term + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = v + let from_ens_for_unwind ~unwind 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 + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = v + let from_ens_for_unwind ~unwind 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 + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = Lazy.force v + let from_ens_for_unwind ~unwind 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 +;; + +module LazyCallByValueStrategyByNameOnConstants = + struct + type stack_term = Cic.term lazy_t + type env_term = Cic.term lazy_t + type ens_term = Cic.term lazy_t + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = Lazy.force v + let from_ens_for_unwind ~unwind 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 +;; + +module LazyCallByNameStrategy = + struct + type stack_term = Cic.term lazy_t + type env_term = Cic.term lazy_t + type ens_term = Cic.term lazy_t + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = Lazy.force v + let from_ens_for_unwind ~unwind 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 + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = (v ~reduce:true) + let from_ens_for_unwind ~unwind 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 config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + and stack_term = config + and env_term = config + and ens_term = config + + let to_env config = config + let to_ens config = config + let from_stack config = config + let from_stack_list_for_unwind ~unwind l = List.map unwind l + let from_env v = v + let from_ens v = v + let from_env_for_unwind ~unwind config = unwind config + let from_ens_for_unwind ~unwind config = unwind config + let stack_to_env ~reduce ~unwind config = reduce config + let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]) + let compute_to_stack ~reduce ~unwind config = config + 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 + type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list + 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 from_env_for_unwind ~unwind v = v + let from_ens_for_unwind ~unwind 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 rec 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_for_unwind ~unwind (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) -> +(* +debug_print (lazy ("%%%%%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_for_unwind ~unwind (List.assq uri ens)) + else + let params = + let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + (match o 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 = + let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + (match o 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 = + let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + (match o 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 = + let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + (match o 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_for_unwind ~unwind t)) :: + (filter_and_lift (uri::already_instantiated) tl) + | _::tl -> filter_and_lift already_instantiated tl +(* + | (uri,_)::tl -> +debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ; +if List.for_all (function (uri',_) -> not (UriManager.eq uri uri')) +exp_named_subst' then debug_print (lazy "---- OK1") ; +debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; +if List.mem uri params then debug_print (lazy "---- 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 + + and unwind (k,e,ens,t,s) = + let t' = unwind' 0 k e ens t in + if s = [] then t' else Cic.Appl (t'::(RS.from_stack_list_for_unwind ~unwind s)) + ;; + +(* + let unwind = + let profiler_unwind = HExtlib.profile ~enable:profile "are_convertible.unwind" in + fun k e ens t -> + profiler_unwind.HExtlib.profile (unwind k e ens) t + ;; +*) + + let reduce ~delta ?(subst = []) context : config -> config = + let module C = Cic in + let module S = CicSubstitution in + let rec reduce = + function + (k, e, _, C.Rel n, s) as config -> + let config' = + try + Some (RS.from_env (List.nth e (n-1))) + with + Failure _ -> + try + begin + match List.nth context (n - 1 - k) with + None -> assert false + | Some (_,C.Decl _) -> None + | Some (_,C.Def (x,_)) -> Some (0,[],[],S.lift (n - k) x,[]) + end + with + Failure _ -> None + in + (match config' with + Some (k',e',ens',t',s') -> reduce (k',e',ens',t',s'@s) + | None -> config) + | (k, e, ens, C.Var (uri,exp_named_subst), s) as config -> + if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then + let (k',e',ens',t',s') = RS.from_ens (List.assq uri ens) in + reduce (k',e',ens',t',s'@s) + else + ( let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + match o with + C.Constant _ -> raise ReferenceToConstant + | C.CurrentProof _ -> raise ReferenceToCurrentProof + | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + | C.Variable (_,None,_,_,_) -> config + | 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 (n,l), s) as config -> + (try + let (_, term,_) = CicUtil.lookup_subst n subst in + reduce (k, e, ens,CicSubstitution.subst_meta l term,s) + with CicUtil.Subst_not_found _ -> config) + | (_, _, _, C.Sort _, _) + | (_, _, _, C.Implicit _, _) as config -> config + | (k, e, ens, C.Cast (te,ty), s) -> + reduce (k, e, ens, te, s) + | (_, _, _, C.Prod _, _) as config -> config + | (_, _, _, C.Lambda _, []) as config -> config + | (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), s) -> + let m' = RS.compute_to_env ~reduce ~unwind k e ens m in + reduce (k+1, m'::e, ens, t, s) + | (_, _, _, C.Appl [], _) -> assert false + | (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) + | (_, _, _, C.Const _, _) as config when delta=false-> config + | (k, e, ens, C.Const (uri,exp_named_subst), s) as config -> + (let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + match o 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,_,_,_) -> config + | 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 + ) + | (_, _, _, C.MutInd _, _) + | (_, _, _, C.MutConstruct _, _) as config -> config + | (k, e, ens, C.MutCase (mutind,i,outty,term,pl),s) as config -> + let decofix = + function + (k, e, ens, C.CoFix (i,fl), s) -> + 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,ens,body',s) + | config -> config + in + (match decofix (reduce (k,e,ens,term,[])) with + (k', e', ens', C.MutConstruct (_,_,j,_), []) -> + reduce (k, e, ens, (List.nth pl (j-1)), []) + | (k', e', ens', C.MutConstruct (_,_,j,_), s') -> + let (arity, r) = + let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph mutind + in + match o with + C.InductiveDefinition (s,ingredients,r,_) -> + let (_,_,arity,_) = List.nth s 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::s) when n > 0 -> eat_first (n - 1, s) + | _ -> raise (Impossible 5) + in + eat_first (num_to_eat,s') + in + reduce (k, e, ens, (List.nth pl (j-1)), ts@s) + | (_, _, _, C.Cast _, _) + | (_, _, _, C.Implicit _, _) -> + raise (Impossible 2) (* we don't trust our whd ;-) *) + | config' -> + (*CSC: here I am unwinding the configuration and for sure I + will do it twice; to avoid this unwinding I should push the + "match [] with _" continuation on the stack; + another possibility is to just return the original configuration, + partially undoing the weak-head computation *) + (*this code is uncorrect since term' lives in e' <> e + let term' = unwind config' in + (k, e, ens, C.MutCase (mutind,i,outty,term',pl),s) + *) + config) + | (k, e, ens, C.Fix (i,fl), s) as config -> + let (_,recindex,_,body) = List.nth fl i in + let recparam = + try + Some (RS.from_stack (List.nth s recindex)) + with + _ -> None + in + (match recparam with + Some recparam -> + (match reduce recparam with + (_,_,_,C.MutConstruct _,_) as config -> + let leng = List.length 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 (k,e,ens,C.Fix (!counter -1, fl),[]))::e)) + in + build_env e + in + let rec replace i s t = + match i,s with + 0,_::tl -> t::tl + | n,he::tl -> he::(replace (n - 1) tl t) + | _,_ -> assert false in + let new_s = + replace recindex s (RS.compute_to_stack ~reduce ~unwind config) + in + reduce (k+leng, new_env, ens, body, new_s) + | _ -> config) + | None -> config + ) + | (_,_,_,C.CoFix _,_) as config -> config + and push_exp_named_subst k e ens = + function + [] -> ens + | (uri,t)::tl -> + push_exp_named_subst k e ((uri,RS.to_ens (k,e,ens,t,[]))::ens) tl + in + reduce + ;; + + let whd ?(delta=true) ?(subst=[]) context t = + unwind (reduce ~delta ~subst context (0, [], [], t, [])) + ;; + + end +;; + + +(* ROTTO = rompe l'unificazione poiche' riduce gli argomenti di un'applicazione + senza ridurre la testa +module R = Reduction CallByNameStrategy;; OK 56.368s +module R = Reduction CallByValueStrategy;; ROTTO +module R = Reduction CallByValueStrategyByNameOnConstants;; ROTTO +module R = Reduction LazyCallByValueStrategy;; ROTTO +module R = Reduction LazyCallByValueStrategyByNameOnConstants;; ROTTO +module R = Reduction LazyCallByNameStrategy;; OK 0m56.398s +module R = Reduction + LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns;; + OK 59.058s +module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;; OK 58.583s +module R = Reduction + ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy;; OK 58.094s +module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);; OK 58.127s +*) +module R = Reduction(CallByValueByNameForUnwind);; +(*module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);;*) +module U = UriManager;; + +let whd = R.whd + +(* +let whd = + let profiler_whd = HExtlib.profile ~enable:profile "are_convertible.whd" in + fun ?(delta=true) ?(subst=[]) context t -> + profiler_whd.HExtlib.profile (whd ~delta ~subst context) t +*) + + (* mimic ocaml (<< 3.08) "=" behaviour. Tests physical equality first then + * fallbacks to structural equality *) +let (===) x y = + Pervasives.compare x y = 0 + +(* t1, t2 must be well-typed *) +let are_convertible whd ?(subst=[]) ?(metasenv=[]) = + let rec aux test_equality_only context t1 t2 ugraph = + let aux2 test_equality_only t1 t2 ugraph = + + (* 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,ugraph + else + begin + let module C = Cic in + match (t1,t2) with + (C.Rel n1, C.Rel n2) -> (n1 = n2),ugraph + | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) -> + if U.eq uri1 uri2 then + (try + List.fold_right2 + (fun (uri1,x) (uri2,y) (b,ugraph) -> + let b',ugraph' = aux test_equality_only context x y ugraph in + (U.eq uri1 uri2 && b' && b),ugraph' + ) exp_named_subst1 exp_named_subst2 (true,ugraph) + with + Invalid_argument _ -> false,ugraph + ) + else + false,ugraph + | (C.Meta (n1,l1), C.Meta (n2,l2)) -> + if n1 = n2 then + let b2, ugraph1 = + let l1 = CicUtil.clean_up_local_context subst metasenv n1 l1 in + let l2 = CicUtil.clean_up_local_context subst metasenv n2 l2 in + List.fold_left2 + (fun (b,ugraph) t1 t2 -> + if b then + match t1,t2 with + None,_ + | _,None -> true,ugraph + | Some t1',Some t2' -> + aux test_equality_only context t1' t2' ugraph + else + false,ugraph + ) (true,ugraph) l1 l2 + in + if b2 then true,ugraph1 else false,ugraph + else + false,ugraph + (* TASSI: CONSTRAINTS *) + | (C.Sort (C.Type t1), C.Sort (C.Type t2)) when test_equality_only -> + true,(CicUniv.add_eq t2 t1 ugraph) + (* TASSI: CONSTRAINTS *) + | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> + true,(CicUniv.add_ge t2 t1 ugraph) + (* TASSI: CONSTRAINTS *) + | (C.Sort s1, C.Sort (C.Type _)) -> (not test_equality_only),ugraph + (* TASSI: CONSTRAINTS *) + | (C.Sort s1, C.Sort s2) -> (s1 = s2),ugraph + | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) -> + let b',ugraph' = aux true context s1 s2 ugraph in + if b' then + aux test_equality_only ((Some (name1, (C.Decl s1)))::context) + t1 t2 ugraph' + else + false,ugraph + | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) -> + let b',ugraph' = aux test_equality_only context s1 s2 ugraph in + if b' then + aux test_equality_only ((Some (name1, (C.Decl s1)))::context) + t1 t2 ugraph' + else + false,ugraph + | (C.LetIn (name1,s1,t1), C.LetIn(_,s2,t2)) -> + let b',ugraph' = aux test_equality_only context s1 s2 ugraph in + if b' then + aux test_equality_only + ((Some (name1, (C.Def (s1,None))))::context) t1 t2 ugraph' + else + false,ugraph + | (C.Appl l1, C.Appl l2) -> + (try + List.fold_right2 + (fun x y (b,ugraph) -> + if b then + aux test_equality_only context x y ugraph + else + false,ugraph) l1 l2 (true,ugraph) + with + Invalid_argument _ -> false,ugraph + ) + | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) -> + let b' = U.eq uri1 uri2 in + if b' then + (try + List.fold_right2 + (fun (uri1,x) (uri2,y) (b,ugraph) -> + if b && U.eq uri1 uri2 then + aux test_equality_only context x y ugraph + else + false,ugraph + ) exp_named_subst1 exp_named_subst2 (true,ugraph) + with + Invalid_argument _ -> false,ugraph + ) + else + false,ugraph + | (C.MutInd (uri1,i1,exp_named_subst1), + C.MutInd (uri2,i2,exp_named_subst2) + ) -> + let b' = U.eq uri1 uri2 && i1 = i2 in + if b' then + (try + List.fold_right2 + (fun (uri1,x) (uri2,y) (b,ugraph) -> + if b && U.eq uri1 uri2 then + aux test_equality_only context x y ugraph + else + false,ugraph + ) exp_named_subst1 exp_named_subst2 (true,ugraph) + with + Invalid_argument _ -> false,ugraph + ) + else + false,ugraph + | (C.MutConstruct (uri1,i1,j1,exp_named_subst1), + C.MutConstruct (uri2,i2,j2,exp_named_subst2) + ) -> + let b' = U.eq uri1 uri2 && i1 = i2 && j1 = j2 in + if b' then + (try + List.fold_right2 + (fun (uri1,x) (uri2,y) (b,ugraph) -> + if b && U.eq uri1 uri2 then + aux test_equality_only context x y ugraph + else + false,ugraph + ) exp_named_subst1 exp_named_subst2 (true,ugraph) + with + Invalid_argument _ -> false,ugraph + ) + else + false,ugraph + | (C.MutCase (uri1,i1,outtype1,term1,pl1), + C.MutCase (uri2,i2,outtype2,term2,pl2)) -> + let b' = U.eq uri1 uri2 && i1 = i2 in + if b' then + let b'',ugraph''=aux test_equality_only context + outtype1 outtype2 ugraph in + if b'' then + let b''',ugraph'''= aux test_equality_only context + term1 term2 ugraph'' in + List.fold_right2 + (fun x y (b,ugraph) -> + if b then + aux test_equality_only context x y ugraph + else + false,ugraph) + pl1 pl2 (b''',ugraph''') + else + false,ugraph + else + false,ugraph + | (C.Fix (i1,fl1), C.Fix (i2,fl2)) -> + let tys = + List.map (function (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1 + in + if i1 = i2 then + List.fold_right2 + (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) (b,ugraph) -> + if b && recindex1 = recindex2 then + let b',ugraph' = aux test_equality_only context ty1 ty2 + ugraph in + if b' then + aux test_equality_only (tys@context) bo1 bo2 ugraph' + else + false,ugraph + else + false,ugraph) + fl1 fl2 (true,ugraph) + else + false,ugraph + | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) -> + let tys = + List.map (function (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1 + in + if i1 = i2 then + List.fold_right2 + (fun (_,ty1,bo1) (_,ty2,bo2) (b,ugraph) -> + if b then + let b',ugraph' = aux test_equality_only context ty1 ty2 + ugraph in + if b' then + aux test_equality_only (tys@context) bo1 bo2 ugraph' + else + false,ugraph + else + false,ugraph) + fl1 fl2 (true,ugraph) + else + false,ugraph + | (C.Cast _, _) | (_, C.Cast _) + | (C.Implicit _, _) | (_, C.Implicit _) -> assert false + | (_,_) -> false,ugraph + end + in + debug t1 [t2] "PREWHD"; + let t1' = whd ?delta:(Some true) ?subst:(Some subst) context t1 in + let t2' = whd ?delta:(Some true) ?subst:(Some subst) context t2 in + debug t1' [t2'] "POSTWHD"; + aux2 test_equality_only t1' t2' ugraph + in + aux false (*c t1 t2 ugraph *) +;; + +(* DEBUGGING ONLY +let whd ?(delta=true) ?(subst=[]) context t = + let res = whd ~delta ~subst context t in + let rescsc = CicReductionNaif.whd ~delta ~subst context t in + if not (fst (are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph)) then + begin + debug_print (lazy ("PRIMA: " ^ CicPp.ppterm t)) ; + flush stderr ; + debug_print (lazy ("DOPO: " ^ CicPp.ppterm res)) ; + flush stderr ; + debug_print (lazy ("CSC: " ^ CicPp.ppterm rescsc)) ; + flush stderr ; +fdebug := 0 ; +let _ = are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph in + assert false ; + end + else + res +;; +*) + +let are_convertible = are_convertible whd + +let whd = R.whd + +(* +let profiler_other_whd = HExtlib.profile ~enable:profile "~are_convertible.whd" +let whd ?(delta=true) ?(subst=[]) context t = + let foo () = + whd ~delta ~subst context t + in + profiler_other_whd.HExtlib.profile foo () +*) + +let rec normalize ?(delta=true) ?(subst=[]) ctx term = + let module C = Cic in + let t = whd ~delta ~subst ctx term in + let aux = normalize ~delta ~subst in + let decl name t = Some (name, C.Decl t) in + match t with + | C.Rel n -> t + | C.Var (uri,exp_named_subst) -> + C.Var (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) + | C.Meta (i,l) -> + C.Meta (i,List.map (function Some t -> Some (aux ctx t) | None -> None) l) + | C.Sort _ -> t + | C.Implicit _ -> t + | C.Cast (te,ty) -> C.Cast (aux ctx te, aux ctx ty) + | C.Prod (n,s,t) -> + let s' = aux ctx s in + C.Prod (n, s', aux ((decl n s')::ctx) t) + | C.Lambda (n,s,t) -> + let s' = aux ctx s in + C.Lambda (n, s', aux ((decl n s')::ctx) t) + | C.LetIn (n,s,t) -> + (* the term is already in weak head normal form *) + assert false + | C.Appl (h::l) -> C.Appl (h::(List.map (aux ctx) l)) + | C.Appl [] -> assert false + | C.Const (uri,exp_named_subst) -> + C.Const (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) + | C.MutInd (uri,typeno,exp_named_subst) -> + C.MutInd (uri,typeno, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) + | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> + C.MutConstruct (uri, typeno, consno, + List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) + | C.MutCase (sp,i,outt,t,pl) -> + C.MutCase (sp,i, aux ctx outt, aux ctx t, List.map (aux ctx) pl) +(*CSC: to be completed, I suppose *) + | C.Fix _ -> t + | C.CoFix _ -> t + +let normalize ?delta ?subst ctx term = +(* prerr_endline ("NORMALIZE:" ^ CicPp.ppterm term); *) + let t = normalize ?delta ?subst ctx term in +(* prerr_endline ("NORMALIZED:" ^ CicPp.ppterm t); *) + t + + +(* performs an head beta/cast reduction *) +let rec head_beta_reduce = + function + (Cic.Appl (Cic.Lambda (_,_,t)::he'::tl')) -> + let he'' = CicSubstitution.subst he' t in + if tl' = [] then + he'' + else + let he''' = + match he'' with + Cic.Appl l -> Cic.Appl (l@tl') + | _ -> Cic.Appl (he''::tl') + in + head_beta_reduce he''' + | Cic.Cast (te,_) -> head_beta_reduce te + | t -> t diff --git a/helm/software/components/cic_proof_checking/cicReduction.mli b/helm/software/components/cic_proof_checking/cicReduction.mli new file mode 100644 index 000000000..e3619053d --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicReduction.mli @@ -0,0 +1,42 @@ +(* 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 WrongUriToInductiveDefinition +exception ReferenceToConstant +exception ReferenceToVariable +exception ReferenceToCurrentProof +exception ReferenceToInductiveDefinition +val fdebug : int ref +val whd : + ?delta:bool -> ?subst:Cic.substitution -> Cic.context -> Cic.term -> Cic.term +val are_convertible : + ?subst:Cic.substitution -> ?metasenv:Cic.metasenv -> + Cic.context -> Cic.term -> Cic.term -> CicUniv.universe_graph -> + bool * CicUniv.universe_graph +val normalize: + ?delta:bool -> ?subst:Cic.substitution -> Cic.context -> Cic.term -> Cic.term + +(* performs an head beta/cast reduction *) +val head_beta_reduce: Cic.term -> Cic.term diff --git a/helm/software/components/cic_proof_checking/cicSubstitution.ml b/helm/software/components/cic_proof_checking/cicSubstitution.ml new file mode 100644 index 000000000..a30a036cb --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicSubstitution.ml @@ -0,0 +1,428 @@ +(* 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/. + *) + +(* $Id$ *) + +exception CannotSubstInMeta;; +exception RelToHiddenHypothesis;; +exception ReferenceToVariable;; +exception ReferenceToConstant;; +exception ReferenceToCurrentProof;; +exception ReferenceToInductiveDefinition;; + +let debug_print = fun _ -> () + +let lift_from k n = + let rec liftaux k = + let module C = Cic in + function + C.Rel m -> + if m < k then + C.Rel m + else + C.Rel (m + n) + | 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 + (function + None -> None + | Some t -> Some (liftaux k t) + ) l + in + C.Meta(i,l') + | C.Sort _ as t -> t + | C.Implicit _ as t -> t + | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty) + | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t) + | 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 (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 + let liftedfl = + List.map + (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (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, liftaux k ty, liftaux (k+len) bo)) + fl + in + C.CoFix (i, liftedfl) + in + liftaux k + +let lift n t = + if n = 0 then + t + else + lift_from 1 n t +;; + +let subst arg = + let rec substaux k = + let module C = Cic in + function + C.Rel n as t -> + (match n with + n when n = k -> lift (k - 1) arg + | n when n < k -> t + | _ -> C.Rel (n - 1) + ) + | 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) -> + 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,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 + 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 +;; + +(*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 t = +(* +debug_print (lazy ("@@@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 + lift (k -1) arg + with + Not_found -> + let params = + let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match obj with + C.Constant _ -> raise ReferenceToConstant + | C.Variable (_,_,_,params,_) -> params + | C.CurrentProof _ -> raise ReferenceToCurrentProof + | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + ) + in +(* +debug_print (lazy "\n\n---- BEGIN ") ; +debug_print (lazy ("----params: " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; +debug_print (lazy ("----S(" ^ UriManager.string_of_uri uri ^ "): " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst))) ; +debug_print (lazy ("----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 +(* +debug_print (lazy ("----D: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst''))) ; +debug_print (lazy "---- END\n\n ") ; +*) + C.Var (uri,exp_named_subst'') + ) + | C.Meta (i, l) -> + 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 = + let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match obj 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 = + let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match obj 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 = + let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match obj 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 -> +debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ; +if List.for_all (function (uri',_) -> not (UriManager.eq uri uri')) +exp_named_subst' then debug_print (lazy "---- OK1") ; +debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; +if List.mem uri params then debug_print (lazy "---- 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 + if exp_named_subst = [] then t + else substaux 1 t +;; + +(* subst_meta [t_1 ; ... ; t_n] t *) +(* returns the term [t] where [Rel i] is substituted with [t_i] *) +(* [t_i] is lifted as usual when it crosses an abstraction *) +let subst_meta l t = + let module C = Cic in + if l = [] then t else + let rec aux k = function + C.Rel n as t -> + if n <= k then t else + (try + match List.nth l (n-k-1) with + None -> raise RelToHiddenHypothesis + | Some t -> lift k t + with + (Failure _) -> assert false + ) + | 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 + (function + None -> None + | Some t -> + try + Some (aux k t) + with + RelToHiddenHypothesis -> None + ) l + in + C.Meta(i,l') + | C.Sort _ as t -> t + | C.Implicit _ as t -> t + | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) (*CSC ??? *) + | 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,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 = + 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 0 t +;; + diff --git a/helm/software/components/cic_proof_checking/cicSubstitution.mli b/helm/software/components/cic_proof_checking/cicSubstitution.mli new file mode 100644 index 000000000..21a1f5d0e --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicSubstitution.mli @@ -0,0 +1,56 @@ +(* 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 CannotSubstInMeta;; +exception RelToHiddenHypothesis;; +exception ReferenceToVariable;; +exception ReferenceToConstant;; +exception ReferenceToInductiveDefinition;; + +(* lift n t *) +(* lifts [t] of [n] *) +(* NOTE: the opposite function (delift_rels) is defined in CicMetaSubst *) +(* since it needs to restrict the metavariables in case of failure *) +val lift : int -> Cic.term -> Cic.term + + +(* lift from n t *) +(* as lift but lifts only indexes >= from *) +val lift_from: int -> 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 + +(* subst_meta [t_1 ; ... ; t_n] t *) +(* returns the term [t] where [Rel i] is substituted with [t_i] *) +(* [t_i] is lifted as usual when it crosses an abstraction *) +val subst_meta : (Cic.term option) list -> Cic.term -> Cic.term + diff --git a/helm/software/components/cic_proof_checking/cicTypeChecker.ml b/helm/software/components/cic_proof_checking/cicTypeChecker.ml new file mode 100644 index 000000000..951f68dbd --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicTypeChecker.ml @@ -0,0 +1,2170 @@ +(* 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/. + *) + +(* $Id$ *) + +(* TODO factorize functions to frequent errors (e.g. "Unknwon mutual inductive + * ...") *) + +open Printf + +exception AssertFailure of string Lazy.t;; +exception TypeCheckerFailure of string Lazy.t;; + +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 (TypeCheckerFailure (lazy (List.fold_right debug_aux (t::context) ""))) +;; + +let debug_print = fun _ -> ();; + +let rec split l n = + match (l,n) with + (l,0) -> ([], l) + | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) + | (_,_) -> + raise (TypeCheckerFailure (lazy "Parameters number < left parameters number")) +;; + +let debrujin_constructor ?(cb=fun _ _ -> ()) uri number_of_types = + let rec aux k t = + let module C = Cic in + let res = + match t with + C.Rel n as t when n <= k -> t + | C.Rel _ -> + raise (TypeCheckerFailure (lazy "unbound variable found in constructor type")) + | 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 (function None -> None | Some t -> Some (aux k t)) l in + C.Meta (i,l') + | 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 + (lazy ("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 + cb t res; + res + in + aux 0 +;; + +exception CicEnvironmentError;; + +let rec type_of_constant ~logger uri ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let cobj,ugraph = + match CicEnvironment.is_type_checked ~trust:true ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' + | CicEnvironment.UncheckedObj uobj -> + logger#log (`Start_type_checking uri) ; + (* let's typecheck the uncooked obj *) + +(**************************************************************** + TASSI: FIXME qui e' inutile ricordarselo, + tanto poi lo richiediamo alla cache che da quello su disco +*****************************************************************) + + let ugraph_dust = + (match uobj with + C.Constant (_,Some te,ty,_,_) -> + let _,ugraph = type_of ~logger ty ugraph in + let type_of_te,ugraph' = type_of ~logger te ugraph in + let b',ugraph'' = (R.are_convertible [] type_of_te ty ugraph') in + if not b' then + raise (TypeCheckerFailure (lazy (sprintf + "the constant %s is not well typed because the type %s of the body is not convertible to the declared type %s" + (U.string_of_uri uri) (CicPp.ppterm type_of_te) + (CicPp.ppterm ty)))) + else + ugraph' + | C.Constant (_,None,ty,_,_) -> + (* only to check that ty is well-typed *) + let _,ugraph' = type_of ~logger ty ugraph in + ugraph' + | C.CurrentProof (_,conjs,te,ty,_,_) -> + let _,ugraph1 = + List.fold_left + (fun (metasenv,ugraph) ((_,context,ty) as conj) -> + let _,ugraph' = + type_of_aux' ~logger metasenv context ty ugraph + in + (metasenv @ [conj],ugraph') + ) ([],ugraph) conjs + in + let _,ugraph2 = type_of_aux' ~logger conjs [] ty ugraph1 in + let type_of_te,ugraph3 = + type_of_aux' ~logger conjs [] te ugraph2 + in + let b,ugraph4 = (R.are_convertible [] type_of_te ty ugraph3) in + if not b then + raise (TypeCheckerFailure (lazy (sprintf + "the current proof %s is not well typed because the type %s of the body is not convertible to the declared type %s" + (U.string_of_uri uri) (CicPp.ppterm type_of_te) + (CicPp.ppterm ty)))) + else + ugraph4 + | _ -> + raise + (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri)))) + in + try + CicEnvironment.set_type_checking_info uri; + logger#log (`Type_checking_completed uri) ; + match CicEnvironment.is_type_checked ~trust:false ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' + | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError + with Invalid_argument s -> + (*debug_print (lazy s);*) + uobj,ugraph_dust + in + match cobj,ugraph with + (C.Constant (_,_,ty,_,_)),g -> ty,g + | (C.CurrentProof (_,_,_,ty,_,_)),g -> ty,g + | _ -> + raise (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri))) + +and type_of_variable ~logger uri ugraph = + 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 ~trust:true ugraph uri with + CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> ty,ugraph' + | CicEnvironment.UncheckedObj (C.Variable (_,bo,ty,_,_)) -> + logger#log (`Start_type_checking uri) ; + (* only to check that ty is well-typed *) + let _,ugraph1 = type_of ~logger ty ugraph in + let ugraph2 = + (match bo with + None -> ugraph + | Some bo -> + let ty_bo,ugraph' = type_of ~logger bo ugraph1 in + let b,ugraph'' = (R.are_convertible [] ty_bo ty ugraph') in + if not b then + raise (TypeCheckerFailure + (lazy ("Unknown variable:" ^ U.string_of_uri uri))) + else + ugraph'') + in + (try + CicEnvironment.set_type_checking_info uri ; + logger#log (`Type_checking_completed uri) ; + match CicEnvironment.is_type_checked ~trust:false ugraph uri with + CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> + ty,ugraph' + | CicEnvironment.CheckedObj _ + | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError + with Invalid_argument s -> + (*debug_print (lazy s);*) + ty,ugraph2) + | _ -> + raise (TypeCheckerFailure (lazy ("Unknown variable:" ^ U.string_of_uri uri))) + +and does_not_occur ?(subst=[]) context n nn te = + let module C = Cic in + (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *) + (*CSC: venga mangiata durante la whd sembra presentare problemi di *) + (*CSC: universi *) + match CicReduction.whd ~subst context te with + C.Rel m when m > n && m <= nn -> false + | C.Rel _ + | C.Sort _ + | C.Implicit _ -> true + | C.Meta (_,l) -> + List.fold_right + (fun x i -> + match x with + None -> i + | Some x -> i && does_not_occur ~subst context n nn x) l true + | C.Cast (te,ty) -> + does_not_occur ~subst context n nn te && does_not_occur ~subst context n nn ty + | C.Prod (name,so,dest) -> + does_not_occur ~subst context n nn so && + does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) + (nn + 1) dest + | C.Lambda (name,so,dest) -> + does_not_occur ~subst context n nn so && + does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) (nn + 1) + dest + | C.LetIn (name,so,dest) -> + does_not_occur ~subst context n nn so && + does_not_occur ~subst ((Some (name,(C.Def (so,None))))::context) + (n + 1) (nn + 1) dest + | C.Appl l -> + List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true + | 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 ~subst context n nn x) + exp_named_subst true + | C.MutCase (_,_,out,te,pl) -> + does_not_occur ~subst context n nn out && does_not_occur ~subst context n nn te && + List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) pl true + | C.Fix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len in + let nn_plus_len = nn + len in + let tys = + List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl + in + List.fold_right + (fun (_,_,ty,bo) i -> + i && does_not_occur ~subst context n nn ty && + does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo + ) fl true + | C.CoFix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len in + let nn_plus_len = nn + len in + let tys = + List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl + in + List.fold_right + (fun (_,ty,bo) i -> + i && does_not_occur ~subst context n nn ty && + does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo + ) fl true + +(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *) +(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *) +(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *) +(*CSC strictly_positive *) +(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *) +and weakly_positive context n nn uri te = + let module C = Cic in +(*CSC: Che schifo! Bisogna capire meglio e trovare una soluzione ragionevole!*) + let dummy_mutind = + C.MutInd (HelmLibraryObjects.Datatypes.nat_URI,0,[]) + in + (*CSC: mettere in cicSubstitution *) + let rec subst_inductive_type_with_dummy_mutind = + function + C.MutInd (uri',0,_) when UriManager.eq uri' uri -> + dummy_mutind + | 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) -> + C.Prod (name, subst_inductive_type_with_dummy_mutind so, + subst_inductive_type_with_dummy_mutind ta) + | C.Lambda (name,so,ta) -> + C.Lambda (name, subst_inductive_type_with_dummy_mutind so, + subst_inductive_type_with_dummy_mutind ta) + | C.Appl tl -> + C.Appl (List.map subst_inductive_type_with_dummy_mutind tl) + | 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.Fix (i,fl) -> + C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i, + subst_inductive_type_with_dummy_mutind ty, + subst_inductive_type_with_dummy_mutind bo)) fl) + | C.CoFix (i,fl) -> + 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.Anonymous,source,dest) -> + strictly_positive context n nn + (subst_inductive_type_with_dummy_mutind source) && + 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 -> + (* dummy abstraction, so we behave as in the anonimous case *) + strictly_positive context n nn + (subst_inductive_type_with_dummy_mutind source) && + weakly_positive ((Some (name,(C.Decl source)))::context) + (n + 1) (nn + 1) uri dest + | C.Prod (name,source,dest) -> + does_not_occur context n nn + (subst_inductive_type_with_dummy_mutind source)&& + weakly_positive ((Some (name,(C.Decl source)))::context) + (n + 1) (nn + 1) uri dest + | _ -> + raise (TypeCheckerFailure (lazy "Malformed inductive constructor type")) + +(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *) +(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *) +and instantiate_parameters params c = + let module C = Cic in + match (c,params) with + (c,[]) -> c + | (C.Prod (_,_,ta), he::tl) -> + instantiate_parameters tl + (CicSubstitution.subst he ta) + | (C.Cast (te,_), _) -> instantiate_parameters params te + | (t,l) -> raise (AssertFailure (lazy "1")) + +and strictly_positive context n nn te = + let module C = Cic in + let module U = UriManager in + match CicReduction.whd context te with + C.Rel _ -> true + | C.Cast (te,ty) -> + (*CSC: bisogna controllare ty????*) + strictly_positive context n nn te + | C.Prod (name,so,ta) -> + does_not_occur context n nn so && + 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,exp_named_subst))::tl) -> + let (ok,paramsno,ity,cl,name) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (tl,_,paramsno,_) -> + let (name,_,ity,cl) = List.nth tl i in + (List.length tl = 1, paramsno, ity, cl, name) + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown inductive type:" ^ 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 + (CicSubstitution.subst_vars exp_named_subst te) + ) cl + in + ok && + List.fold_right + (fun x i -> i && does_not_occur context n nn x) + arguments true && + (*CSC: MEGAPATCH3 (sara' quella giusta?)*) + List.fold_right + (fun x i -> + i && + weakly_positive + ((Some (C.Name name,(Cic.Decl ity)))::context) (n+1) (nn+1) uri + x + ) cl' true + | t -> does_not_occur context n nn t + +(* the inductive type indexes are s.t. n < x <= nn *) +and are_all_occurrences_positive context uri indparamsno i n nn te = + let module C = Cic in + match CicReduction.whd context te with + C.Appl ((C.Rel m)::tl) when m = i -> + (*CSC: riscrivere fermandosi a 0 *) + (* let's check if the inductive type is applied at least to *) + (* indparamsno parameters *) + let last = + List.fold_left + (fun k x -> + if k = 0 then 0 + else + match CicReduction.whd context x with + C.Rel m when m = n - (indparamsno - k) -> k - 1 + | _ -> + raise (TypeCheckerFailure + (lazy + ("Non-positive occurence in mutual inductive definition(s) [1]" ^ + 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 (TypeCheckerFailure + (lazy ("Non-positive occurence in mutual inductive definition(s) [2]"^ + UriManager.string_of_uri uri))) + | C.Rel m when m = i -> + if indparamsno = 0 then + true + else + raise (TypeCheckerFailure + (lazy ("Non-positive occurence in mutual inductive definition(s) [3]"^ + UriManager.string_of_uri uri))) + | C.Prod (C.Anonymous,source,dest) -> + strictly_positive context n nn source && + are_all_occurrences_positive + ((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 -> + (* dummy abstraction, so we behave as in the anonimous case *) + strictly_positive context n nn source && + are_all_occurrences_positive + ((Some (name,(C.Decl source)))::context) uri indparamsno + (i+1) (n + 1) (nn + 1) dest + | C.Prod (name,source,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 + (TypeCheckerFailure (lazy ("Malformed inductive constructor type " ^ + (UriManager.string_of_uri 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 ~logger uri (itl,_,indparamsno) ugraph = + let module U = UriManager in + (* let's check if the arity of the inductive types are well *) + (* formed *) + let ugrap1 = List.fold_left + (fun ugraph (_,_,x,_) -> let _,ugraph' = + type_of ~logger x ugraph in ugraph') + ugraph itl in + + (* 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 _,ugraph2 = + List.fold_right + (fun (_,_,_,cl) (i,ugraph) -> + let ugraph'' = + List.fold_left + (fun ugraph (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 _,ugraph' = type_of ~logger augmented_term ugraph in + (* let's check also the positivity conditions *) + if + not + (are_all_occurrences_positive tys uri indparamsno i 0 len + debrujinedte) + then + raise + (TypeCheckerFailure + (lazy ("Non positive occurence in " ^ U.string_of_uri uri))) + else + ugraph' + ) ugraph cl in + (i + 1),ugraph'' + ) itl (1,ugrap1) + in + ugraph2 + +(* Main function to checks the correctness of a mutual *) +(* inductive block definition. *) +and check_mutual_inductive_defs uri obj ugraph = + match obj with + Cic.InductiveDefinition (itl, params, indparamsno, _) -> + typecheck_mutual_inductive_defs uri (itl,params,indparamsno) ugraph + | _ -> + raise (TypeCheckerFailure ( + lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + +and type_of_mutual_inductive_defs ~logger uri i ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let cobj,ugraph1 = + match CicEnvironment.is_type_checked ~trust:true ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' + | CicEnvironment.UncheckedObj uobj -> + logger#log (`Start_type_checking uri) ; + let ugraph1_dust = + check_mutual_inductive_defs ~logger uri uobj ugraph + in + (* TASSI: FIXME: check ugraph1 == ugraph ritornato da env *) + try + CicEnvironment.set_type_checking_info uri ; + logger#log (`Type_checking_completed uri) ; + (match CicEnvironment.is_type_checked ~trust:false ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> (cobj,ugraph') + | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError + ) + with + Invalid_argument s -> + (*debug_print (lazy s);*) + uobj,ugraph1_dust + in + match cobj with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,arity,_) = List.nth dl i in + arity,ugraph1 + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ U.string_of_uri uri))) + +and type_of_mutual_inductive_constr ~logger uri i j ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let cobj,ugraph1 = + match CicEnvironment.is_type_checked ~trust:true ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' + | CicEnvironment.UncheckedObj uobj -> + logger#log (`Start_type_checking uri) ; + let ugraph1_dust = + check_mutual_inductive_defs ~logger uri uobj ugraph + in + (* check ugraph1 validity ??? == ugraph' *) + try + CicEnvironment.set_type_checking_info uri ; + logger#log (`Type_checking_completed uri) ; + (match + CicEnvironment.is_type_checked ~trust:false ugraph uri + with + CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' + | CicEnvironment.UncheckedObj _ -> + raise CicEnvironmentError) + with + Invalid_argument s -> + (*debug_print (lazy s);*) + uobj,ugraph1_dust + in + match cobj with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,_,cl) = List.nth dl i in + let (_,ty) = List.nth cl (j-1) in + ty,ugraph1 + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri))) + +and recursive_args context n nn te = + let module C = Cic in + match CicReduction.whd context te with + C.Rel _ -> [] + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit _ + | C.Cast _ (*CSC ??? *) -> + raise (AssertFailure (lazy "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 (AssertFailure (lazy "4")) (* due to type-checking *) + | C.Appl _ -> [] + | C.Const _ -> raise (AssertFailure (lazy "5")) + | C.MutInd _ + | C.MutConstruct _ + | C.MutCase _ + | C.Fix _ + | C.CoFix _ -> raise (AssertFailure (lazy "6")) (* due to type-checking *) + +and get_new_safes ~subst context p c rl safes n nn x = + let module C = Cic in + let module U = UriManager in + let module R = CicReduction in + match (R.whd ~subst context c, R.whd ~subst context p, rl) with + (C.Prod (_,so,ta1), C.Lambda (name,_,ta2), b::tl) -> + (* we are sure that the two sources are convertible because we *) + (* have just checked this. So let's go along ... *) + let safes' = + List.map (fun x -> x + 1) safes + in + let safes'' = + if b then 1::safes' else safes' + in + get_new_safes ~subst ((Some (name,(C.Decl so)))::context) + ta2 ta1 tl safes'' (n+1) (nn+1) (x+1) + | (C.Prod _, (C.MutConstruct _ as e), _) + | (C.Prod _, (C.Rel _ as e), _) + | (C.MutInd _, e, []) + | (C.Appl _, e, []) -> (e,safes,n,nn,x,context) + | (c,p,l) -> + (* CSC: If the next exception is raised, it just means that *) + (* CSC: the proof-assistant allows to use very strange things *) + (* 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 + (AssertFailure (lazy + (Printf.sprintf "Get New Safes: c=%s ; p=%s" + (CicPp.ppterm c) (CicPp.ppterm p)))) + +and split_prods ~subst context n te = + let module C = Cic in + let module R = CicReduction in + match (n, R.whd ~subst context te) with + (0, _) -> context,te + | (n, C.Prod (name,so,ta)) when n > 0 -> + split_prods ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta + | (_, _) -> raise (AssertFailure (lazy "8")) + +and eat_lambdas ~subst context n te = + let module C = Cic in + let module R = CicReduction in + match (n, R.whd ~subst context te) with + (0, _) -> (te, 0, context) + | (n, C.Lambda (name,so,ta)) when n > 0 -> + let (te, k, context') = + eat_lambdas ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta + in + (te, k + 1, context') + | (n, te) -> + raise (AssertFailure (lazy (sprintf "9 (%d, %s)" n (CicPp.ppterm te)))) + +(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *) +and check_is_really_smaller_arg ~subst context n nn kl x safes te = + (*CSC: forse la whd si puo' fare solo quando serve veramente. *) + (*CSC: cfr guarded_by_destructors *) + let module C = Cic in + let module U = UriManager in + match CicReduction.whd ~subst context te with + C.Rel m when List.mem m safes -> true + | C.Rel _ -> false + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit _ + | C.Cast _ +(* | C.Cast (te,ty) -> + check_is_really_smaller_arg ~subst n nn kl x safes te && + check_is_really_smaller_arg ~subst n nn kl x safes ty*) +(* | C.Prod (_,so,ta) -> + check_is_really_smaller_arg ~subst n nn kl x safes so && + check_is_really_smaller_arg ~subst (n+1) (nn+1) kl (x+1) + (List.map (fun x -> x + 1) safes) ta*) + | C.Prod _ -> raise (AssertFailure (lazy "10")) + | C.Lambda (name,so,ta) -> + check_is_really_smaller_arg ~subst context n nn kl x safes so && + check_is_really_smaller_arg ~subst ((Some (name,(C.Decl so)))::context) + (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta + | C.LetIn (name,so,ta) -> + check_is_really_smaller_arg ~subst context n nn kl x safes so && + check_is_really_smaller_arg ~subst ((Some (name,(C.Def (so,None))))::context) + (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta + | C.Appl (he::_) -> + (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *) + (*CSC: solo perche' non abbiamo trovato controesempi *) + check_is_really_smaller_arg ~subst context n nn kl x safes he + | C.Appl [] -> raise (AssertFailure (lazy "11")) + | C.Const _ + | C.MutInd _ -> raise (AssertFailure (lazy "12")) + | C.MutConstruct _ -> false + | C.MutCase (uri,i,outtype,term,pl) -> + (match term with + C.Rel m when List.mem m safes || m = x -> + let (tys,len,isinductive,paramsno,cl) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (tl,_,paramsno,_) -> + let tys = + List.map + (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) tl + in + let (_,isinductive,_,cl) = List.nth tl i in + let cl' = + List.map + (fun (id,ty) -> + (id, snd (split_prods ~subst tys paramsno ty))) cl + in + (tys,List.length tl,isinductive,paramsno,cl') + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + in + if not isinductive then + List.fold_right + (fun p i -> + i && check_is_really_smaller_arg ~subst context n nn kl x safes p) + pl true + else + let pl_and_cl = + try + List.combine pl cl + with + Invalid_argument _ -> + raise (TypeCheckerFailure (lazy "not enough patterns")) + in + List.fold_right + (fun (p,(_,c)) i -> + let rl' = + 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 ~subst context p c rl' safes n nn x + in + i && + check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e + ) pl_and_cl true + | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> + let (tys,len,isinductive,paramsno,cl) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (tl,_,paramsno,_) -> + let (_,isinductive,_,cl) = List.nth tl i in + let tys = + List.map (fun (n,_,ty,_) -> + Some(Cic.Name n,(Cic.Decl ty))) tl + in + let cl' = + List.map + (fun (id,ty) -> + (id, snd (split_prods ~subst tys paramsno ty))) cl + in + (tys,List.length tl,isinductive,paramsno,cl') + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + in + if not isinductive then + List.fold_right + (fun p i -> + i && check_is_really_smaller_arg ~subst context n nn kl x safes p) + pl true + else + let pl_and_cl = + try + List.combine pl cl + with + Invalid_argument _ -> + raise (TypeCheckerFailure (lazy "not enough patterns")) + in + (*CSC: supponiamo come prima che nessun controllo sia necessario*) + (*CSC: sugli argomenti di una applicazione *) + List.fold_right + (fun (p,(_,c)) i -> + let rl' = + 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 ~subst context p c rl' safes n nn x + in + i && + check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e + ) pl_and_cl true + | _ -> + List.fold_right + (fun p i -> + i && check_is_really_smaller_arg ~subst context n nn kl x safes p + ) pl true + ) + | C.Fix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,_,ty,bo) i -> + i && + check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl + x_plus_len safes' bo + ) fl true + | C.CoFix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,ty,bo) i -> + i && + check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl + x_plus_len safes' bo + ) fl true + +and guarded_by_destructors ~subst context n nn kl x safes = + let module C = Cic in + let module U = UriManager in + function + C.Rel m when m > n && m <= nn -> false + | C.Rel m -> + (match List.nth context (n-1) with + Some (_,C.Decl _) -> true + | Some (_,C.Def (bo,_)) -> + guarded_by_destructors ~subst context m nn kl x safes + (CicSubstitution.lift m bo) + | None -> raise (TypeCheckerFailure (lazy "Reference to deleted hypothesis")) + ) + | C.Meta _ + | C.Sort _ + | C.Implicit _ -> true + | C.Cast (te,ty) -> + guarded_by_destructors ~subst context n nn kl x safes te && + guarded_by_destructors ~subst context n nn kl x safes ty + | C.Prod (name,so,ta) -> + guarded_by_destructors ~subst context n nn kl x safes so && + guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context) + (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta + | C.Lambda (name,so,ta) -> + guarded_by_destructors ~subst context n nn kl x safes so && + guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context) + (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta + | C.LetIn (name,so,ta) -> + guarded_by_destructors ~subst context n nn kl x safes so && + guarded_by_destructors ~subst ((Some (name,(C.Def (so,None))))::context) + (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta + | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> + let k = List.nth kl (m - n - 1) in + if not (List.length tl > k) then false + else + List.fold_right + (fun param i -> + i && guarded_by_destructors ~subst context n nn kl x safes param + ) tl true && + check_is_really_smaller_arg ~subst context n nn kl x safes (List.nth tl k) + | C.Appl tl -> + List.fold_right + (fun t i -> i && guarded_by_destructors ~subst context n nn kl x safes t) + tl true + | 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 ~subst context n nn kl x safes t) + exp_named_subst true + | C.MutCase (uri,i,outtype,term,pl) -> + (match CicReduction.whd ~subst context term with + C.Rel m when List.mem m safes || m = x -> + let (tys,len,isinductive,paramsno,cl) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (tl,_,paramsno,_) -> + let len = List.length tl in + let (_,isinductive,_,cl) = List.nth tl i in + let tys = + List.map (fun (n,_,ty,_) -> + Some(Cic.Name n,(Cic.Decl ty))) tl + in + let cl' = + List.map + (fun (id,ty) -> + let debrujinedty = debrujin_constructor uri len ty in + (id, snd (split_prods ~subst tys paramsno ty), + snd (split_prods ~subst tys paramsno debrujinedty) + )) cl + in + (tys,len,isinductive,paramsno,cl') + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + in + if not isinductive then + guarded_by_destructors ~subst context n nn kl x safes outtype && + guarded_by_destructors ~subst context n nn kl x safes term && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun p i -> + i && guarded_by_destructors ~subst context n nn kl x safes p) + pl true + else + let pl_and_cl = + try + List.combine pl cl + with + Invalid_argument _ -> + raise (TypeCheckerFailure (lazy "not enough patterns")) + in + guarded_by_destructors ~subst context n nn kl x safes outtype && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun (p,(_,c,brujinedc)) i -> + let rl' = recursive_args tys 0 len brujinedc in + let (e,safes',n',nn',x',context') = + get_new_safes ~subst context p c rl' safes n nn x + in + i && + guarded_by_destructors ~subst context' n' nn' kl x' safes' e + ) pl_and_cl true + | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x -> + let (tys,len,isinductive,paramsno,cl) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (tl,_,paramsno,_) -> + let (_,isinductive,_,cl) = List.nth tl i in + let tys = + List.map + (fun (n,_,ty,_) -> Some(Cic.Name n,(Cic.Decl ty))) tl + in + let cl' = + List.map + (fun (id,ty) -> + (id, snd (split_prods ~subst tys paramsno ty))) cl + in + (tys,List.length tl,isinductive,paramsno,cl') + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + in + if not isinductive then + guarded_by_destructors ~subst context n nn kl x safes outtype && + guarded_by_destructors ~subst context n nn kl x safes term && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun p i -> + i && guarded_by_destructors ~subst context n nn kl x safes p) + pl true + else + let pl_and_cl = + try + List.combine pl cl + with + Invalid_argument _ -> + raise (TypeCheckerFailure (lazy "not enough patterns")) + in + guarded_by_destructors ~subst context n nn kl x safes outtype && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun t i -> + i && guarded_by_destructors ~subst context n nn kl x safes t) + tl true && + List.fold_right + (fun (p,(_,c)) i -> + let rl' = + 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 ~subst context p c rl' safes n nn x + in + i && + guarded_by_destructors ~subst context' n' nn' kl x' safes' e + ) pl_and_cl true + | _ -> + guarded_by_destructors ~subst context n nn kl x safes outtype && + guarded_by_destructors ~subst context n nn kl x safes term && + (*CSC: manca ??? il controllo sul tipo di term? *) + List.fold_right + (fun p i -> i && guarded_by_destructors ~subst context n nn kl x safes p) + pl true + ) + | C.Fix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,_,ty,bo) i -> + i && guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty && + guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl + x_plus_len safes' bo + ) fl true + | C.CoFix (_, fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + and x_plus_len = x + len + and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl + and safes' = List.map (fun x -> x + len) safes in + List.fold_right + (fun (_,ty,bo) i -> + i && + guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty && + guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl + x_plus_len safes' bo + ) fl true + +(* the boolean h means already protected *) +(* args is the list of arguments the type of the constructor that may be *) +(* found in head position must be applied to. *) +and guarded_by_constructors ~subst context n nn h te args coInductiveTypeURI = + let module C = Cic in + (*CSC: There is a lot of code replication between the cases X and *) + (*CSC: (C.Appl X tl). Maybe it will be better to define a function *) + (*CSC: that maps X into (C.Appl X []) when X is not already a C.Appl *) + match CicReduction.whd ~subst context te with + C.Rel m when m > n && m <= nn -> h + | C.Rel _ -> true + | C.Meta _ + | C.Sort _ + | C.Implicit _ + | C.Cast _ + | C.Prod _ + | C.LetIn _ -> + (* the term has just been type-checked *) + raise (AssertFailure (lazy "17")) + | C.Lambda (name,so,de) -> + does_not_occur ~subst context n nn so && + guarded_by_constructors ~subst ((Some (name,(C.Decl so)))::context) + (n + 1) (nn + 1) h de args coInductiveTypeURI + | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> + h && + List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) tl true + | C.Appl ((C.MutConstruct (uri,i,j,exp_named_subst))::tl) -> + let consty = + let obj,_ = + try + CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri + with Not_found -> assert false + in + match obj with + C.InductiveDefinition (itl,_,_,_) -> + let (_,_,_,cl) = List.nth itl i in + let (_,cons) = List.nth cl (j - 1) in + CicSubstitution.subst_vars exp_named_subst cons + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri))) + in + let rec analyse_branch context ty te = + match CicReduction.whd ~subst context ty with + C.Meta _ -> raise (AssertFailure (lazy "34")) + | C.Rel _ + | C.Var _ + | C.Sort _ -> + does_not_occur ~subst context n nn te + | C.Implicit _ + | C.Cast _ -> + raise (AssertFailure (lazy "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 (AssertFailure (lazy "25"))(* due to type-checking *) + | C.Appl ((C.MutInd (uri,_,_))::_) when uri == coInductiveTypeURI -> + guarded_by_constructors ~subst context n nn true te [] + coInductiveTypeURI + | C.Appl ((C.MutInd (uri,_,_))::_) -> + guarded_by_constructors ~subst context n nn true te tl + coInductiveTypeURI + | C.Appl _ -> + does_not_occur ~subst context n nn te + | C.Const _ -> raise (AssertFailure (lazy "26")) + | C.MutInd (uri,_,_) when uri == coInductiveTypeURI -> + guarded_by_constructors ~subst context n nn true te [] + coInductiveTypeURI + | C.MutInd _ -> + does_not_occur ~subst context n nn te + | C.MutConstruct _ -> raise (AssertFailure (lazy "27")) + (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *) + (*CSC: in head position. *) + | C.MutCase _ + | C.Fix _ + | C.CoFix _ -> + raise (AssertFailure (lazy "28"))(* due to type-checking *) + in + let rec analyse_instantiated_type context ty l = + match CicReduction.whd ~subst context ty with + C.Rel _ + | C.Var _ + | C.Meta _ + | C.Sort _ + | C.Implicit _ + | C.Cast _ -> raise (AssertFailure (lazy "29"))(* due to type-checking *) + | C.Prod (name,so,de) -> + begin + match l with + [] -> true + | he::tl -> + analyse_branch context so he && + analyse_instantiated_type + ((Some (name,(C.Decl so)))::context) de tl + end + | C.Lambda _ + | C.LetIn _ -> + raise (AssertFailure (lazy "30"))(* due to type-checking *) + | C.Appl _ -> + List.fold_left + (fun i x -> i && does_not_occur ~subst context n nn x) true l + | C.Const _ -> raise (AssertFailure (lazy "31")) + | C.MutInd _ -> + List.fold_left + (fun i x -> i && does_not_occur ~subst context n nn x) true l + | C.MutConstruct _ -> raise (AssertFailure (lazy "32")) + (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *) + (*CSC: in head position. *) + | C.MutCase _ + | C.Fix _ + | C.CoFix _ -> + raise (AssertFailure (lazy "33"))(* due to type-checking *) + in + let rec instantiate_type args consty = + function + [] -> true + | tlhe::tltl as l -> + let consty' = CicReduction.whd ~subst context consty in + match args with + he::tl -> + begin + match consty' with + C.Prod (_,_,de) -> + let instantiated_de = CicSubstitution.subst he de in + (*CSC: siamo sicuri che non sia troppo forte? *) + does_not_occur ~subst context n nn tlhe & + instantiate_type tl instantiated_de tltl + | _ -> + (*CSC:We do not consider backbones with a MutCase, a *) + (*CSC:FixPoint, a CoFixPoint and so on in head position.*) + raise (AssertFailure (lazy "23")) + end + | [] -> analyse_instantiated_type context consty' l + (* These are all the other cases *) + in + instantiate_type args consty tl + | C.Appl ((C.CoFix (_,fl))::tl) -> + List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl && + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *) + and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in + List.fold_right + (fun (_,ty,bo) i -> + i && does_not_occur ~subst context n nn ty && + guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len + h bo args coInductiveTypeURI + ) fl true + | C.Appl ((C.MutCase (_,_,out,te,pl))::tl) -> + List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl && + does_not_occur ~subst context n nn out && + does_not_occur ~subst context n nn te && + List.fold_right + (fun x i -> + i && + guarded_by_constructors ~subst context n nn h x args + coInductiveTypeURI + ) pl true + | C.Appl l -> + List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true + | C.Var (_,exp_named_subst) + | C.Const (_,exp_named_subst) -> + List.fold_right + (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true + | C.MutInd _ -> assert false + | C.MutConstruct (_,_,_,exp_named_subst) -> + List.fold_right + (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true + | C.MutCase (_,_,out,te,pl) -> + does_not_occur ~subst context n nn out && + does_not_occur ~subst context n nn te && + List.fold_right + (fun x i -> + i && + guarded_by_constructors ~subst context n nn h x args + coInductiveTypeURI + ) pl true + | C.Fix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *) + and tys = List.map (fun (n,_,ty,_)-> Some (C.Name n,(C.Decl ty))) fl in + List.fold_right + (fun (_,_,ty,bo) i -> + i && does_not_occur ~subst context n nn ty && + does_not_occur ~subst (tys@context) n_plus_len nn_plus_len bo + ) fl true + | C.CoFix (_,fl) -> + let len = List.length fl in + let n_plus_len = n + len + and nn_plus_len = nn + len + (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *) + and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in + List.fold_right + (fun (_,ty,bo) i -> + i && does_not_occur ~subst context n nn ty && + guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len + h bo + args coInductiveTypeURI + ) fl true + +and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i + need_dummy ind arity1 arity2 ugraph = + let module C = Cic in + let module U = UriManager in + let arity1 = CicReduction.whd ~subst context arity1 in + let rec check_allowed_sort_elimination_aux ugraph context arity2 need_dummy = + match arity1, CicReduction.whd ~subst context arity2 with + (C.Prod (_,so1,de1), C.Prod (_,so2,de2)) -> + let b,ugraph1 = + CicReduction.are_convertible ~subst ~metasenv context so1 so2 ugraph in + if b then + check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i + need_dummy (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2 + ugraph1 + else + false,ugraph1 + | (C.Sort _, C.Prod (name,so,ta)) when not need_dummy -> + let b,ugraph1 = + CicReduction.are_convertible ~subst ~metasenv context so ind ugraph in + if not b then + false,ugraph1 + else + check_allowed_sort_elimination_aux ugraph1 + ((Some (name,C.Decl so))::context) ta true + | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true,ugraph + | (C.Sort C.Prop, C.Sort C.Set) + | (C.Sort C.Prop, C.Sort C.CProp) + | (C.Sort C.Prop, C.Sort (C.Type _) ) when need_dummy -> + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (itl,_,paramsno,_) -> + let itl_len = List.length itl in + let (name,_,ty,cl) = List.nth itl i in + let cl_len = List.length cl in + if (cl_len = 0 || (itl_len = 1 && cl_len = 1)) then + let non_informative,ugraph = + if cl_len = 0 then true,ugraph + else + is_non_informative ~logger [Some (C.Name name,C.Decl ty)] + paramsno (snd (List.nth cl 0)) ugraph + in + (* is it a singleton or empty non recursive and non informative + definition? *) + non_informative, ugraph + else + false,ugraph + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + ) + | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true , ugraph + | (C.Sort C.CProp, C.Sort C.Prop) when need_dummy -> true , ugraph + | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true , ugraph + | (C.Sort C.Set, C.Sort C.CProp) when need_dummy -> true , ugraph + | (C.Sort C.CProp, C.Sort C.Set) when need_dummy -> true , ugraph + | (C.Sort C.CProp, C.Sort C.CProp) when need_dummy -> true , ugraph + | ((C.Sort C.Set, C.Sort (C.Type _)) | (C.Sort C.CProp, C.Sort (C.Type _))) + when need_dummy -> + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (itl,_,paramsno,_) -> + let tys = + List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl + in + let (_,_,_,cl) = List.nth itl i in + (List.fold_right + (fun (_,x) (i,ugraph) -> + if i then + is_small ~logger tys paramsno x ugraph + else + false,ugraph + ) cl (true,ugraph)) + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + ) + | (C.Sort (C.Type _), C.Sort _) when need_dummy -> true , ugraph + | (_,_) -> false,ugraph + in + check_allowed_sort_elimination_aux ugraph context arity2 need_dummy + +and type_of_branch ~subst context argsno need_dummy outtype term constype = + let module C = Cic in + let module R = CicReduction in + match R.whd ~subst context constype with + C.MutInd (_,_,_) -> + if need_dummy then + outtype + else + C.Appl [outtype ; term] + | C.Appl (C.MutInd (_,_,_)::tl) -> + let (_,arguments) = split tl argsno + in + if need_dummy && arguments = [] then + outtype + else + C.Appl (outtype::arguments@(if need_dummy then [] else [term])) + | C.Prod (name,so,de) -> + let term' = + match CicSubstitution.lift 1 term with + C.Appl l -> C.Appl (l@[C.Rel 1]) + | t -> C.Appl [t ; C.Rel 1] + in + C.Prod (C.Anonymous,so,type_of_branch ~subst + ((Some (name,(C.Decl so)))::context) argsno need_dummy + (CicSubstitution.lift 1 outtype) term' de) + | _ -> raise (AssertFailure (lazy "20")) + +(* 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 ~logger ~subst metasenv context + canonical_context l ugraph += + 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.subst_meta l (S.lift i t))))::(aux (i+1) tl) + | (Some (n,C.Def (t,None)))::tl -> + (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl) + | None::tl -> None::(aux (i+1) tl) + | (Some (n,C.Def (t,Some ty)))::tl -> + (Some (n,C.Def ((S.subst_meta l (S.lift i t)),Some (S.subst_meta l (S.lift i ty)))))::(aux (i+1) tl) + in + aux 1 canonical_context + in + List.fold_left2 + (fun ugraph t ct -> + match (t,ct) with + | _,None -> ugraph + | Some t,Some (_,C.Def (ct,_)) -> + let b,ugraph1 = + R.are_convertible ~subst ~metasenv context t ct ugraph + in + if not b then + raise + (TypeCheckerFailure + (lazy (sprintf "Not well typed metavariable local context: expected a term convertible with %s, found %s" (CicPp.ppterm ct) (CicPp.ppterm t)))) + else + ugraph1 + | Some t,Some (_,C.Decl ct) -> + let type_t,ugraph1 = + type_of_aux' ~logger ~subst metasenv context t ugraph + in + let b,ugraph2 = + R.are_convertible ~subst ~metasenv context type_t ct ugraph1 + in + if not b then + raise (TypeCheckerFailure + (lazy (sprintf "Not well typed metavariable local context: expected a term of type %s, found %s of type %s" + (CicPp.ppterm ct) (CicPp.ppterm t) + (CicPp.ppterm type_t)))) + else + ugraph2 + | None, _ -> + raise (TypeCheckerFailure + (lazy ("Not well typed metavariable local context: "^ + "an hypothesis, that is not hidden, is not instantiated"))) + ) ugraph l lifted_canonical_context + + +(* + type_of_aux' is just another name (with a different scope) + for type_of_aux +*) + +and type_of_aux' ~logger ?(subst = []) metasenv context t ugraph = + let rec type_of_aux ~logger context t ugraph = + let module C = Cic in + let module R = CicReduction in + let module S = CicSubstitution in + let module U = UriManager in + match t with + C.Rel n -> + (try + match List.nth context (n - 1) with + Some (_,C.Decl t) -> S.lift n t,ugraph + | Some (_,C.Def (_,Some ty)) -> S.lift n ty,ugraph + | Some (_,C.Def (bo,None)) -> + debug_print (lazy "##### CASO DA INVESTIGARE E CAPIRE") ; + type_of_aux ~logger context (S.lift n bo) ugraph + | None -> raise + (TypeCheckerFailure (lazy "Reference to deleted hypothesis")) + with + _ -> + raise (TypeCheckerFailure (lazy "unbound variable")) + ) + | C.Var (uri,exp_named_subst) -> + incr fdebug ; + let ugraph1 = + check_exp_named_subst ~logger ~subst context exp_named_subst ugraph + in + let ty,ugraph2 = type_of_variable ~logger uri ugraph1 in + let ty1 = CicSubstitution.subst_vars exp_named_subst ty in + decr fdebug ; + ty1,ugraph2 + | C.Meta (n,l) -> + (try + let (canonical_context,term,ty) = CicUtil.lookup_subst n subst in + let ugraph1 = + check_metasenv_consistency ~logger + ~subst metasenv context canonical_context l ugraph + in + (* assuming subst is well typed !!!!! *) + ((CicSubstitution.subst_meta l ty), ugraph1) + (* type_of_aux context (CicSubstitution.subst_meta l term) *) + with CicUtil.Subst_not_found _ -> + let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in + let ugraph1 = + check_metasenv_consistency ~logger + ~subst metasenv context canonical_context l ugraph + in + ((CicSubstitution.subst_meta l ty),ugraph1)) + (* TASSI: CONSTRAINTS *) + | C.Sort (C.Type t) -> + let t' = CicUniv.fresh() in + let ugraph1 = CicUniv.add_gt t' t ugraph in + (C.Sort (C.Type t')),ugraph1 + (* TASSI: CONSTRAINTS *) + | C.Sort s -> (C.Sort (C.Type (CicUniv.fresh ()))),ugraph + | C.Implicit _ -> raise (AssertFailure (lazy "21")) + | C.Cast (te,ty) as t -> + let _,ugraph1 = type_of_aux ~logger context ty ugraph in + let ty_te,ugraph2 = type_of_aux ~logger context te ugraph1 in + let b,ugraph3 = + R.are_convertible ~subst ~metasenv context ty_te ty ugraph2 + in + if b then + ty,ugraph3 + else + raise (TypeCheckerFailure + (lazy (sprintf "Invalid cast %s" (CicPp.ppterm t)))) + | C.Prod (name,s,t) -> + let sort1,ugraph1 = type_of_aux ~logger context s ugraph in + let sort2,ugraph2 = + type_of_aux ~logger ((Some (name,(C.Decl s)))::context) t ugraph1 + in + sort_of_prod ~subst context (name,s) (sort1,sort2) ugraph2 + | C.Lambda (n,s,t) -> + let sort1,ugraph1 = type_of_aux ~logger context s ugraph in + (match R.whd ~subst context sort1 with + C.Meta _ + | C.Sort _ -> () + | _ -> + raise + (TypeCheckerFailure (lazy (sprintf + "Not well-typed lambda-abstraction: the source %s should be a type; instead it is a term of type %s" (CicPp.ppterm s) + (CicPp.ppterm sort1)))) + ) ; + let type2,ugraph2 = + type_of_aux ~logger ((Some (n,(C.Decl s)))::context) t ugraph1 + in + (C.Prod (n,s,type2)),ugraph2 + | C.LetIn (n,s,t) -> + (* only to check if s is well-typed *) + let ty,ugraph1 = type_of_aux ~logger context s ugraph in + (* 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 ~subst 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. *) + let ty1,ugraph2 = + type_of_aux ~logger + ((Some (n,(C.Def (s,Some ty))))::context) t ugraph1 + in + (CicSubstitution.subst s ty1),ugraph2 + | C.Appl (he::tl) when List.length tl > 0 -> + let hetype,ugraph1 = type_of_aux ~logger context he ugraph in + let tlbody_and_type,ugraph2 = + List.fold_right ( + fun x (l,ugraph) -> + let ty,ugraph1 = type_of_aux ~logger context x ugraph in + let _,ugraph1 = type_of_aux ~logger context ty ugraph1 in + ((x,ty)::l,ugraph1)) + tl ([],ugraph1) + in + (* TASSI: questa c'era nel mio... ma non nel CVS... *) + (* let _,ugraph2 = type_of_aux context hetype ugraph2 in *) + eat_prods ~subst context hetype tlbody_and_type ugraph2 + | C.Appl _ -> raise (AssertFailure (lazy "Appl: no arguments")) + | C.Const (uri,exp_named_subst) -> + incr fdebug ; + let ugraph1 = + check_exp_named_subst ~logger ~subst context exp_named_subst ugraph + in + let cty,ugraph2 = type_of_constant ~logger uri ugraph1 in + let cty1 = + CicSubstitution.subst_vars exp_named_subst cty + in + decr fdebug ; + cty1,ugraph2 + | C.MutInd (uri,i,exp_named_subst) -> + incr fdebug ; + let ugraph1 = + check_exp_named_subst ~logger ~subst context exp_named_subst ugraph + in + (* TASSI: da me c'era anche questa, ma in CVS no *) + let mty,ugraph2 = type_of_mutual_inductive_defs ~logger uri i ugraph1 in + (* fine parte dubbia *) + let cty = + CicSubstitution.subst_vars exp_named_subst mty + in + decr fdebug ; + cty,ugraph2 + | C.MutConstruct (uri,i,j,exp_named_subst) -> + let ugraph1 = + check_exp_named_subst ~logger ~subst context exp_named_subst ugraph + in + (* TASSI: idem come sopra *) + let mty,ugraph2 = + type_of_mutual_inductive_constr ~logger uri i j ugraph1 + in + let cty = + CicSubstitution.subst_vars exp_named_subst mty + in + cty,ugraph2 + | C.MutCase (uri,i,outtype,term,pl) -> + let outsort,ugraph1 = type_of_aux ~logger context outtype ugraph in + let (need_dummy, k) = + let rec guess_args context t = + let outtype = CicReduction.whd ~subst context t in + match outtype with + C.Sort _ -> (true, 0) + | C.Prod (name, s, t) -> + let (b, n) = + guess_args ((Some (name,(C.Decl s)))::context) t in + if n = 0 then + (* last prod before sort *) + match CicReduction.whd ~subst context s with +(*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 + (TypeCheckerFailure + (lazy (sprintf + "Malformed case analasys' output type %s" + (CicPp.ppterm outtype)))) + in +(* + let (parameters, arguments, exp_named_subst),ugraph2 = + let ty,ugraph2 = type_of_aux context term ugraph1 in + match R.whd ~subst context ty with + (*CSC manca il caso dei CAST *) +(*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),ugraph2 + else + raise + (TypeCheckerFailure + (lazy (sprintf + ("Case analysys: analysed term type is %s, but is expected to be (an application of) %s#1/%d{_}") + (CicPp.ppterm typ) (U.string_of_uri uri) i))) + | C.Appl + ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' -> + if U.eq uri uri' && i = i' then + let params,args = + split tl (List.length tl - k) + in (params,args,exp_named_subst),ugraph2 + else + raise + (TypeCheckerFailure + (lazy (sprintf + ("Case analysys: analysed term type is %s, "^ + "but is expected to be (an application of) "^ + "%s#1/%d{_}") + (CicPp.ppterm typ') (U.string_of_uri uri) i))) + | _ -> + raise + (TypeCheckerFailure + (lazy (sprintf + ("Case analysis: "^ + "analysed term %s is not an inductive one") + (CicPp.ppterm term)))) +*) + let (b, k) = guess_args context outsort in + if not b then (b, k - 1) else (b, k) in + let (parameters, arguments, exp_named_subst),ugraph2 = + let ty,ugraph2 = type_of_aux ~logger context term ugraph1 in + match R.whd ~subst context ty with + C.MutInd (uri',i',exp_named_subst) as typ -> + if U.eq uri uri' && i = i' then + ([],[],exp_named_subst),ugraph2 + else raise + (TypeCheckerFailure + (lazy (sprintf + ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}") + (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) 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),ugraph2 + else raise + (TypeCheckerFailure + (lazy (sprintf + ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}") + (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i))) + | _ -> + raise + (TypeCheckerFailure + (lazy (sprintf + "Case analysis: analysed term %s is not an inductive one" + (CicPp.ppterm term)))) + 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,i,exp_named_subst) + else + C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters) + in + let type_of_sort_of_ind_ty,ugraph3 = + type_of_aux ~logger context sort_of_ind_type ugraph2 in + let b,ugraph4 = + check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i + need_dummy sort_of_ind_type type_of_sort_of_ind_ty outsort ugraph3 + in + if not b then + raise + (TypeCheckerFailure (lazy ("Case analasys: sort elimination not allowed"))); + (* let's check if the type of branches are right *) + let parsno = + let obj,_ = + try + CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri + with Not_found -> assert false + in + match obj with + C.InductiveDefinition (_,_,parsno,_) -> parsno + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + in + let (_,branches_ok,ugraph5) = + List.fold_left + (fun (j,b,ugraph) p -> + if b then + let cons = + if parameters = [] then + (C.MutConstruct (uri,i,j,exp_named_subst)) + else + (C.Appl + (C.MutConstruct (uri,i,j,exp_named_subst)::parameters)) + in + let ty_p,ugraph1 = type_of_aux ~logger context p ugraph in + let ty_cons,ugraph3 = type_of_aux ~logger context cons ugraph1 in + (* 2 is skipped *) + let ty_branch = + type_of_branch ~subst context parsno need_dummy outtype cons + ty_cons in + let b1,ugraph4 = + R.are_convertible + ~subst ~metasenv context ty_p ty_branch ugraph3 + in + if not b1 then + debug_print (lazy + ("#### " ^ CicPp.ppterm ty_p ^ + " <==> " ^ CicPp.ppterm ty_branch)); + (j + 1,b1,ugraph4) + else + (j,false,ugraph) + ) (1,true,ugraph4) pl + in + if not branches_ok then + raise + (TypeCheckerFailure (lazy "Case analysys: wrong branch type")); + let arguments' = + if not need_dummy then outtype::arguments@[term] + else outtype::arguments in + let outtype = + if need_dummy && arguments = [] then outtype + else CicReduction.head_beta_reduce (C.Appl arguments') + in + outtype,ugraph5 + | C.Fix (i,fl) -> + let types_times_kl,ugraph1 = + (* WAS: list rev list map *) + List.fold_left + (fun (l,ugraph) (n,k,ty,_) -> + let _,ugraph1 = type_of_aux ~logger context ty ugraph in + ((Some (C.Name n,(C.Decl ty)),k)::l,ugraph1) + ) ([],ugraph) fl + in + let (types,kl) = List.split types_times_kl in + let len = List.length types in + let ugraph2 = + List.fold_left + (fun ugraph (name,x,ty,bo) -> + let ty_bo,ugraph1 = + type_of_aux ~logger (types@context) bo ugraph + in + let b,ugraph2 = + R.are_convertible ~subst ~metasenv (types@context) + ty_bo (CicSubstitution.lift len ty) ugraph1 in + if b then + begin + let (m, eaten, context') = + eat_lambdas ~subst (types @ context) (x + 1) bo + in + (* + let's control the guarded by + destructors conditions D{f,k,x,M} + *) + if not (guarded_by_destructors ~subst context' eaten + (len + eaten) kl 1 [] m) then + raise + (TypeCheckerFailure + (lazy ("Fix: not guarded by destructors"))) + else + ugraph2 + end + else + raise (TypeCheckerFailure (lazy ("Fix: ill-typed bodies"))) + ) ugraph1 fl in + (*CSC: controlli mancanti solo su D{f,k,x,M} *) + let (_,_,ty,_) = List.nth fl i in + ty,ugraph2 + | C.CoFix (i,fl) -> + let types,ugraph1 = + List.fold_left + (fun (l,ugraph) (n,ty,_) -> + let _,ugraph1 = + type_of_aux ~logger context ty ugraph in + (Some (C.Name n,(C.Decl ty))::l,ugraph1) + ) ([],ugraph) fl + in + let len = List.length types in + let ugraph2 = + List.fold_left + (fun ugraph (_,ty,bo) -> + let ty_bo,ugraph1 = + type_of_aux ~logger (types @ context) bo ugraph + in + let b,ugraph2 = + R.are_convertible ~subst ~metasenv (types @ context) ty_bo + (CicSubstitution.lift len ty) ugraph1 + in + if b then + begin + (* let's control that the returned type is coinductive *) + match returns_a_coinductive ~subst context ty with + None -> + raise + (TypeCheckerFailure + (lazy "CoFix: does not return a coinductive type")) + | Some uri -> + (* + let's control the guarded by constructors + conditions C{f,M} + *) + if not (guarded_by_constructors ~subst + (types @ context) 0 len false bo [] uri) then + raise + (TypeCheckerFailure + (lazy "CoFix: not guarded by constructors")) + else + ugraph2 + end + else + raise + (TypeCheckerFailure (lazy "CoFix: ill-typed bodies")) + ) ugraph1 fl + in + let (_,ty,_) = List.nth fl i in + ty,ugraph2 + + and check_exp_named_subst ~logger ~subst context ugraph = + let rec check_exp_named_subst_aux ~logger esubsts l ugraph = + match l with + [] -> ugraph + | ((uri,t) as item)::tl -> + let ty_uri,ugraph1 = type_of_variable ~logger uri ugraph in + let typeofvar = + CicSubstitution.subst_vars esubsts ty_uri in + let typeoft,ugraph2 = type_of_aux ~logger context t ugraph1 in + let b,ugraph3 = + CicReduction.are_convertible ~subst ~metasenv + context typeoft typeofvar ugraph2 + in + if b then + check_exp_named_subst_aux ~logger (esubsts@[item]) tl ugraph3 + else + begin + CicReduction.fdebug := 0 ; + ignore + (CicReduction.are_convertible + ~subst ~metasenv context typeoft typeofvar ugraph2) ; + fdebug := 0 ; + debug typeoft [typeofvar] ; + raise (TypeCheckerFailure (lazy "Wrong Explicit Named Substitution")) + end + in + check_exp_named_subst_aux ~logger [] ugraph + + and sort_of_prod ~subst context (name,s) (t1, t2) ugraph = + let module C = Cic in + let t1' = CicReduction.whd ~subst context t1 in + let t2' = CicReduction.whd ~subst ((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 or s2 = C.CProp) -> + (* different from Coq manual!!! *) + C.Sort s2,ugraph + | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> + (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *) + let t' = CicUniv.fresh() in + let ugraph1 = CicUniv.add_ge t' t1 ugraph in + let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in + C.Sort (C.Type t'),ugraph2 + | (C.Sort _,C.Sort (C.Type t1)) -> + (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *) + C.Sort (C.Type t1),ugraph (* c'e' bisogno di un fresh? *) + | (C.Meta _, C.Sort _) -> t2',ugraph + | (C.Meta _, (C.Meta (_,_) as t)) + | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t -> + t2',ugraph + | (_,_) -> raise (TypeCheckerFailure (lazy (sprintf + "Prod: expected two sorts, found = %s, %s" (CicPp.ppterm t1') + (CicPp.ppterm t2')))) + + and eat_prods ~subst context hetype l ugraph = + (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *) + (*CSC: cucinati *) + match l with + [] -> hetype,ugraph + | (hete, hety)::tl -> + (match (CicReduction.whd ~subst context hetype) with + Cic.Prod (n,s,t) -> + let b,ugraph1 = + CicReduction.are_convertible + ~subst ~metasenv context hety s ugraph + in + if b then + begin + CicReduction.fdebug := -1 ; + eat_prods ~subst context + (CicSubstitution.subst hete t) tl ugraph1 + (*TASSI: not sure *) + end + else + begin + CicReduction.fdebug := 0 ; + ignore (CicReduction.are_convertible + ~subst ~metasenv context s hety ugraph) ; + fdebug := 0 ; + debug s [hety] ; + raise + (TypeCheckerFailure + (lazy (sprintf + ("Appl: wrong parameter-type, expected %s, found %s") + (CicPp.ppterm hetype) (CicPp.ppterm s)))) + end + | _ -> + raise (TypeCheckerFailure + (lazy "Appl: this is not a function, it cannot be applied")) + ) + + and returns_a_coinductive ~subst context ty = + let module C = Cic in + match CicReduction.whd ~subst context ty with + C.MutInd (uri,i,_) -> + (*CSC: definire una funzioncina per questo codice sempre replicato *) + let obj,_ = + try + CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri + with Not_found -> assert false + in + (match obj with + C.InductiveDefinition (itl,_,_,_) -> + let (_,is_inductive,_,_) = List.nth itl i in + if is_inductive then None else (Some uri) + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + ) + | C.Appl ((C.MutInd (uri,i,_))::_) -> + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (itl,_,_,_) -> + let (_,is_inductive,_,_) = List.nth itl i in + if is_inductive then None else (Some uri) + | _ -> + raise (TypeCheckerFailure + (lazy ("Unknown mutual inductive definition:" ^ + UriManager.string_of_uri uri))) + ) + | C.Prod (n,so,de) -> + returns_a_coinductive ~subst ((Some (n,C.Decl so))::context) de + | _ -> None + + in +(*CSC +debug_print (lazy ("INIZIO TYPE_OF_AUX " ^ CicPp.ppterm t)) ; flush stderr ; +let res = +*) + type_of_aux ~logger context t ugraph +(* +in debug_print (lazy "FINE TYPE_OF_AUX") ; flush stderr ; res +*) + +(* is a small constructor? *) +(*CSC: ottimizzare calcolando staticamente *) +and is_small_or_non_informative ~condition ~logger context paramsno c ugraph = + let rec is_small_or_non_informative_aux ~logger context c ugraph = + let module C = Cic in + match CicReduction.whd context c with + C.Prod (n,so,de) -> + let s,ugraph1 = type_of_aux' ~logger [] context so ugraph in + let b = condition s in + if b then + is_small_or_non_informative_aux + ~logger ((Some (n,(C.Decl so)))::context) de ugraph1 + else + false,ugraph1 + | _ -> true,ugraph (*CSC: we trust the type-checker *) + in + let (context',dx) = split_prods ~subst:[] context paramsno c in + is_small_or_non_informative_aux ~logger context' dx ugraph + +and is_small ~logger = + is_small_or_non_informative + ~condition:(fun s -> s=Cic.Sort Cic.Prop || s=Cic.Sort Cic.Set) + ~logger + +and is_non_informative ~logger = + is_small_or_non_informative + ~condition:(fun s -> s=Cic.Sort Cic.Prop) + ~logger + +and type_of ~logger t ugraph = +(*CSC +debug_print (lazy ("INIZIO TYPE_OF_AUX' " ^ CicPp.ppterm t)) ; flush stderr ; +let res = +*) + type_of_aux' ~logger [] [] t ugraph +(*CSC +in debug_print (lazy "FINE TYPE_OF_AUX'") ; flush stderr ; res +*) +;; + +let typecheck_obj0 ~logger uri ugraph = + let module C = Cic in + function + C.Constant (_,Some te,ty,_,_) -> + let _,ugraph = type_of ~logger ty ugraph in + let ty_te,ugraph = type_of ~logger te ugraph in + let b,ugraph = (CicReduction.are_convertible [] ty_te ty ugraph) in + if not b then + raise (TypeCheckerFailure + (lazy + ("the type of the body is not the one expected:\n" ^ + CicPp.ppterm ty_te ^ "\nvs\n" ^ + CicPp.ppterm ty))) + else + ugraph + | C.Constant (_,None,ty,_,_) -> + (* only to check that ty is well-typed *) + let _,ugraph = type_of ~logger ty ugraph in + ugraph + | C.CurrentProof (_,conjs,te,ty,_,_) -> + let _,ugraph = + List.fold_left + (fun (metasenv,ugraph) ((_,context,ty) as conj) -> + let _,ugraph = + type_of_aux' ~logger metasenv context ty ugraph + in + metasenv @ [conj],ugraph + ) ([],ugraph) conjs + in + let _,ugraph = type_of_aux' ~logger conjs [] ty ugraph in + let type_of_te,ugraph = + type_of_aux' ~logger conjs [] te ugraph + in + let b,ugraph = CicReduction.are_convertible [] type_of_te ty ugraph in + if not b then + raise (TypeCheckerFailure (lazy (sprintf + "the current proof is not well typed because the type %s of the body is not convertible to the declared type %s" + (CicPp.ppterm type_of_te) (CicPp.ppterm ty)))) + else + ugraph + | C.Variable (_,bo,ty,_,_) -> + (* only to check that ty is well-typed *) + let _,ugraph = type_of ~logger ty ugraph in + (match bo with + None -> ugraph + | Some bo -> + let ty_bo,ugraph = type_of ~logger bo ugraph in + let b,ugraph = CicReduction.are_convertible [] ty_bo ty ugraph in + if not b then + raise (TypeCheckerFailure + (lazy "the body is not the one expected")) + else + ugraph + ) + | (C.InductiveDefinition _ as obj) -> + check_mutual_inductive_defs ~logger uri obj ugraph + +let typecheck uri = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let logger = new CicLogger.logger in + (* ??? match CicEnvironment.is_type_checked ~trust:true uri with ???? *) + match CicEnvironment.is_type_checked ~trust:false CicUniv.empty_ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> + (* debug_print (lazy ("NON-INIZIO A TYPECHECKARE " ^ U.string_of_uri uri));*) + cobj,ugraph' + | CicEnvironment.UncheckedObj uobj -> + (* let's typecheck the uncooked object *) + logger#log (`Start_type_checking uri) ; + (* debug_print (lazy ("INIZIO A TYPECHECKARE " ^ U.string_of_uri uri)); *) + let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph uobj in + try + CicEnvironment.set_type_checking_info uri; + logger#log (`Type_checking_completed uri); + match CicEnvironment.is_type_checked ~trust:false ugraph uri with + CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' + | _ -> raise CicEnvironmentError + with + (* + this is raised if set_type_checking_info is called on an object + that has no associated universe file. If we are in univ_maker + phase this is OK since univ_maker will properly commit the + object. + *) + Invalid_argument s -> + (*debug_print (lazy s);*) + uobj,ugraph +;; + +let typecheck_obj ~logger uri obj = + let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph obj in + let ugraph, univlist, obj = CicUnivUtils.clean_and_fill uri obj ugraph in + CicEnvironment.add_type_checked_obj uri (obj,ugraph,univlist) + +(** wrappers which instantiate fresh loggers *) + +let type_of_aux' ?(subst = []) metasenv context t ugraph = + let logger = new CicLogger.logger in + type_of_aux' ~logger ~subst metasenv context t ugraph + +let typecheck_obj uri obj = + let logger = new CicLogger.logger in + typecheck_obj ~logger uri obj + +(* check_allowed_sort_elimination uri i s1 s2 + This function is used outside the kernel to determine in advance whether + a MutCase will be allowed or not. + [uri,i] is the type of the term to match + [s1] is the sort of the term to eliminate (i.e. the head of the arity + of the inductive type [uri,i]) + [s2] is the sort of the goal (i.e. the head of the type of the outtype + of the MutCase) *) +let check_allowed_sort_elimination uri i s1 s2 = + fst (check_allowed_sort_elimination ~subst:[] ~metasenv:[] + ~logger:(new CicLogger.logger) [] uri i true + (Cic.Implicit None) (* never used *) (Cic.Sort s1) (Cic.Sort s2) + CicUniv.empty_ugraph) diff --git a/helm/software/components/cic_proof_checking/cicTypeChecker.mli b/helm/software/components/cic_proof_checking/cicTypeChecker.mli new file mode 100644 index 000000000..e9419171e --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicTypeChecker.mli @@ -0,0 +1,61 @@ +(* 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/. + *) + +(* These are the only exceptions that will be raised *) +exception TypeCheckerFailure of string Lazy.t +exception AssertFailure of string Lazy.t + +(* this function is exported to be used also by the refiner; + the callback function (defaul value: ignore) is invoked on each + processed subterm; its first argument is the undebrujined term (the + input); its second argument the corresponding debrujined term (the + output). The callback is used to relocalize the error messages *) +val debrujin_constructor : + ?cb:(Cic.term -> Cic.term -> unit) -> + UriManager.uri -> int -> Cic.term -> Cic.term + +val typecheck : UriManager.uri -> Cic.obj * CicUniv.universe_graph + +(* FUNCTIONS USED ONLY IN THE TOPLEVEL *) + +(* type_of_aux' metasenv context term *) +val type_of_aux': + ?subst:Cic.substitution -> Cic.metasenv -> Cic.context -> + Cic.term -> CicUniv.universe_graph -> + Cic.term * CicUniv.universe_graph + +(* typechecks the obj and puts it in the environment *) +val typecheck_obj : UriManager.uri -> Cic.obj -> unit + +(* check_allowed_sort_elimination uri i s1 s2 + This function is used outside the kernel to determine in advance whether + a MutCase will be allowed or not. + [uri,i] is the type of the term to match + [s1] is the sort of the term to eliminate (i.e. the head of the arity + of the inductive type [uri,i]) + [s2] is the sort of the goal (i.e. the head of the type of the outtype + of the MutCase) *) +val check_allowed_sort_elimination: + UriManager.uri -> int -> Cic.sort -> Cic.sort -> bool diff --git a/helm/software/components/cic_proof_checking/cicUnivUtils.ml b/helm/software/components/cic_proof_checking/cicUnivUtils.ml new file mode 100644 index 000000000..cd1aeba32 --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicUnivUtils.ml @@ -0,0 +1,153 @@ +(* 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 *) +(* *) +(* Enrico Tassi *) +(* 23/04/2004 *) +(* *) +(* This module implements some useful function regarding univers graphs *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +module C = Cic +module H = UriManager.UriHashtbl +let eq = UriManager.eq + +(* uri is the uri of the actual object that must be 'skipped' *) +let universes_of_obj uri t = + (* don't the same work twice *) + let visited_objs = H.create 31 in + let visited u = H.replace visited_objs u true in + let is_not_visited u = not (H.mem visited_objs u) in + visited uri; + (* the result *) + let results = ref [] in + let add_result l = results := l :: !results in + (* the iterators *) + let rec aux = function + | C.Const (u,exp_named_subst) when is_not_visited u -> + aux_uri u; + visited u; + C.Const (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.Var (u,exp_named_subst) when is_not_visited u -> + aux_uri u; + visited u; + C.Var (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.Const (u,exp_named_subst) -> + C.Const (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.Var (u,exp_named_subst) -> + C.Var (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.MutInd (u,x,exp_named_subst) when is_not_visited u -> + aux_uri u; + visited u; + C.MutInd (u,x,List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.MutInd (u,x,exp_named_subst) -> + C.MutInd (u,x, List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.MutConstruct (u,x,y,exp_named_subst) when is_not_visited u -> + aux_uri u; + visited u; + C.MutConstruct (u,x,y,List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.MutConstruct (x,y,z,exp_named_subst) -> + C.MutConstruct (x,y,z,List.map (fun (x,t) -> x,aux t) exp_named_subst) + | C.Meta (n,l1) -> C.Meta (n, List.map (HExtlib.map_option aux) l1) + | C.Sort (C.Type i) -> add_result [i]; + C.Sort (C.Type (CicUniv.name_universe i uri)) + | C.Rel _ + | C.Sort _ + | C.Implicit _ as x -> x + | C.Cast (v,t) -> C.Cast (aux v, aux t) + | C.Prod (b,s,t) -> C.Prod (b,aux s, aux t) + | C.Lambda (b,s,t) -> C.Lambda (b,aux s, aux t) + | C.LetIn (b,s,t) -> C.LetIn (b,aux s, aux t) + | C.Appl li -> C.Appl (List.map aux li) + | C.MutCase (uri,n1,ty,te,patterns) -> + C.MutCase (uri,n1,aux ty,aux te, List.map aux patterns) + | C.Fix (no, funs) -> + C.Fix(no, List.map (fun (x,y,b,c) -> (x,y,aux b,aux c)) funs) + | C.CoFix (no,funs) -> + C.CoFix(no, List.map (fun (x,b,c) -> (x,aux b,aux c)) funs) + and aux_uri u = + if is_not_visited u then + let _, _, l = + CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph u in + add_result l + and aux_obj = function + | C.Constant (x,Some te,ty,v,y) -> + List.iter aux_uri v; + C.Constant (x,Some (aux te),aux ty,v,y) + | C.Variable (x,Some te,ty,v,y) -> + List.iter aux_uri v; + C.Variable (x,Some (aux te),aux ty,v,y) + | C.Constant (x,None, ty, v,y) -> + List.iter aux_uri v; + C.Constant (x,None, aux ty, v,y) + | C.Variable (x,None, ty, v,y) -> + List.iter aux_uri v; + C.Variable (x,None, aux ty, v,y) + | C.CurrentProof (_,conjs,te,ty,v,_) -> assert false + | C.InductiveDefinition (l,v,x,y) -> + List.iter aux_uri v; + C.InductiveDefinition ( + List.map + (fun (x,y,t,l') -> + (x,y,aux t, List.map (fun (x,t) -> x,aux t) l')) + l,v,x,y) + in + let o = aux_obj t in + List.flatten !results, o + +let rec list_uniq = function + | [] -> [] + | h::[] -> [h] + | h1::h2::tl when CicUniv.eq h1 h2 -> list_uniq (h2 :: tl) + | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq tl + +let list_uniq l = + list_uniq (List.fast_sort CicUniv.compare l) + +let profiler = (HExtlib.profile "clean_and_fill").HExtlib.profile + +let clean_and_fill uri obj ugraph = + (* universes of obj fills the universes of the obj with the right uri *) + let list_of_universes, obj = universes_of_obj uri obj in + let list_of_universes = list_uniq list_of_universes in +(* CicUniv.print_ugraph ugraph;*) +(* List.iter (fun u -> prerr_endline (CicUniv.string_of_universe u))*) +(* list_of_universes;*) + let ugraph = CicUniv.clean_ugraph ugraph list_of_universes in +(* CicUniv.print_ugraph ugraph;*) + let ugraph, list_of_universes = + CicUniv.fill_empty_nodes_with_uri ugraph list_of_universes uri + in + ugraph, list_of_universes, obj + +let clean_and_fill u o g = + profiler (clean_and_fill u o) g + diff --git a/helm/software/components/cic_proof_checking/cicUnivUtils.mli b/helm/software/components/cic_proof_checking/cicUnivUtils.mli new file mode 100644 index 000000000..eb55a47eb --- /dev/null +++ b/helm/software/components/cic_proof_checking/cicUnivUtils.mli @@ -0,0 +1,32 @@ +(* 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/. + *) + + (** cleans the universe graph for a given object and fills universes with URI. + * to be used on qed + *) +val clean_and_fill: + UriManager.uri -> Cic.obj -> CicUniv.universe_graph -> + CicUniv.universe_graph * CicUniv.universe list * Cic.obj + diff --git a/helm/software/components/cic_proof_checking/doc/inductive.txt b/helm/software/components/cic_proof_checking/doc/inductive.txt new file mode 100644 index 000000000..f2e49d398 --- /dev/null +++ b/helm/software/components/cic_proof_checking/doc/inductive.txt @@ -0,0 +1,41 @@ +Table of allowed eliminations: + + +--------------------+----------------------------------+ + | Inductive Type | Elimination to | + +--------------------+----------------------------------+ + | Sort | "Smallness" | Prop | SetI | SetP | CProp| Type | + +--------------------+----------------------------------+ + | Prop empty | yes yes yes yes yes | + | Prop unit | yes yes yes yes yes | + | Prop small | yes no2 no2 no2 no12 | + | Prop | yes no2 no2 no2 no12 | + | SetI empty | yes yes -- yes yes | + | SetI small | yes yes -- yes yes | + | SetI | yes yes -- no1 no1 | + | SetP empty | yes -- yes yes yes | + | SetP small | yes -- yes yes yes | + | SetP | na3 na3 na3 na3 na3 | + | CProp empty | yes yes yes yes yes | + | CProp small | yes yes yes yes yes | + | CProp | yes yes yes yes yes | + | Type | yes yes yes yes yes | + +--------------------+----------------------------------+ + +Legenda: + no: elimination not allowed + na: not allowed, the inductive definition is rejected + + 1 : due to paradoxes a la Hurkens + 2 : due to code extraction + proof irreleveance incompatibility + (if you define Bool in Prop, you will be able to prove true<>false) + 3 : inductive type is rejected due to universe inconsistency + + SetP : Predicative Set + SetI : Impredicative Set + + non-informative : Constructor arguments are in Prop only + small : Constructor arguments are not in Type and SetP and CProp + unit : Non (mutually) recursive /\ only one constructor /\ non-informative + empty : in Coq: no constructors and non mutually recursive + in Matita: no constructors (but eventually mutually recursive + with non-empty types) diff --git a/helm/software/components/cic_proof_checking/freshNamesGenerator.ml b/helm/software/components/cic_proof_checking/freshNamesGenerator.ml new file mode 100755 index 000000000..99c9e4d76 --- /dev/null +++ b/helm/software/components/cic_proof_checking/freshNamesGenerator.ml @@ -0,0 +1,354 @@ +(* Copyright (C) 2004, 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/. + *) + +(* $Id$ *) + +let debug_print = fun _ -> () + +let rec higher_name arity = + function + Cic.Sort Cic.Prop + | Cic.Sort Cic.CProp -> + if arity = 0 then "A" (* propositions *) + else if arity = 1 then "P" (* predicates *) + else "R" (*relations *) + | Cic.Sort Cic.Set + -> if arity = 0 then "S" else "F" + | Cic.Sort (Cic.Type _ ) -> + if arity = 0 then "T" else "F" + | Cic.Prod (_,_,t) -> higher_name (arity+1) t + | _ -> "f" + +let get_initial s = + if String.length s = 0 then "_" + else + let head = String.sub s 0 1 in + String.lowercase head + +(* only used when the sort is not Prop or CProp *) +let rec guess_a_name context ty = + match ty with + Cic.Rel n -> + (match List.nth context (n-1) with + None -> assert false + | Some (Cic.Anonymous,_) -> "eccomi_qua" + | Some (Cic.Name s,_) -> get_initial s) + | Cic.Var (uri,_) -> get_initial (UriManager.name_of_uri uri) + | Cic.Sort _ -> higher_name 0 ty + | Cic.Implicit _ -> assert false + | Cic.Cast (t1,t2) -> guess_a_name context t1 + | Cic.Prod (na_,_,t) -> higher_name 1 t + | Cic.Lambda _ -> assert false + | Cic.LetIn (_,s,t) -> guess_a_name context (CicSubstitution.subst s t) + | Cic.Appl [] -> assert false + | Cic.Appl (he::_) -> guess_a_name context he + | Cic.Const (uri,_) + | Cic.MutInd (uri,_,_) + | Cic.MutConstruct (uri,_,_,_) -> get_initial (UriManager.name_of_uri uri) + | _ -> "x" + +(* 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 ~subst metasenv context name ~typ = + let module C = Cic in + let basename = + match name with + C.Anonymous -> + (try + let ty,_ = + CicTypeChecker.type_of_aux' ~subst metasenv context typ + CicUniv.empty_ugraph in + (match ty with + C.Sort C.Prop + | C.Sort C.CProp -> "H" + | _ -> guess_a_name context typ + ) + with CicTypeChecker.TypeCheckerFailure _ -> "H" + ) + | C.Name name -> + Str.global_replace (Str.regexp "[0-9]*$") "" name + in + let already_used name = + List.exists (function Some (n,_) -> n=name | _ -> false) context + in + if name <> C.Anonymous && not (already_used name) then + name + else if not (already_used (C.Name basename)) then + C.Name basename + else + let rec try_next n = + let name' = C.Name (basename ^ string_of_int n) in + if already_used name' then + try_next (n+1) + else + name' + in + try_next 1 +;; + +(* let mk_fresh_names ~subst metasenv context t *) +let rec mk_fresh_names ~subst metasenv context t = + match t with + Cic.Rel _ -> t + | Cic.Var (uri,exp_named_subst) -> + let ens = + List.map + (fun (uri,t) -> + (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in + Cic.Var (uri,ens) + | Cic.Meta (i,l) -> + let l' = + List.map + (fun t -> + match t with + None -> None + | Some t -> Some (mk_fresh_names ~subst metasenv context t)) l in + Cic.Meta(i,l') + | Cic.Sort _ + | Cic.Implicit _ -> t + | Cic.Cast (te,ty) -> + let te' = mk_fresh_names ~subst metasenv context te in + let ty' = mk_fresh_names ~subst metasenv context ty in + Cic.Cast (te', ty') + | Cic.Prod (n,s,t) -> + let s' = mk_fresh_names ~subst metasenv context s in + let n' = + match n with + Cic.Anonymous -> Cic.Anonymous + | Cic.Name "matita_dummy" -> + mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' + | _ -> n in + let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Decl s')::context) t in + Cic.Prod (n',s',t') + | Cic.Lambda (n,s,t) -> + let s' = mk_fresh_names ~subst metasenv context s in + let n' = + match n with + Cic.Anonymous -> Cic.Anonymous + | Cic.Name "matita_dummy" -> + mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' + | _ -> n in + let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Decl s')::context) t in + Cic.Lambda (n',s',t') + | Cic.LetIn (n,s,t) -> + let s' = mk_fresh_names ~subst metasenv context s in + let n' = + match n with + Cic.Anonymous -> Cic.Anonymous + | Cic.Name "matita_dummy" -> + mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' + | _ -> n in + let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Def (s',None))::context) t in + Cic.LetIn (n',s',t') + | Cic.Appl l -> + Cic.Appl (List.map (mk_fresh_names ~subst metasenv context) l) + | Cic.Const (uri,exp_named_subst) -> + let ens = + List.map + (fun (uri,t) -> + (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in + Cic.Const(uri,ens) + | Cic.MutInd (uri,tyno,exp_named_subst) -> + let ens = + List.map + (fun (uri,t) -> + (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in + Cic.MutInd (uri,tyno,ens) + | Cic.MutConstruct (uri,tyno,consno,exp_named_subst) -> + let ens = + List.map + (fun (uri,t) -> + (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in + Cic.MutConstruct (uri,tyno,consno, ens) + | Cic.MutCase (sp,i,outty,t,pl) -> + let outty' = mk_fresh_names ~subst metasenv context outty in + let t' = mk_fresh_names ~subst metasenv context t in + let pl' = List.map (mk_fresh_names ~subst metasenv context) pl in + Cic.MutCase (sp, i, outty', t', pl') + | Cic.Fix (i, fl) -> + let tys = List.map + (fun (n,_,ty,_) -> + Some (Cic.Name n,(Cic.Decl ty))) fl in + let fl' = List.map + (fun (n,i,ty,bo) -> + let ty' = mk_fresh_names ~subst metasenv context ty in + let bo' = mk_fresh_names ~subst metasenv (tys@context) bo in + (n,i,ty',bo')) fl in + Cic.Fix (i, fl') + | Cic.CoFix (i, fl) -> + let tys = List.map + (fun (n,_,ty) -> + Some (Cic.Name n,(Cic.Decl ty))) fl in + let fl' = List.map + (fun (n,ty,bo) -> + let ty' = mk_fresh_names ~subst metasenv context ty in + let bo' = mk_fresh_names ~subst metasenv (tys@context) bo in + (n,ty',bo')) fl in + Cic.CoFix (i, fl') +;; + +(* clean_dummy_dependent_types term *) +(* returns a copy of [term] where every dummy dependent product *) +(* have been replaced with a non-dependent product and where *) +(* dummy let-ins have been removed. *) +let clean_dummy_dependent_types t = + let module C = Cic in + let rec aux k = + function + C.Rel m as t -> t,[k - m] + | C.Var (uri,exp_named_subst) -> + let exp_named_subst',rels = + List.fold_right + (fun (uri,t) (exp_named_subst,rels) -> + let t',rels' = aux k t in + (uri,t')::exp_named_subst, rels' @ rels + ) exp_named_subst ([],[]) + in + C.Var (uri,exp_named_subst'),rels + | C.Meta (i,l) -> + let l',rels = + List.fold_right + (fun t (l,rels) -> + let t',rels' = + match t with + None -> None,[] + | Some t -> + let t',rels' = aux k t in + Some t', rels' + in + t'::l, rels' @ rels + ) l ([],[]) + in + C.Meta(i,l'),rels + | C.Sort _ as t -> t,[] + | C.Implicit _ as t -> t,[] + | C.Cast (te,ty) -> + let te',rels1 = aux k te in + let ty',rels2 = aux k ty in + C.Cast (te', ty'), rels1@rels2 + | C.Prod (n,s,t) -> + let s',rels1 = aux k s in + let t',rels2 = aux (k+1) t in + let n' = + match n with + C.Anonymous -> + if List.mem k rels2 then +( + debug_print (lazy "If this happens often, we can do something about it (i.e. we can generate a new fresh name; problem: we need the metasenv and context ;-(. Alternative solution: mk_implicit does not generate entries for the elements in the context that have no name") ; + C.Anonymous +) + else + C.Anonymous + | C.Name _ as n -> + if List.mem k rels2 then n else C.Anonymous + in + C.Prod (n', s', t'), rels1@rels2 + | C.Lambda (n,s,t) -> + let s',rels1 = aux k s in + let t',rels2 = aux (k+1) t in + C.Lambda (n, s', t'), rels1@rels2 + | C.LetIn (n,s,t) -> + let s',rels1 = aux k s in + let t',rels2 = aux (k+1) t in + let rels = rels1 @ rels2 in + if List.mem k rels2 then + C.LetIn (n, s', t'), rels + else + (* (C.Rel 1) is just a dummy term; any term would fit *) + CicSubstitution.subst (C.Rel 1) t', rels + | C.Appl l -> + let l',rels = + List.fold_right + (fun t (exp_named_subst,rels) -> + let t',rels' = aux k t in + t'::exp_named_subst, rels' @ rels + ) l ([],[]) + in + C.Appl l', rels + | C.Const (uri,exp_named_subst) -> + let exp_named_subst',rels = + List.fold_right + (fun (uri,t) (exp_named_subst,rels) -> + let t',rels' = aux k t in + (uri,t')::exp_named_subst, rels' @ rels + ) exp_named_subst ([],[]) + in + C.Const (uri,exp_named_subst'),rels + | C.MutInd (uri,tyno,exp_named_subst) -> + let exp_named_subst',rels = + List.fold_right + (fun (uri,t) (exp_named_subst,rels) -> + let t',rels' = aux k t in + (uri,t')::exp_named_subst, rels' @ rels + ) exp_named_subst ([],[]) + in + C.MutInd (uri,tyno,exp_named_subst'),rels + | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> + let exp_named_subst',rels = + List.fold_right + (fun (uri,t) (exp_named_subst,rels) -> + let t',rels' = aux k t in + (uri,t')::exp_named_subst, rels' @ rels + ) exp_named_subst ([],[]) + in + C.MutConstruct (uri,tyno,consno,exp_named_subst'),rels + | C.MutCase (sp,i,outty,t,pl) -> + let outty',rels1 = aux k outty in + let t',rels2 = aux k t in + let pl',rels3 = + List.fold_right + (fun t (exp_named_subst,rels) -> + let t',rels' = aux k t in + t'::exp_named_subst, rels' @ rels + ) pl ([],[]) + in + C.MutCase (sp, i, outty', t', pl'), rels1 @ rels2 @rels3 + | C.Fix (i, fl) -> + let len = List.length fl in + let fl',rels = + List.fold_right + (fun (name,i,ty,bo) (fl,rels) -> + let ty',rels1 = aux k ty in + let bo',rels2 = aux (k + len) bo in + (name,i,ty',bo')::fl, rels1 @ rels2 @ rels + ) fl ([],[]) + in + C.Fix (i, fl'),rels + | C.CoFix (i, fl) -> + let len = List.length fl in + let fl',rels = + List.fold_right + (fun (name,ty,bo) (fl,rels) -> + let ty',rels1 = aux k ty in + let bo',rels2 = aux (k + len) bo in + (name,ty',bo')::fl, rels1 @ rels2 @ rels + ) fl ([],[]) + in + C.CoFix (i, fl'),rels + in + fst (aux 0 t) +;; diff --git a/helm/software/components/cic_proof_checking/freshNamesGenerator.mli b/helm/software/components/cic_proof_checking/freshNamesGenerator.mli new file mode 100644 index 000000000..b90c0f2f5 --- /dev/null +++ b/helm/software/components/cic_proof_checking/freshNamesGenerator.mli @@ -0,0 +1,46 @@ +(* Copyright (C) 2004, 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 metasenv 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 : + subst:Cic.substitution -> + Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name + +(* mk_fresh_names metasenv context term *) +(* returns a term t' convertible with term where all *) +(* matita_dummies have been replaced by fresh names *) + +val mk_fresh_names : + subst:Cic.substitution -> + Cic.metasenv -> Cic.context -> Cic.term -> Cic.term + +(* clean_dummy_dependent_types term *) +(* returns a copy of [term] where every dummy dependent product *) +(* have been replaced with a non-dependent product and where *) +(* dummy let-ins have been removed. *) +val clean_dummy_dependent_types : Cic.term -> Cic.term diff --git a/helm/software/components/cic_proof_checking/utilities/Makefile b/helm/software/components/cic_proof_checking/utilities/Makefile new file mode 100644 index 000000000..383391d70 --- /dev/null +++ b/helm/software/components/cic_proof_checking/utilities/Makefile @@ -0,0 +1,21 @@ +UTILITIES = create_environment parse_library list_uris +UTILITIES_OPT = $(patsubst %,%.opt,$(UTILITIES)) +LINKOPTS = -linkpkg -thread +LIBS = helm-cic_proof_checking +OCAMLC = $(OCAMLFIND) ocamlc $(LINKOPTS) -package $(LIBS) +OCAMLOPT = $(OCAMLFIND) opt $(LINKOPTS) -package $(LIBS) +all: $(UTILITIES) + @echo -n +opt: $(UTILITIES_OPT) + @echo -n +%: %.ml + @echo " OCAMLC $<" + @$(OCAMLC) -o $@ $< +%.opt: %.ml + @echo " OCAMLOPT $<" + @$(OCAMLOPT) -o $@ $< +clean: + rm -f $(UTILITIES) $(UTILITIES_OPT) *.cm[iox] *.o + +include ../../../Makefile.defs + diff --git a/helm/software/components/cic_proof_checking/utilities/create_environment.ml b/helm/software/components/cic_proof_checking/utilities/create_environment.ml new file mode 100644 index 000000000..8a8524d24 --- /dev/null +++ b/helm/software/components/cic_proof_checking/utilities/create_environment.ml @@ -0,0 +1,73 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +let trust = true + +let outfname = + match Sys.argv.(1) with + | "-help" | "--help" | "-h" | "--h" -> + print_endline + ("Usage: create_environment \n" ^ + " is the file where environment will be dumped\n" ^ + " is the file containing the URIs, one per line,\n" ^ + " that will be typechecked. Could be \"-\" for\n" ^ + " standard input"); + flush stdout; + exit 0 + | f -> f +let _ = + CicEnvironment.set_trust (fun _ -> trust); + Helm_registry.set "getter.mode" "remote"; + Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/"; + Sys.catch_break true; + if Sys.file_exists outfname then begin + let ic = open_in outfname in + CicEnvironment.restore_from_channel ic; + close_in ic + end +let urifname = + try + Sys.argv.(2) + with Invalid_argument _ -> "-" +let ic = + match urifname with + | "-" -> stdin + | fname -> open_in fname +let _ = + try + while true do +(* try *) + let uri = input_line ic in + print_endline uri; + flush stdout; + let uri = UriManager.uri_of_string uri in + ignore (CicTypeChecker.typecheck uri) +(* with Sys.Break -> () *) + done + with End_of_file | Sys.Break -> + let oc = open_out outfname in + CicEnvironment.dump_to_channel oc; + close_out oc + diff --git a/helm/software/components/cic_proof_checking/utilities/list_uris.ml b/helm/software/components/cic_proof_checking/utilities/list_uris.ml new file mode 100644 index 000000000..90ea51616 --- /dev/null +++ b/helm/software/components/cic_proof_checking/utilities/list_uris.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +let ic = open_in Sys.argv.(1) in +CicEnvironment.restore_from_channel ic; +List.iter + (fun uri -> print_endline (UriManager.string_of_uri uri)) + (CicEnvironment.list_uri ()) diff --git a/helm/software/components/cic_proof_checking/utilities/parse_library.ml b/helm/software/components/cic_proof_checking/utilities/parse_library.ml new file mode 100644 index 000000000..1d65291cb --- /dev/null +++ b/helm/software/components/cic_proof_checking/utilities/parse_library.ml @@ -0,0 +1,54 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +let trust = true + +let _ = + CicEnvironment.set_trust (fun _ -> trust); + Helm_registry.set "getter.mode" "remote"; + Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/" +let urifname = + try + Sys.argv.(1) + with Invalid_argument _ -> "-" +let ic = + match urifname with + | "-" -> stdin + | fname -> open_in fname +let _ = + try + while true do + try + let uri = input_line ic in + prerr_endline uri; + let uri = UriManager.uri_of_string uri in + ignore (CicEnvironment.get_obj CicUniv.empty_ugraph uri) +(* with Sys.Break -> () *) + with + | End_of_file -> raise End_of_file + | exn -> () + done + with End_of_file -> Unix.sleep max_int + diff --git a/helm/software/components/cic_unification/.depend b/helm/software/components/cic_unification/.depend new file mode 100644 index 000000000..a442c1d4d --- /dev/null +++ b/helm/software/components/cic_unification/.depend @@ -0,0 +1,10 @@ +cicMetaSubst.cmo: cicMetaSubst.cmi +cicMetaSubst.cmx: cicMetaSubst.cmi +cicMkImplicit.cmo: cicMkImplicit.cmi +cicMkImplicit.cmx: cicMkImplicit.cmi +cicUnification.cmo: cicMetaSubst.cmi cicUnification.cmi +cicUnification.cmx: cicMetaSubst.cmx cicUnification.cmi +cicRefine.cmo: cicUnification.cmi cicMkImplicit.cmi cicMetaSubst.cmi \ + cicRefine.cmi +cicRefine.cmx: cicUnification.cmx cicMkImplicit.cmx cicMetaSubst.cmx \ + cicRefine.cmi diff --git a/helm/software/components/cic_unification/Makefile b/helm/software/components/cic_unification/Makefile new file mode 100644 index 000000000..62be3a61c --- /dev/null +++ b/helm/software/components/cic_unification/Makefile @@ -0,0 +1,13 @@ +PACKAGE = cic_unification +PREDICATES = + +INTERFACE_FILES = \ + cicMetaSubst.mli \ + cicMkImplicit.mli \ + cicUnification.mli \ + cicRefine.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/cic_unification/cicMetaSubst.ml b/helm/software/components/cic_unification/cicMetaSubst.ml new file mode 100644 index 000000000..5870089be --- /dev/null +++ b/helm/software/components/cic_unification/cicMetaSubst.ml @@ -0,0 +1,898 @@ +(* Copyright (C) 2003, 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/. + *) + +(* $Id$ *) + +open Printf + +(* PROFILING *) +(* +let deref_counter = ref 0 +let apply_subst_context_counter = ref 0 +let apply_subst_metasenv_counter = ref 0 +let lift_counter = ref 0 +let subst_counter = ref 0 +let whd_counter = ref 0 +let are_convertible_counter = ref 0 +let metasenv_length = ref 0 +let context_length = ref 0 +let reset_counters () = + apply_subst_counter := 0; + apply_subst_context_counter := 0; + apply_subst_metasenv_counter := 0; + lift_counter := 0; + subst_counter := 0; + whd_counter := 0; + are_convertible_counter := 0; + metasenv_length := 0; + context_length := 0 +let print_counters () = + debug_print (lazy (Printf.sprintf +"apply_subst: %d +apply_subst_context: %d +apply_subst_metasenv: %d +lift: %d +subst: %d +whd: %d +are_convertible: %d +metasenv length: %d (avg = %.2f) +context length: %d (avg = %.2f) +" + !apply_subst_counter !apply_subst_context_counter + !apply_subst_metasenv_counter !lift_counter !subst_counter !whd_counter + !are_convertible_counter !metasenv_length + ((float !metasenv_length) /. (float !apply_subst_metasenv_counter)) + !context_length + ((float !context_length) /. (float !apply_subst_context_counter)) + ))*) + + + +exception MetaSubstFailure of string Lazy.t +exception Uncertain of string Lazy.t +exception AssertFailure of string Lazy.t +exception DeliftingARelWouldCaptureAFreeVariable;; + +let debug_print = fun _ -> () + +type substitution = (int * (Cic.context * Cic.term)) list + +(* +let rec deref subst = + let third _,_,a = a in + function + Cic.Meta(n,l) as t -> + (try + deref subst + (CicSubstitution.subst_meta + l (third (CicUtil.lookup_subst n subst))) + with + CicUtil.Subst_not_found _ -> t) + | t -> t +;; +*) + +let lookup_subst = CicUtil.lookup_subst +;; + + +(* clean_up_meta take a metasenv and a term and make every local context +of each occurrence of a metavariable consistent with its canonical context, +with respect to the hidden hipothesis *) + +(* +let clean_up_meta subst metasenv t = + let module C = Cic in + let rec aux t = + match t with + C.Rel _ + | C.Sort _ -> t + | C.Implicit _ -> assert false + | C.Meta (n,l) as t -> + let cc = + (try + let (cc,_) = lookup_subst n subst in cc + with CicUtil.Subst_not_found _ -> + try + let (_,cc,_) = CicUtil.lookup_meta n metasenv in cc + with CicUtil.Meta_not_found _ -> assert false) in + let l' = + (try + List.map2 + (fun t1 t2 -> + match t1,t2 with + None , _ -> None + | _ , t -> t) cc l + with + Invalid_argument _ -> assert false) in + C.Meta (n, l') + | C.Cast (te,ty) -> C.Cast (aux te, aux ty) + | C.Prod (name,so,dest) -> C.Prod (name, aux so, aux dest) + | C.Lambda (name,so,dest) -> C.Lambda (name, aux so, aux dest) + | C.LetIn (name,so,dest) -> C.LetIn (name, aux so, aux dest) + | C.Appl l -> C.Appl (List.map aux l) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst + in + C.Var (uri, exp_named_subst') + | C.Const (uri, exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst + in + C.Const (uri, exp_named_subst') + | C.MutInd (uri,tyno,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri,t) -> (uri, aux 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 (fun (uri,t) -> (uri, aux t)) exp_named_subst + in + C.MutConstruct (uri, tyno, consno, exp_named_subst') + | C.MutCase (uri,tyno,out,te,pl) -> + C.MutCase (uri, tyno, aux out, aux te, List.map aux pl) + | C.Fix (i,fl) -> + let fl' = + List.map + (fun (name,j,ty,bo) -> (name, j, aux ty, aux bo)) fl + in + C.Fix (i, fl') + | C.CoFix (i,fl) -> + let fl' = + List.map + (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl + in + C.CoFix (i, fl') + in + aux t *) + +(*** Functions to apply a substitution ***) + +let apply_subst_gen ~appl_fun subst term = + let rec um_aux = + let module C = Cic in + let module S = CicSubstitution in + function + C.Rel _ as t -> t + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst + in + C.Var (uri, exp_named_subst') + | C.Meta (i, l) -> + (try + let (_, t,_) = lookup_subst i subst in + um_aux (S.subst_meta l t) + with CicUtil.Subst_not_found _ -> + (* unconstrained variable, i.e. free in subst*) + let l' = + List.map (function None -> None | Some t -> Some (um_aux t)) l + in + C.Meta (i,l')) + | C.Sort _ + | C.Implicit _ as t -> t + | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty) + | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t) + | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t) + | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t) + | C.Appl (hd :: tl) -> appl_fun um_aux hd tl + | C.Appl _ -> assert false + | C.Const (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (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 (fun (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 (fun (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) -> + let pl' = List.map um_aux pl in + C.MutCase (sp, i, um_aux outty, um_aux t, pl') + | C.Fix (i, fl) -> + let fl' = + List.map (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo)) fl + in + C.Fix (i, fl') + | C.CoFix (i, fl) -> + let fl' = + List.map (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo)) fl + in + C.CoFix (i, fl') + in + LibrarySync.merge_coercions (um_aux term) +;; + +let apply_subst = + let appl_fun um_aux he tl = + let tl' = List.map um_aux tl in + let t' = + match um_aux he with + Cic.Appl l -> Cic.Appl (l@tl') + | he' -> Cic.Appl (he'::tl') + in + begin + match he with + Cic.Meta (m,_) -> CicReduction.head_beta_reduce t' + | _ -> t' + end + in + fun s t -> +(* incr apply_subst_counter; *) + apply_subst_gen ~appl_fun s t +;; + +let rec apply_subst_context subst context = +(* + incr apply_subst_context_counter; + context_length := !context_length + List.length context; +*) + List.fold_right + (fun item context -> + match item with + | Some (n, Cic.Decl t) -> + let t' = apply_subst subst t in + Some (n, Cic.Decl t') :: context + | Some (n, Cic.Def (t, ty)) -> + let ty' = + match ty with + | None -> None + | Some ty -> Some (apply_subst subst ty) + in + let t' = apply_subst subst t in + Some (n, Cic.Def (t', ty')) :: context + | None -> None :: context) + context [] + +let apply_subst_metasenv subst metasenv = +(* + incr apply_subst_metasenv_counter; + metasenv_length := !metasenv_length + List.length metasenv; +*) + List.map + (fun (n, context, ty) -> + (n, apply_subst_context subst context, apply_subst subst ty)) + (List.filter + (fun (i, _, _) -> not (List.mem_assoc i subst)) + metasenv) + +(***** Pretty printing functions ******) + +let ppterm subst term = CicPp.ppterm (apply_subst subst term) + +let ppterm_in_name_context subst term name_context = + CicPp.pp (apply_subst subst term) name_context + +let ppterm_in_context subst term context = + let name_context = + List.map (function None -> None | Some (n,_) -> Some n) context + in + ppterm_in_name_context subst term name_context + +let ppcontext' ?(sep = "\n") subst context = + let separate s = if s = "" then "" else s ^ sep in + List.fold_right + (fun context_entry (i,name_context) -> + match context_entry with + Some (n,Cic.Decl t) -> + sprintf "%s%s : %s" (separate i) (CicPp.ppname n) + (ppterm_in_name_context subst t name_context), (Some n)::name_context + | Some (n,Cic.Def (bo,ty)) -> + sprintf "%s%s : %s := %s" (separate i) (CicPp.ppname n) + (match ty with + None -> "_" + | Some ty -> ppterm_in_name_context subst ty name_context) + (ppterm_in_name_context subst bo name_context), (Some n)::name_context + | None -> + sprintf "%s_ :? _" (separate i), None::name_context + ) context ("",[]) + +let ppsubst_unfolded subst = + String.concat "\n" + (List.map + (fun (idx, (c, t,_)) -> + let context,name_context = ppcontext' ~sep:"; " subst c in + sprintf "%s |- ?%d:= %s" context idx + (ppterm_in_name_context subst t name_context)) + subst) +(* + Printf.sprintf "?%d := %s" idx (CicPp.ppterm term)) + subst) *) +;; + +let ppsubst subst = + String.concat "\n" + (List.map + (fun (idx, (c, t, _)) -> + let context,name_context = ppcontext' ~sep:"; " [] c in + sprintf "%s |- ?%d:= %s" context idx + (ppterm_in_name_context [] t name_context)) + subst) +;; + +let ppcontext ?sep subst context = fst (ppcontext' ?sep subst context) + +let ppmetasenv ?(sep = "\n") subst metasenv = + String.concat sep + (List.map + (fun (i, c, t) -> + let context,name_context = ppcontext' ~sep:"; " subst c in + sprintf "%s |- ?%d: %s" context i + (ppterm_in_name_context subst t name_context)) + (List.filter + (fun (i, _, _) -> not (List.mem_assoc i subst)) + metasenv)) + +let tempi_type_of_aux_subst = ref 0.0;; +let tempi_subst = ref 0.0;; +let tempi_type_of_aux = ref 0.0;; + +(**** DELIFT ****) +(* the delift function takes in input a metavariable index, an ordered list of + * optional terms [t1,...,tn] and a term t, and substitutes every tk = Some + * (rel(nk)) with rel(k). Typically, the list of optional terms is the explicit + * substitution that is applied to a metavariable occurrence and the result of + * the delift function is a term the implicit variable can be substituted with + * to make the term [t] unifiable with the metavariable occurrence. In general, + * the problem is undecidable if we consider equivalence in place of alpha + * convertibility. Our implementation, though, is even weaker than alpha + * convertibility, since it replace the term [tk] if and only if [tk] is a Rel + * (missing all the other cases). Does this matter in practice? + * The metavariable index is the index of the metavariable that must not occur + * in the term (for occur check). + *) + +exception NotInTheList;; + +let position n = + let rec aux k = + function + [] -> raise NotInTheList + | (Some (Cic.Rel m))::_ when m=n -> k + | _::tl -> aux (k+1) tl in + aux 1 +;; + +exception Occur;; + +let rec force_does_not_occur subst to_be_restricted t = + let module C = Cic in + let more_to_be_restricted = ref [] in + let rec aux k = function + C.Rel r when List.mem (r - k) to_be_restricted -> raise Occur + | C.Rel _ + | C.Sort _ as t -> t + | C.Implicit _ -> assert false + | C.Meta (n, l) -> + (* we do not retrieve the term associated to ?n in subst since *) + (* in this way we can restrict if something goes wrong *) + let l' = + let i = ref 0 in + List.map + (function t -> + incr i ; + match t with + None -> None + | Some t -> + try + Some (aux k t) + with Occur -> + more_to_be_restricted := (n,!i) :: !more_to_be_restricted; + None) + l + in + C.Meta (n, l') + | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) + | C.Prod (name,so,dest) -> C.Prod (name, aux k so, aux (k+1) dest) + | C.Lambda (name,so,dest) -> C.Lambda (name, aux k so, aux (k+1) dest) + | C.LetIn (name,so,dest) -> C.LetIn (name, aux k so, aux (k+1) dest) + | C.Appl l -> C.Appl (List.map (aux k) l) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst + in + C.Var (uri, exp_named_subst') + | C.Const (uri, exp_named_subst) -> + let exp_named_subst' = + List.map (fun (uri,t) -> (uri, aux 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 (fun (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 (fun (uri,t) -> (uri, aux k t)) exp_named_subst + in + C.MutConstruct (uri, tyno, consno, exp_named_subst') + | C.MutCase (uri,tyno,out,te,pl) -> + C.MutCase (uri, tyno, aux k out, aux k te, List.map (aux k) pl) + | C.Fix (i,fl) -> + let len = List.length fl in + let k_plus_len = k + len in + let fl' = + List.map + (fun (name,j,ty,bo) -> (name, j, aux k ty, aux k_plus_len bo)) fl + in + C.Fix (i, fl') + | C.CoFix (i,fl) -> + let len = List.length fl in + let k_plus_len = k + len in + let fl' = + List.map + (fun (name,ty,bo) -> (name, aux k ty, aux k_plus_len bo)) fl + in + C.CoFix (i, fl') + in + let res = aux 0 t in + (!more_to_be_restricted, res) + +let rec restrict subst to_be_restricted metasenv = + let names_of_context_indexes context indexes = + String.concat ", " + (List.map + (fun i -> + try + match List.nth context (i-1) with + | None -> assert false + | Some (n, _) -> CicPp.ppname n + with + Failure _ -> assert false + ) indexes) + in + let force_does_not_occur_in_context to_be_restricted = function + | None -> [], None + | Some (name, Cic.Decl t) -> + let (more_to_be_restricted, t') = + force_does_not_occur subst to_be_restricted t + in + more_to_be_restricted, Some (name, Cic.Decl t') + | Some (name, Cic.Def (bo, ty)) -> + let (more_to_be_restricted, bo') = + force_does_not_occur subst to_be_restricted bo + in + let more_to_be_restricted, ty' = + match ty with + | None -> more_to_be_restricted, None + | Some ty -> + let more_to_be_restricted', ty' = + force_does_not_occur subst to_be_restricted ty + in + more_to_be_restricted @ more_to_be_restricted', + Some ty' + in + more_to_be_restricted, Some (name, Cic.Def (bo', ty')) + in + let rec erase i to_be_restricted n = function + | [] -> [], to_be_restricted, [] + | hd::tl -> + let more_to_be_restricted,restricted,tl' = + erase (i+1) to_be_restricted n tl + in + let restrict_me = List.mem i restricted in + if restrict_me then + more_to_be_restricted, restricted, None:: tl' + else + (try + let more_to_be_restricted', hd' = + let delifted_restricted = + let rec aux = + function + [] -> [] + | j::tl when j > i -> (j - i)::aux tl + | _::tl -> aux tl + in + aux restricted + in + force_does_not_occur_in_context delifted_restricted hd + in + more_to_be_restricted @ more_to_be_restricted', + restricted, hd' :: tl' + with Occur -> + more_to_be_restricted, (i :: restricted), None :: tl') + in + let (more_to_be_restricted, metasenv) = (* restrict metasenv *) + List.fold_right + (fun (n, context, t) (more, metasenv) -> + let to_be_restricted = + List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted) + in + let (more_to_be_restricted, restricted, context') = + (* just an optimization *) + if to_be_restricted = [] then + [],[],context + else + erase 1 to_be_restricted n context + in + try + let more_to_be_restricted', t' = + force_does_not_occur subst restricted t + in + let metasenv' = (n, context', t') :: metasenv in + (more @ more_to_be_restricted @ more_to_be_restricted', + metasenv') + with Occur -> + raise (MetaSubstFailure (lazy (sprintf + "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since metavariable's type depends on at least one of them" + n (names_of_context_indexes context to_be_restricted))))) + metasenv ([], []) + in + let (more_to_be_restricted', subst) = (* restrict subst *) + List.fold_right + (* TODO: cambiare dopo l'aggiunta del ty *) + (fun (n, (context, term,ty)) (more, subst') -> + let to_be_restricted = + List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted) + in + (try + let (more_to_be_restricted, restricted, context') = + (* just an optimization *) + if to_be_restricted = [] then + [], [], context + else + erase 1 to_be_restricted n context + in + let more_to_be_restricted', term' = + force_does_not_occur subst restricted term + in + let more_to_be_restricted'', ty' = + force_does_not_occur subst restricted ty in + let subst' = (n, (context', term',ty')) :: subst' in + let more = + more @ more_to_be_restricted + @ more_to_be_restricted'@more_to_be_restricted'' in + (more, subst') + with Occur -> + let error_msg = lazy (sprintf + "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since ?%d is already instantiated with %s and at least one of the hypotheses occurs in the substituted term" + n (names_of_context_indexes context to_be_restricted) n + (ppterm subst term)) + in + (* DEBUG + debug_print (lazy error_msg); + debug_print (lazy ("metasenv = \n" ^ (ppmetasenv metasenv subst))); + debug_print (lazy ("subst = \n" ^ (ppsubst subst))); + debug_print (lazy ("context = \n" ^ (ppcontext subst context))); *) + raise (MetaSubstFailure error_msg))) + subst ([], []) + in + match more_to_be_restricted @ more_to_be_restricted' with + | [] -> (metasenv, subst) + | l -> restrict subst l metasenv +;; + +(*CSC: maybe we should rename delift in abstract, as I did in my dissertation *)(*Andrea: maybe not*) + +let delift n subst context metasenv l t = +(* INVARIANT: we suppose that t is not another occurrence of Meta(n,_), + otherwise the occur check does not make sense *) + +(* + debug_print (lazy ("sto deliftando il termine " ^ (CicPp.ppterm t) ^ " rispetto + al contesto locale " ^ (CicPp.ppterm (Cic.Meta(0,l))))); +*) + + let module S = CicSubstitution in + let l = + let (_, canonical_context, _) = CicUtil.lookup_meta n metasenv in + List.map2 (fun ct lt -> + match (ct, lt) with + | None, _ -> None + | Some _, _ -> lt) + canonical_context l + in + let to_be_restricted = ref [] in + let rec deliftaux k = + let module C = Cic in + function + C.Rel m -> + if m <=k then + C.Rel m (*CSC: che succede se c'e' un Def? Dovrebbe averlo gia' *) + (*CSC: deliftato la regola per il LetIn *) + (*CSC: FALSO! La regola per il LetIn non lo fa *) + else + (try + match List.nth context (m-k-1) with + Some (_,C.Def (t,_)) -> + (*CSC: Hmmm. This bit of reduction is not in the spirit of *) + (*CSC: first order unification. Does it help or does it harm? *) + deliftaux k (S.lift m t) + | Some (_,C.Decl t) -> + C.Rel ((position (m-k) l) + k) + | None -> raise (MetaSubstFailure (lazy "RelToHiddenHypothesis")) + with + Failure _ -> + raise (MetaSubstFailure (lazy "Unbound variable found in deliftaux")) + ) + | 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 -> + (try + let (_,t,_) = CicUtil.lookup_subst i subst in + deliftaux k (CicSubstitution.subst_meta l1 t) + with CicUtil.Subst_not_found _ -> + (* see the top level invariant *) + if (i = n) then + raise (MetaSubstFailure (lazy (sprintf + "Cannot unify the metavariable ?%d with a term that has as subterm %s in which the same metavariable occurs (occur check)" + i (ppterm subst t)))) + else + begin + (* I do not consider the term associated to ?i in subst since *) + (* in this way I can restrict if something goes wrong. *) + let rec deliftl j = + function + [] -> [] + | None::tl -> None::(deliftl (j+1) tl) + | (Some t)::tl -> + let l1' = (deliftl (j+1) tl) in + try + Some (deliftaux k t)::l1' + with + NotInTheList + | MetaSubstFailure _ -> + to_be_restricted := + (i,j)::!to_be_restricted ; None::l1' + in + let l' = deliftl 1 l1 in + C.Meta(i,l') + end) + | C.Sort _ as t -> t + | C.Implicit _ as t -> t + | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty) + | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t) + | 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 (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 + let liftedfl = + List.map + (fun (name, i, ty, bo) -> + (name, i, deliftaux k ty, deliftaux (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, deliftaux k ty, deliftaux (k+len) bo)) + fl + in + C.CoFix (i, liftedfl) + in + let res = + try + deliftaux 0 t + with + NotInTheList -> + (* This is the case where we fail even first order unification. *) + (* The reason is that our delift function is weaker than first *) + (* order (in the sense of alpha-conversion). See comment above *) + (* related to the delift function. *) +(* debug_print (lazy "First Order UnificationFailure during delift") ; +debug_print(lazy (sprintf + "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables" + (ppterm subst t) + (String.concat "; " + (List.map + (function Some t -> ppterm subst t | None -> "_") l + )))); *) + raise (Uncertain (lazy (sprintf + "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables" + (ppterm subst t) + (String.concat "; " + (List.map + (function Some t -> ppterm subst t | None -> "_") + l))))) + in + let (metasenv, subst) = restrict subst !to_be_restricted metasenv in + res, metasenv, subst +;; + +(* delifts a term t of n levels strating from k, that is changes (Rel m) + * to (Rel (m - n)) when m > (k + n). if k <= m < k + n delift fails + *) +let delift_rels_from subst metasenv k n = + let rec liftaux subst metasenv k = + let module C = Cic in + function + C.Rel m -> + if m < k then + C.Rel m, subst, metasenv + else if m < k + n then + raise DeliftingARelWouldCaptureAFreeVariable + else + C.Rel (m - n), subst, metasenv + | C.Var (uri,exp_named_subst) -> + let exp_named_subst',subst,metasenv = + List.fold_right + (fun (uri,t) (l,subst,metasenv) -> + let t',subst,metasenv = liftaux subst metasenv k t in + (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) + in + C.Var (uri,exp_named_subst'),subst,metasenv + | C.Meta (i,l) -> + (try + let (_, t,_) = lookup_subst i subst in + liftaux subst metasenv k (CicSubstitution.subst_meta l t) + with CicUtil.Subst_not_found _ -> + let l',to_be_restricted,subst,metasenv = + let rec aux con l subst metasenv = + match l with + [] -> [],[],subst,metasenv + | he::tl -> + let tl',to_be_restricted,subst,metasenv = + aux (con + 1) tl subst metasenv in + let he',more_to_be_restricted,subst,metasenv = + match he with + None -> None,[],subst,metasenv + | Some t -> + try + let t',subst,metasenv = liftaux subst metasenv k t in + Some t',[],subst,metasenv + with + DeliftingARelWouldCaptureAFreeVariable -> + None,[i,con],subst,metasenv + in + he'::tl',more_to_be_restricted@to_be_restricted,subst,metasenv + in + aux 1 l subst metasenv in + let metasenv,subst = restrict subst to_be_restricted metasenv in + C.Meta(i,l'),subst,metasenv) + | C.Sort _ as t -> t,subst,metasenv + | C.Implicit _ as t -> t,subst,metasenv + | C.Cast (te,ty) -> + let te',subst,metasenv = liftaux subst metasenv k te in + let ty',subst,metasenv = liftaux subst metasenv k ty in + C.Cast (te',ty'),subst,metasenv + | C.Prod (n,s,t) -> + let s',subst,metasenv = liftaux subst metasenv k s in + let t',subst,metasenv = liftaux subst metasenv (k+1) t in + C.Prod (n,s',t'),subst,metasenv + | C.Lambda (n,s,t) -> + let s',subst,metasenv = liftaux subst metasenv k s in + let t',subst,metasenv = liftaux subst metasenv (k+1) t in + C.Lambda (n,s',t'),subst,metasenv + | C.LetIn (n,s,t) -> + let s',subst,metasenv = liftaux subst metasenv k s in + let t',subst,metasenv = liftaux subst metasenv (k+1) t in + C.LetIn (n,s',t'),subst,metasenv + | C.Appl l -> + let l',subst,metasenv = + List.fold_right + (fun t (l,subst,metasenv) -> + let t',subst,metasenv = liftaux subst metasenv k t in + t'::l,subst,metasenv) l ([],subst,metasenv) in + C.Appl l',subst,metasenv + | C.Const (uri,exp_named_subst) -> + let exp_named_subst',subst,metasenv = + List.fold_right + (fun (uri,t) (l,subst,metasenv) -> + let t',subst,metasenv = liftaux subst metasenv k t in + (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) + in + C.Const (uri,exp_named_subst'),subst,metasenv + | C.MutInd (uri,tyno,exp_named_subst) -> + let exp_named_subst',subst,metasenv = + List.fold_right + (fun (uri,t) (l,subst,metasenv) -> + let t',subst,metasenv = liftaux subst metasenv k t in + (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) + in + C.MutInd (uri,tyno,exp_named_subst'),subst,metasenv + | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> + let exp_named_subst',subst,metasenv = + List.fold_right + (fun (uri,t) (l,subst,metasenv) -> + let t',subst,metasenv = liftaux subst metasenv k t in + (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv) + in + C.MutConstruct (uri,tyno,consno,exp_named_subst'),subst,metasenv + | C.MutCase (sp,i,outty,t,pl) -> + let outty',subst,metasenv = liftaux subst metasenv k outty in + let t',subst,metasenv = liftaux subst metasenv k t in + let pl',subst,metasenv = + List.fold_right + (fun t (l,subst,metasenv) -> + let t',subst,metasenv = liftaux subst metasenv k t in + t'::l,subst,metasenv) pl ([],subst,metasenv) + in + C.MutCase (sp,i,outty',t',pl'),subst,metasenv + | C.Fix (i, fl) -> + let len = List.length fl in + let liftedfl,subst,metasenv = + List.fold_right + (fun (name, i, ty, bo) (l,subst,metasenv) -> + let ty',subst,metasenv = liftaux subst metasenv k ty in + let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in + (name,i,ty',bo')::l,subst,metasenv + ) fl ([],subst,metasenv) + in + C.Fix (i, liftedfl),subst,metasenv + | C.CoFix (i, fl) -> + let len = List.length fl in + let liftedfl,subst,metasenv = + List.fold_right + (fun (name, ty, bo) (l,subst,metasenv) -> + let ty',subst,metasenv = liftaux subst metasenv k ty in + let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in + (name,ty',bo')::l,subst,metasenv + ) fl ([],subst,metasenv) + in + C.CoFix (i, liftedfl),subst,metasenv + in + liftaux subst metasenv k + +let delift_rels subst metasenv n t = + delift_rels_from subst metasenv 1 n t + + +(**** END OF DELIFT ****) + + +(** {2 Format-like pretty printers} *) + +let fpp_gen ppf s = + Format.pp_print_string ppf s; + Format.pp_print_newline ppf (); + Format.pp_print_flush ppf () + +let fppsubst ppf subst = fpp_gen ppf (ppsubst subst) +let fppterm ppf term = fpp_gen ppf (CicPp.ppterm term) +let fppmetasenv ppf metasenv = fpp_gen ppf (ppmetasenv [] metasenv) + diff --git a/helm/software/components/cic_unification/cicMetaSubst.mli b/helm/software/components/cic_unification/cicMetaSubst.mli new file mode 100644 index 000000000..96f87205f --- /dev/null +++ b/helm/software/components/cic_unification/cicMetaSubst.mli @@ -0,0 +1,92 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +exception MetaSubstFailure of string Lazy.t +exception Uncertain of string Lazy.t +exception AssertFailure of string Lazy.t +exception DeliftingARelWouldCaptureAFreeVariable;; + +(* The entry (i,t) in a substitution means that *) +(* (META i) have been instantiated with t. *) +(* type substitution = (int * (Cic.context * Cic.term)) list *) + + (** @raise SubstNotFound *) + +(* apply_subst subst t *) +(* applies the substitution [subst] to [t] *) +(* [subst] must be already unwinded *) + +val apply_subst : Cic.substitution -> Cic.term -> Cic.term +val apply_subst_context : Cic.substitution -> Cic.context -> Cic.context +val apply_subst_metasenv: Cic.substitution -> Cic.metasenv -> Cic.metasenv + +(*** delifting ***) + +val delift : + int -> Cic.substitution -> Cic.context -> Cic.metasenv -> + (Cic.term option) list -> Cic.term -> + Cic.term * Cic.metasenv * Cic.substitution +val restrict : + Cic.substitution -> (int * int) list -> Cic.metasenv -> + Cic.metasenv * Cic.substitution + +(** delifts the Rels in t of n + * @raise DeliftingARelWouldCaptureAFreeVariable + *) +val delift_rels : + Cic.substitution -> Cic.metasenv -> int -> Cic.term -> + Cic.term * Cic.substitution * Cic.metasenv + +(** {2 Pretty printers} *) + +val ppsubst_unfolded: Cic.substitution -> string +val ppsubst: Cic.substitution -> string +val ppterm: Cic.substitution -> Cic.term -> string +val ppcontext: ?sep: string -> Cic.substitution -> Cic.context -> string +val ppterm_in_name_context: + Cic.substitution -> Cic.term -> (Cic.name option) list -> string +val ppterm_in_context: + Cic.substitution -> Cic.term -> Cic.context -> string +val ppmetasenv: ?sep: string -> Cic.substitution -> Cic.metasenv -> string + +(** {2 Format-like pretty printers} + * As above with prototypes suitable for toplevel/ocamldebug printers. No + * subsitutions are applied here since such printers are required to be invoked + * with only one argument. + *) + +val fppsubst: Format.formatter -> Cic.substitution -> unit +val fppterm: Format.formatter -> Cic.term -> unit +val fppmetasenv: Format.formatter -> Cic.metasenv -> unit + +(* +(* DEBUG *) +val print_counters: unit -> unit +val reset_counters: unit -> unit +*) + +(* val clean_up_meta : + Cic.substitution -> Cic.metasenv -> Cic.term -> Cic.term +*) diff --git a/helm/software/components/cic_unification/cicMkImplicit.ml b/helm/software/components/cic_unification/cicMkImplicit.ml new file mode 100644 index 000000000..36679223c --- /dev/null +++ b/helm/software/components/cic_unification/cicMkImplicit.ml @@ -0,0 +1,122 @@ +(* Copyright (C) 2004, 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/. + *) + +(* $Id$ *) + +(* 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 ?(start = 1) canonical_context = + let rec aux = + function + (_,[]) -> [] + | (n,None::tl) -> None::(aux ((n+1),tl)) + | (n,_::tl) -> (Some (Cic.Rel n))::(aux ((n+1),tl)) + in + aux (start,canonical_context) + +(* Returns the first meta whose number is above the *) +(* number of the higher meta. *) +let new_meta metasenv subst = + 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 + let indexes = + (List.map (fun (i, _, _) -> i) metasenv) @ (List.map fst subst) + in + 1 + aux (None, indexes) + +(* let apply_subst_context = CicMetaSubst.apply_subst_context;; *) +(* questa o la precedente sembrano essere equivalenti come tempi *) +let apply_subst_context _ context = context ;; + +let mk_implicit metasenv subst context = + let newmeta = new_meta metasenv subst in + let newuniv = CicUniv.fresh () in + let irl = identity_relocation_list_for_metavariable context in + (* in the following mk_* functions we apply substitution to canonical + * context since we have the invariant that the metasenv has already been + * instantiated with subst *) + let context = apply_subst_context subst context in + ([ newmeta, [], Cic.Sort (Cic.Type newuniv) ; + (* TASSI: ?? *) + newmeta + 1, context, Cic.Meta (newmeta, []); + newmeta + 2, context, Cic.Meta (newmeta + 1,irl) ] @ metasenv, + newmeta + 2) + +let mk_implicit_type metasenv subst context = + let newmeta = new_meta metasenv subst in + let newuniv = CicUniv.fresh () in + let context = apply_subst_context subst context in + ([ newmeta, [], Cic.Sort (Cic.Type newuniv); + (* TASSI: ?? *) + newmeta + 1, context, Cic.Meta (newmeta, []) ] @metasenv, + newmeta + 1) + +let mk_implicit_sort metasenv subst = + let newmeta = new_meta metasenv subst in + let newuniv = CicUniv.fresh () in + ([ newmeta, [], Cic.Sort (Cic.Type newuniv)] @ metasenv, newmeta) + (* TASSI: ?? *) + +let n_fresh_metas metasenv subst context n = + if n = 0 then metasenv, [] + else + let irl = identity_relocation_list_for_metavariable context in + let context = apply_subst_context subst context in + let newmeta = new_meta metasenv subst in + let newuniv = CicUniv.fresh () in + let rec aux newmeta n = + if n = 0 then metasenv, [] + else + let metasenv', l = aux (newmeta + 3) (n-1) in + (* TASSI: ?? *) + (newmeta, context, Cic.Sort (Cic.Type newuniv)):: + (newmeta + 1, context, Cic.Meta (newmeta, irl)):: + (newmeta + 2, context, Cic.Meta (newmeta + 1,irl))::metasenv', + Cic.Meta(newmeta+2,irl)::l in + aux newmeta n + +let fresh_subst metasenv subst context uris = + let irl = identity_relocation_list_for_metavariable context in + let context = apply_subst_context subst context in + let newmeta = new_meta metasenv subst in + let newuniv = CicUniv.fresh () in + let rec aux newmeta = function + [] -> metasenv, [] + | uri::tl -> + let metasenv', l = aux (newmeta + 3) tl in + (* TASSI: ?? *) + (newmeta, context, Cic.Sort (Cic.Type newuniv)):: + (newmeta + 1, context, Cic.Meta (newmeta, irl)):: + (newmeta + 2, context, Cic.Meta (newmeta + 1,irl))::metasenv', + (uri,Cic.Meta(newmeta+2,irl))::l in + aux newmeta uris + diff --git a/helm/software/components/cic_unification/cicMkImplicit.mli b/helm/software/components/cic_unification/cicMkImplicit.mli new file mode 100644 index 000000000..476270144 --- /dev/null +++ b/helm/software/components/cic_unification/cicMkImplicit.mli @@ -0,0 +1,60 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + + +(* 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 : + ?start: int -> 'a option list -> Cic.term option list + +(* Returns the first meta whose number is above the *) +(* number of the higher meta. *) +val new_meta : Cic.metasenv -> Cic.substitution -> int + +(** [mk_implicit metasenv context] + * add a fresh metavariable to the given metasenv, using given context + * @return the new metasenv and the index of the added conjecture *) +val mk_implicit: Cic.metasenv -> Cic.substitution -> Cic.context -> Cic.metasenv * int + +(** as above, but the fresh metavariable represents a type *) +val mk_implicit_type: Cic.metasenv -> Cic.substitution -> Cic.context -> Cic.metasenv * int + +(** as above, but the fresh metavariable represents a sort *) +val mk_implicit_sort: Cic.metasenv -> Cic.substitution -> Cic.metasenv * int + +(** [mk_implicit metasenv context] create n fresh metavariables *) +val n_fresh_metas: + Cic.metasenv -> Cic.substitution -> Cic.context -> int -> Cic.metasenv * Cic.term list + +(** [fresh_subst metasenv context uris] takes in input a list of uri and +creates a fresh explicit substitution *) +val fresh_subst: + Cic.metasenv -> + Cic.substitution -> + Cic.context -> + UriManager.uri list -> + Cic.metasenv * (Cic.term Cic.explicit_named_substitution) + diff --git a/helm/software/components/cic_unification/cicRefine.ml b/helm/software/components/cic_unification/cicRefine.ml new file mode 100644 index 000000000..620f66f18 --- /dev/null +++ b/helm/software/components/cic_unification/cicRefine.ml @@ -0,0 +1,1395 @@ +(* 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/. + *) + +(* $Id$ *) + +open Printf + +exception RefineFailure of string Lazy.t;; +exception Uncertain of string Lazy.t;; +exception AssertFailure of string Lazy.t;; + +let insert_coercions = ref true + +let debug_print = fun _ -> () + +let profiler = HExtlib.profile "CicRefine.fo_unif" + +let fo_unif_subst subst context metasenv t1 t2 ugraph = + try +let foo () = + CicUnification.fo_unif_subst subst context metasenv t1 t2 ugraph +in profiler.HExtlib.profile foo () + with + (CicUnification.UnificationFailure msg) -> raise (RefineFailure msg) + | (CicUnification.Uncertain msg) -> raise (Uncertain msg) +;; + +let enrich localization_tbl t ?(f = fun msg -> msg) exn = + let exn' = + match exn with + RefineFailure msg -> RefineFailure (f msg) + | Uncertain msg -> Uncertain (f msg) + | _ -> assert false in + let loc = + try + Cic.CicHash.find localization_tbl t + with Not_found -> + prerr_endline ("!!! NOT LOCALIZED: " ^ CicPp.ppterm t); + assert false + in + raise (HExtlib.Localized (loc,exn')) + +let relocalize localization_tbl oldt newt = + try + let infos = Cic.CicHash.find localization_tbl oldt in + Cic.CicHash.remove localization_tbl oldt; + Cic.CicHash.add localization_tbl newt infos; + with + Not_found -> () +;; + +let rec split l n = + match (l,n) with + (l,0) -> ([], l) + | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) + | (_,_) -> raise (AssertFailure (lazy "split: list too short")) +;; + +let exp_impl metasenv subst context = + function + | Some `Type -> + let (metasenv', idx) = CicMkImplicit.mk_implicit_type metasenv subst context in + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + metasenv', Cic.Meta (idx, irl) + | Some `Closed -> + let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst [] in + metasenv', Cic.Meta (idx, []) + | None -> + let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst context in + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + metasenv', Cic.Meta (idx, irl) + | _ -> assert false +;; + + +let rec type_of_constant uri ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let _ = CicTypeChecker.typecheck uri in + let obj,u = + try + CicEnvironment.get_cooked_obj ugraph uri + with Not_found -> assert false + in + match obj with + C.Constant (_,_,ty,_,_) -> ty,u + | C.CurrentProof (_,_,_,ty,_,_) -> ty,u + | _ -> + raise + (RefineFailure (lazy ("Unknown constant definition " ^ U.string_of_uri uri))) + +and type_of_variable uri ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let _ = CicTypeChecker.typecheck uri in + let obj,u = + try + CicEnvironment.get_cooked_obj ugraph uri + with Not_found -> assert false + in + match obj with + C.Variable (_,_,ty,_,_) -> ty,u + | _ -> + raise + (RefineFailure + (lazy ("Unknown variable definition " ^ UriManager.string_of_uri uri))) + +and type_of_mutual_inductive_defs uri i ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let _ = CicTypeChecker.typecheck uri in + let obj,u = + try + CicEnvironment.get_cooked_obj ugraph uri + with Not_found -> assert false + in + match obj with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,arity,_) = List.nth dl i in + arity,u + | _ -> + raise + (RefineFailure + (lazy ("Unknown mutual inductive definition " ^ U.string_of_uri uri))) + +and type_of_mutual_inductive_constr uri i j ugraph = + let module C = Cic in + let module R = CicReduction in + let module U = UriManager in + let _ = CicTypeChecker.typecheck uri in + let obj,u = + try + CicEnvironment.get_cooked_obj ugraph uri + with Not_found -> assert false + in + match obj with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,_,cl) = List.nth dl i in + let (_,ty) = List.nth cl (j-1) in + ty,u + | _ -> + raise + (RefineFailure + (lazy + ("Unkown mutual inductive definition " ^ U.string_of_uri uri))) + + +(* type_of_aux' is just another name (with a different scope) for type_of_aux *) + +(* the check_branch function checks if a branch of a case is refinable. + It returns a pair (outype_instance,args), a subst and a metasenv. + outype_instance is the expected result of applying the case outtype + to args. + The problem is that outype is in general unknown, and we should + try to synthesize it from the above information, that is in general + a second order unification problem. *) + +and check_branch n context metasenv subst left_args_no actualtype term expectedtype ugraph = + let module C = Cic in + (* let module R = CicMetaSubst in *) + let module R = CicReduction in + match R.whd ~subst context expectedtype with + C.MutInd (_,_,_) -> + (n,context,actualtype, [term]), subst, metasenv, ugraph + | C.Appl (C.MutInd (_,_,_)::tl) -> + let (_,arguments) = split tl left_args_no in + (n,context,actualtype, arguments@[term]), subst, metasenv, ugraph + | C.Prod (name,so,de) -> + (* we expect that the actual type of the branch has the due + number of Prod *) + (match R.whd ~subst context actualtype with + C.Prod (name',so',de') -> + let subst, metasenv, ugraph1 = + fo_unif_subst subst context metasenv so so' ugraph in + let term' = + (match CicSubstitution.lift 1 term with + C.Appl l -> C.Appl (l@[C.Rel 1]) + | t -> C.Appl [t ; C.Rel 1]) in + (* we should also check that the name variable is anonymous in + the actual type de' ?? *) + check_branch (n+1) + ((Some (name,(C.Decl so)))::context) + metasenv subst left_args_no de' term' de ugraph1 + | _ -> raise (AssertFailure (lazy "Wrong number of arguments"))) + | _ -> raise (AssertFailure (lazy "Prod or MutInd expected")) + +and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t + ugraph += + let rec type_of_aux subst metasenv context t ugraph = + let module C = Cic in + let module S = CicSubstitution in + let module U = UriManager in + let (t',_,_,_,_) as res = + match t with + (* function *) + C.Rel n -> + (try + match List.nth context (n - 1) with + Some (_,C.Decl ty) -> + t,S.lift n ty,subst,metasenv, ugraph + | Some (_,C.Def (_,Some ty)) -> + t,S.lift n ty,subst,metasenv, ugraph + | Some (_,C.Def (bo,None)) -> + let ty,ugraph = + (* if it is in the context it must be already well-typed*) + CicTypeChecker.type_of_aux' ~subst metasenv context + (S.lift n bo) ugraph + in + t,ty,subst,metasenv,ugraph + | None -> + enrich localization_tbl t + (RefineFailure (lazy "Rel to hidden hypothesis")) + with + _ -> + enrich localization_tbl t + (RefineFailure (lazy "Not a close term"))) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst',subst',metasenv',ugraph1 = + check_exp_named_subst + subst metasenv context exp_named_subst ugraph + in + let ty_uri,ugraph1 = type_of_variable uri ugraph in + let ty = + CicSubstitution.subst_vars exp_named_subst' ty_uri + in + C.Var (uri,exp_named_subst'),ty,subst',metasenv',ugraph1 + | C.Meta (n,l) -> + (try + let (canonical_context, term,ty) = + CicUtil.lookup_subst n subst + in + let l',subst',metasenv',ugraph1 = + check_metasenv_consistency n subst metasenv context + canonical_context l ugraph + in + (* trust or check ??? *) + C.Meta (n,l'),CicSubstitution.subst_meta l' ty, + subst', metasenv', ugraph1 + (* type_of_aux subst metasenv + context (CicSubstitution.subst_meta l term) *) + with CicUtil.Subst_not_found _ -> + let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in + let l',subst',metasenv', ugraph1 = + check_metasenv_consistency n subst metasenv context + canonical_context l ugraph + in + C.Meta (n,l'),CicSubstitution.subst_meta l' ty, + subst', metasenv',ugraph1) + | C.Sort (C.Type tno) -> + let tno' = CicUniv.fresh() in + let ugraph1 = CicUniv.add_gt tno' tno ugraph in + t,(C.Sort (C.Type tno')),subst,metasenv,ugraph1 + | C.Sort _ -> + t,C.Sort (C.Type (CicUniv.fresh())),subst,metasenv,ugraph + | C.Implicit infos -> + let metasenv',t' = exp_impl metasenv subst context infos in + type_of_aux subst metasenv' context t' ugraph + | C.Cast (te,ty) -> + let ty',_,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context ty ugraph + in + let te',inferredty,subst'',metasenv'',ugraph2 = + type_of_aux subst' metasenv' context te ugraph1 + in + (try + let subst''',metasenv''',ugraph3 = + fo_unif_subst subst'' context metasenv'' + inferredty ty' ugraph2 + in + C.Cast (te',ty'),ty',subst''',metasenv''',ugraph3 + with + exn -> + enrich localization_tbl te' + ~f:(fun _ -> + lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst'' te' + context ^ " has type " ^ + CicMetaSubst.ppterm_in_context subst'' inferredty + context ^ " but is here used with type " ^ + CicMetaSubst.ppterm_in_context subst'' ty' context)) exn + ) + | C.Prod (name,s,t) -> + let carr t subst context = CicMetaSubst.apply_subst subst t in + let coerce_to_sort in_source tgt_sort t type_to_coerce + subst context metasenv uragph + = + if not !insert_coercions then + t,type_to_coerce,subst,metasenv,ugraph + else + let coercion_src = carr type_to_coerce subst context in + match coercion_src with + | Cic.Sort _ -> + t,type_to_coerce,subst,metasenv,ugraph + | Cic.Meta _ as meta -> + t, meta, subst, metasenv, ugraph + | Cic.Cast _ as cast -> + t, cast, subst, metasenv, ugraph + | term -> + let coercion_tgt = carr (Cic.Sort tgt_sort) subst context in + let search = CoercGraph.look_for_coercion in + let boh = search coercion_src coercion_tgt in + (match boh with + | CoercGraph.NoCoercion + | CoercGraph.NotHandled _ -> + enrich localization_tbl t + (RefineFailure + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst t context ^ + " is not a type since it has type " ^ + CicMetaSubst.ppterm_in_context + subst coercion_src context ^ " that is not a sort"))) + | CoercGraph.NotMetaClosed -> + enrich localization_tbl t + (Uncertain + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst t context ^ + " is not a type since it has type " ^ + CicMetaSubst.ppterm_in_context + subst coercion_src context ^ " that is not a sort"))) + | CoercGraph.SomeCoercion c -> + let newt, tty, subst, metasenv, ugraph = + avoid_double_coercion + subst metasenv ugraph + (Cic.Appl[c;t]) coercion_tgt + in + newt, tty, subst, metasenv, ugraph) + in + let s',sort1,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context s ugraph + in + let s',sort1,subst', metasenv',ugraph1 = + coerce_to_sort true (Cic.Type(CicUniv.fresh())) + s' sort1 subst' context metasenv' ugraph1 + in + let context_for_t = ((Some (name,(C.Decl s')))::context) in + let t',sort2,subst'',metasenv'',ugraph2 = + type_of_aux subst' metasenv' + context_for_t t ugraph1 + in + let t',sort2,subst'',metasenv'',ugraph2 = + coerce_to_sort false (Cic.Type(CicUniv.fresh())) + t' sort2 subst'' context_for_t metasenv'' ugraph2 + in + let sop,subst''',metasenv''',ugraph3 = + sort_of_prod subst'' metasenv'' + context (name,s') (sort1,sort2) ugraph2 + in + C.Prod (name,s',t'),sop,subst''',metasenv''',ugraph3 + | C.Lambda (n,s,t) -> + + let s',sort1,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context s ugraph in + let s',sort1,subst',metasenv',ugraph1 = + if not !insert_coercions then + s',sort1, subst', metasenv', ugraph1 + else + match CicReduction.whd ~subst:subst' context sort1 with + | C.Meta _ | C.Sort _ -> s',sort1, subst', metasenv', ugraph1 + | coercion_src -> + let coercion_tgt = Cic.Sort (Cic.Type (CicUniv.fresh())) in + let search = CoercGraph.look_for_coercion in + let boh = search coercion_src coercion_tgt in + match boh with + | CoercGraph.SomeCoercion c -> + let newt, tty, subst', metasenv', ugraph1 = + avoid_double_coercion + subst' metasenv' ugraph1 + (Cic.Appl[c;s']) coercion_tgt + in + newt, tty, subst', metasenv', ugraph1 + | CoercGraph.NoCoercion + | CoercGraph.NotHandled _ -> + enrich localization_tbl s' + (RefineFailure + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst s' context ^ + " is not a type since it has type " ^ + CicMetaSubst.ppterm_in_context + subst coercion_src context ^ " that is not a sort"))) + | CoercGraph.NotMetaClosed -> + enrich localization_tbl s' + (Uncertain + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst s' context ^ + " is not a type since it has type " ^ + CicMetaSubst.ppterm_in_context + subst coercion_src context ^ " that is not a sort"))) + in + let context_for_t = ((Some (n,(C.Decl s')))::context) in + let t',type2,subst'',metasenv'',ugraph2 = + type_of_aux subst' metasenv' context_for_t t ugraph1 + in + C.Lambda (n,s',t'),C.Prod (n,s',type2), + subst'',metasenv'',ugraph2 + | C.LetIn (n,s,t) -> + (* only to check if s is well-typed *) + let s',ty,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context s ugraph + in + let context_for_t = ((Some (n,(C.Def (s',Some ty))))::context) in + + let t',inferredty,subst'',metasenv'',ugraph2 = + type_of_aux subst' metasenv' + context_for_t t ugraph1 + in + (* One-step LetIn reduction. + * Even faster than the previous solution. + * Moreover the inferred type is closer to the expected one. + *) + C.LetIn (n,s',t'),CicSubstitution.subst s' inferredty, + subst'',metasenv'',ugraph2 + | C.Appl (he::((_::_) as tl)) -> + let he',hetype,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context he ugraph + in + let tlbody_and_type,subst'',metasenv'',ugraph2 = + List.fold_right + (fun x (res,subst,metasenv,ugraph) -> + let x',ty,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context x ugraph + in + (x', ty)::res,subst',metasenv',ugraph1 + ) tl ([],subst',metasenv',ugraph1) + in + let tl',applty,subst''',metasenv''',ugraph3 = + eat_prods true subst'' metasenv'' context + hetype tlbody_and_type ugraph2 + in + avoid_double_coercion + subst''' metasenv''' ugraph3 (C.Appl (he'::tl')) applty + | C.Appl _ -> assert false + | C.Const (uri,exp_named_subst) -> + let exp_named_subst',subst',metasenv',ugraph1 = + check_exp_named_subst subst metasenv context + exp_named_subst ugraph in + let ty_uri,ugraph2 = type_of_constant uri ugraph1 in + let cty = + CicSubstitution.subst_vars exp_named_subst' ty_uri + in + C.Const (uri,exp_named_subst'),cty,subst',metasenv',ugraph2 + | C.MutInd (uri,i,exp_named_subst) -> + let exp_named_subst',subst',metasenv',ugraph1 = + check_exp_named_subst subst metasenv context + exp_named_subst ugraph + in + let ty_uri,ugraph2 = type_of_mutual_inductive_defs uri i ugraph1 in + let cty = + CicSubstitution.subst_vars exp_named_subst' ty_uri in + C.MutInd (uri,i,exp_named_subst'),cty,subst',metasenv',ugraph2 + | C.MutConstruct (uri,i,j,exp_named_subst) -> + let exp_named_subst',subst',metasenv',ugraph1 = + check_exp_named_subst subst metasenv context + exp_named_subst ugraph + in + let ty_uri,ugraph2 = + type_of_mutual_inductive_constr uri i j ugraph1 + in + let cty = + CicSubstitution.subst_vars exp_named_subst' ty_uri + in + C.MutConstruct (uri,i,j,exp_named_subst'),cty,subst', + metasenv',ugraph2 + | C.MutCase (uri, i, outtype, term, pl) -> + (* first, get the inductive type (and noparams) + * in the environment *) + let (_,b,arity,constructors), expl_params, no_left_params,ugraph = + let _ = CicTypeChecker.typecheck uri in + let obj,u = CicEnvironment.get_cooked_obj ugraph uri in + match obj with + C.InductiveDefinition (l,expl_params,parsno,_) -> + List.nth l i , expl_params, parsno, u + | _ -> + enrich localization_tbl t + (RefineFailure + (lazy ("Unkown mutual inductive definition " ^ + U.string_of_uri uri))) + in + let rec count_prod t = + match CicReduction.whd ~subst context t with + C.Prod (_, _, t) -> 1 + (count_prod t) + | _ -> 0 + in + let no_args = count_prod arity in + (* now, create a "generic" MutInd *) + let metasenv,left_args = + CicMkImplicit.n_fresh_metas metasenv subst context no_left_params + in + let metasenv,right_args = + let no_right_params = no_args - no_left_params in + if no_right_params < 0 then assert false + else CicMkImplicit.n_fresh_metas + metasenv subst context no_right_params + in + let metasenv,exp_named_subst = + CicMkImplicit.fresh_subst metasenv subst context expl_params in + let expected_type = + if no_args = 0 then + C.MutInd (uri,i,exp_named_subst) + else + C.Appl + (C.MutInd (uri,i,exp_named_subst)::(left_args @ right_args)) + in + (* check consistency with the actual type of term *) + let term',actual_type,subst,metasenv,ugraph1 = + type_of_aux subst metasenv context term ugraph in + let expected_type',_, subst, metasenv,ugraph2 = + type_of_aux subst metasenv context expected_type ugraph1 + in + let actual_type = CicReduction.whd ~subst context actual_type in + let subst,metasenv,ugraph3 = + try + fo_unif_subst subst context metasenv + expected_type' actual_type ugraph2 + with + exn -> + enrich localization_tbl term' exn + ~f:(function _ -> + lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst term' + context ^ " has type " ^ + CicMetaSubst.ppterm_in_context subst actual_type + context ^ " but is here used with type " ^ + CicMetaSubst.ppterm_in_context subst expected_type' context)) + in + let rec instantiate_prod t = + function + [] -> t + | he::tl -> + match CicReduction.whd ~subst context t with + C.Prod (_,_,t') -> + instantiate_prod (CicSubstitution.subst he t') tl + | _ -> assert false + in + let arity_instantiated_with_left_args = + instantiate_prod arity left_args in + (* TODO: check if the sort elimination + * is allowed: [(I q1 ... qr)|B] *) + let (pl',_,outtypeinstances,subst,metasenv,ugraph4) = + List.fold_left + (fun (pl,j,outtypeinstances,subst,metasenv,ugraph) p -> + let constructor = + if left_args = [] then + (C.MutConstruct (uri,i,j,exp_named_subst)) + else + (C.Appl + (C.MutConstruct (uri,i,j,exp_named_subst)::left_args)) + in + let p',actual_type,subst,metasenv,ugraph1 = + type_of_aux subst metasenv context p ugraph + in + let constructor',expected_type, subst, metasenv,ugraph2 = + type_of_aux subst metasenv context constructor ugraph1 + in + let outtypeinstance,subst,metasenv,ugraph3 = + check_branch 0 context metasenv subst no_left_params + actual_type constructor' expected_type ugraph2 + in + (pl @ [p'],j+1, + outtypeinstance::outtypeinstances,subst,metasenv,ugraph3)) + ([],1,[],subst,metasenv,ugraph3) pl + in + + (* we are left to check that the outype matches his instances. + The easy case is when the outype is specified, that amount + to a trivial check. Otherwise, we should guess a type from + its instances + *) + + let outtype,outtypety, subst, metasenv,ugraph4 = + type_of_aux subst metasenv context outtype ugraph4 in + (match outtype with + | C.Meta (n,l) -> + (let candidate,ugraph5,metasenv,subst = + let exp_name_subst, metasenv = + let o,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri + in + let uris = CicUtil.params_of_obj o in + List.fold_right ( + fun uri (acc,metasenv) -> + let metasenv',new_meta = + CicMkImplicit.mk_implicit metasenv subst context + in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable + context + in + (uri, Cic.Meta(new_meta,irl))::acc, metasenv' + ) uris ([],metasenv) + in + let ty = + match left_args,right_args with + [],[] -> Cic.MutInd(uri, i, exp_name_subst) + | _,_ -> + let rec mk_right_args = + function + 0 -> [] + | n -> (Cic.Rel n)::(mk_right_args (n - 1)) + in + let right_args_no = List.length right_args in + let lifted_left_args = + List.map (CicSubstitution.lift right_args_no) left_args + in + Cic.Appl (Cic.MutInd(uri,i,exp_name_subst):: + (lifted_left_args @ mk_right_args right_args_no)) + in + let fresh_name = + FreshNamesGenerator.mk_fresh_name ~subst metasenv + context Cic.Anonymous ~typ:ty + in + match outtypeinstances with + | [] -> + let extended_context = + let rec add_right_args = + function + Cic.Prod (name,ty,t) -> + Some (name,Cic.Decl ty)::(add_right_args t) + | _ -> [] + in + (Some (fresh_name,Cic.Decl ty)):: + (List.rev + (add_right_args arity_instantiated_with_left_args))@ + context + in + let metasenv,new_meta = + CicMkImplicit.mk_implicit metasenv subst extended_context + in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable + extended_context + in + let rec add_lambdas b = + function + Cic.Prod (name,ty,t) -> + Cic.Lambda (name,ty,(add_lambdas b t)) + | _ -> Cic.Lambda (fresh_name, ty, b) + in + let candidate = + add_lambdas (Cic.Meta (new_meta,irl)) + arity_instantiated_with_left_args + in + (Some candidate),ugraph4,metasenv,subst + | (constructor_args_no,_,instance,_)::tl -> + try + let instance',subst,metasenv = + CicMetaSubst.delift_rels subst metasenv + constructor_args_no instance + in + let candidate,ugraph,metasenv,subst = + List.fold_left ( + fun (candidate_oty,ugraph,metasenv,subst) + (constructor_args_no,_,instance,_) -> + match candidate_oty with + | None -> None,ugraph,metasenv,subst + | Some ty -> + try + let instance',subst,metasenv = + CicMetaSubst.delift_rels subst metasenv + constructor_args_no instance + in + let subst,metasenv,ugraph = + fo_unif_subst subst context metasenv + instance' ty ugraph + in + candidate_oty,ugraph,metasenv,subst + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + None,ugraph,metasenv,subst + ) (Some instance',ugraph4,metasenv,subst) tl + in + match candidate with + | None -> None, ugraph,metasenv,subst + | Some t -> + let rec add_lambdas n b = + function + Cic.Prod (name,ty,t) -> + Cic.Lambda (name,ty,(add_lambdas (n + 1) b t)) + | _ -> + Cic.Lambda (fresh_name, ty, + CicSubstitution.lift (n + 1) t) + in + Some + (add_lambdas 0 t arity_instantiated_with_left_args), + ugraph,metasenv,subst + with CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + None,ugraph4,metasenv,subst + in + match candidate with + | None -> raise (Uncertain (lazy "can't solve an higher order unification problem")) + | Some candidate -> + let subst,metasenv,ugraph = + fo_unif_subst subst context metasenv + candidate outtype ugraph5 + in + C.MutCase (uri, i, outtype, term', pl'), + CicReduction.head_beta_reduce + (CicMetaSubst.apply_subst subst + (Cic.Appl (outtype::right_args@[term']))), + subst,metasenv,ugraph) + | _ -> (* easy case *) + let tlbody_and_type,subst,metasenv,ugraph4 = + List.fold_right + (fun x (res,subst,metasenv,ugraph) -> + let x',ty,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context x ugraph + in + (x', ty)::res,subst',metasenv',ugraph1 + ) (right_args @ [term']) ([],subst,metasenv,ugraph4) + in + let _,_,subst,metasenv,ugraph4 = + eat_prods false subst metasenv context + outtypety tlbody_and_type ugraph4 + in + let _,_, subst, metasenv,ugraph5 = + type_of_aux subst metasenv context + (C.Appl ((outtype :: right_args) @ [term'])) ugraph4 + in + let (subst,metasenv,ugraph6) = + List.fold_left + (fun (subst,metasenv,ugraph) + (constructor_args_no,context,instance,args) -> + let instance' = + let appl = + let outtype' = + CicSubstitution.lift constructor_args_no outtype + in + C.Appl (outtype'::args) + in + CicReduction.whd ~subst context appl + in + fo_unif_subst subst context metasenv + instance instance' ugraph) + (subst,metasenv,ugraph5) outtypeinstances + in + C.MutCase (uri, i, outtype, term', pl'), + CicReduction.head_beta_reduce + (CicMetaSubst.apply_subst subst + (C.Appl(outtype::right_args@[term]))), + subst,metasenv,ugraph6) + | C.Fix (i,fl) -> + let fl_ty',subst,metasenv,types,ugraph1 = + List.fold_left + (fun (fl,subst,metasenv,types,ugraph) (n,_,ty,_) -> + let ty',_,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context ty ugraph + in + fl @ [ty'],subst',metasenv', + Some (C.Name n,(C.Decl ty')) :: types, ugraph + ) ([],subst,metasenv,[],ugraph) fl + in + let len = List.length types in + let context' = types@context in + let fl_bo',subst,metasenv,ugraph2 = + List.fold_left + (fun (fl,subst,metasenv,ugraph) ((name,x,_,bo),ty) -> + let bo',ty_of_bo,subst,metasenv,ugraph1 = + type_of_aux subst metasenv context' bo ugraph + in + let subst',metasenv',ugraph' = + fo_unif_subst subst context' metasenv + ty_of_bo (CicSubstitution.lift len ty) ugraph1 + in + fl @ [bo'] , subst',metasenv',ugraph' + ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty') + in + let ty = List.nth fl_ty' i in + (* now we have the new ty in fl_ty', the new bo in fl_bo', + * and we want the new fl with bo' and ty' injected in the right + * place. + *) + let rec map3 f l1 l2 l3 = + match l1,l2,l3 with + | [],[],[] -> [] + | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3) + | _ -> assert false + in + let fl'' = map3 (fun ty' bo' (name,x,ty,bo) -> (name,x,ty',bo') ) + fl_ty' fl_bo' fl + in + C.Fix (i,fl''),ty,subst,metasenv,ugraph2 + | C.CoFix (i,fl) -> + let fl_ty',subst,metasenv,types,ugraph1 = + List.fold_left + (fun (fl,subst,metasenv,types,ugraph) (n,ty,_) -> + let ty',_,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context ty ugraph + in + fl @ [ty'],subst',metasenv', + Some (C.Name n,(C.Decl ty')) :: types, ugraph1 + ) ([],subst,metasenv,[],ugraph) fl + in + let len = List.length types in + let context' = types@context in + let fl_bo',subst,metasenv,ugraph2 = + List.fold_left + (fun (fl,subst,metasenv,ugraph) ((name,_,bo),ty) -> + let bo',ty_of_bo,subst,metasenv,ugraph1 = + type_of_aux subst metasenv context' bo ugraph + in + let subst',metasenv',ugraph' = + fo_unif_subst subst context' metasenv + ty_of_bo (CicSubstitution.lift len ty) ugraph1 + in + fl @ [bo'],subst',metasenv',ugraph' + ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty') + in + let ty = List.nth fl_ty' i in + (* now we have the new ty in fl_ty', the new bo in fl_bo', + * and we want the new fl with bo' and ty' injected in the right + * place. + *) + let rec map3 f l1 l2 l3 = + match l1,l2,l3 with + | [],[],[] -> [] + | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3) + | _ -> assert false + in + let fl'' = map3 (fun ty' bo' (name,ty,bo) -> (name,ty',bo') ) + fl_ty' fl_bo' fl + in + C.CoFix (i,fl''),ty,subst,metasenv,ugraph2 + in + relocalize localization_tbl t t'; + res + + and avoid_double_coercion subst metasenv ugraph t ty = + match t with + | (Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ]) when + CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 -> + let source_carr = CoercGraph.source_of c2 in + let tgt_carr = CicMetaSubst.apply_subst subst ty in + (match CoercGraph.look_for_coercion source_carr tgt_carr + with + | CoercGraph.SomeCoercion c -> + Cic.Appl [ c ; head ], ty, subst,metasenv,ugraph + | _ -> assert false) (* the composite coercion must exist *) + | _ -> t, ty, subst, metasenv, ugraph + + (* 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 + metano subst metasenv context canonical_context l ugraph + = + 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.subst_meta l (S.lift i t))))::(aux (i+1) tl) + | (Some (n,C.Def (t,None)))::tl -> + (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl) + | None::tl -> None::(aux (i+1) tl) + | (Some (n,C.Def (t,Some ty)))::tl -> + (Some (n, + C.Def ((S.subst_meta l (S.lift i t)), + Some (S.subst_meta l (S.lift i ty))))) :: (aux (i+1) tl) + in + aux 1 canonical_context + in + try + List.fold_left2 + (fun (l,subst,metasenv,ugraph) t ct -> + match (t,ct) with + _,None -> + l @ [None],subst,metasenv,ugraph + | Some t,Some (_,C.Def (ct,_)) -> + let subst',metasenv',ugraph' = + (try + fo_unif_subst subst context metasenv t ct ugraph + with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since %s cannot be unified with %s. Reason: %s" (CicMetaSubst.ppterm subst t) (CicMetaSubst.ppterm subst ct) (match e with AssertFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e)))))) + in + l @ [Some t],subst',metasenv',ugraph' + | Some t,Some (_,C.Decl ct) -> + let t',inferredty,subst',metasenv',ugraph1 = + type_of_aux subst metasenv context t ugraph + in + let subst'',metasenv'',ugraph2 = + (try + fo_unif_subst + subst' context metasenv' inferredty ct ugraph1 + with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since the type %s of %s cannot be unified with the expected type %s. Reason: %s" (CicMetaSubst.ppterm subst' inferredty) (CicMetaSubst.ppterm subst' t) (CicMetaSubst.ppterm subst' ct) (match e with AssertFailure msg -> Lazy.force msg | RefineFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e)))))) + in + l @ [Some t'], subst'',metasenv'',ugraph2 + | None, Some _ -> + raise (RefineFailure (lazy (sprintf "Not well typed metavariable instance %s: the local context does not instantiate an hypothesis even if the hypothesis is not restricted in the canonical context %s" (CicMetaSubst.ppterm subst (Cic.Meta (metano, l))) (CicMetaSubst.ppcontext subst canonical_context))))) ([],subst,metasenv,ugraph) l lifted_canonical_context + with + Invalid_argument _ -> + raise + (RefineFailure + (lazy (sprintf + "Not well typed metavariable instance %s: the length of the local context does not match the length of the canonical context %s" + (CicMetaSubst.ppterm subst (Cic.Meta (metano, l))) + (CicMetaSubst.ppcontext subst canonical_context)))) + + and check_exp_named_subst metasubst metasenv context tl ugraph = + let rec check_exp_named_subst_aux metasubst metasenv substs tl ugraph = + match tl with + [] -> [],metasubst,metasenv,ugraph + | (uri,t)::tl -> + let ty_uri,ugraph1 = type_of_variable uri ugraph in + let typeofvar = + CicSubstitution.subst_vars substs ty_uri in + (* CSC: why was this code here? it is wrong + (match CicEnvironment.get_cooked_obj ~trust:false uri with + Cic.Variable (_,Some bo,_,_) -> + raise + (RefineFailure (lazy + "A variable with a body can not be explicit substituted")) + | Cic.Variable (_,None,_,_) -> () + | _ -> + raise + (RefineFailure (lazy + ("Unkown variable definition " ^ UriManager.string_of_uri uri))) + ) ; + *) + let t',typeoft,metasubst',metasenv',ugraph2 = + type_of_aux metasubst metasenv context t ugraph1 in + let subst = uri,t' in + let metasubst'',metasenv'',ugraph3 = + try + fo_unif_subst + metasubst' context metasenv' typeoft typeofvar ugraph2 + with _ -> + raise (RefineFailure (lazy + ("Wrong Explicit Named Substitution: " ^ + CicMetaSubst.ppterm metasubst' typeoft ^ + " not unifiable with " ^ + CicMetaSubst.ppterm metasubst' typeofvar))) + in + (* FIXME: no mere tail recursive! *) + let exp_name_subst, metasubst''', metasenv''', ugraph4 = + check_exp_named_subst_aux + metasubst'' metasenv'' (substs@[subst]) tl ugraph3 + in + ((uri,t')::exp_name_subst), metasubst''', metasenv''', ugraph4 + in + check_exp_named_subst_aux metasubst metasenv [] tl ugraph + + + and sort_of_prod subst metasenv context (name,s) (t1, t2) ugraph = + let module C = Cic in + let context_for_t2 = (Some (name,C.Decl s))::context in + let t1'' = CicReduction.whd ~subst context t1 in + let t2'' = CicReduction.whd ~subst context_for_t2 t2 in + match (t1'', t2'') with + (C.Sort s1, C.Sort s2) + when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) -> + (* different than Coq manual!!! *) + C.Sort s2,subst,metasenv,ugraph + | (C.Sort (C.Type t1), C.Sort (C.Type t2)) -> + let t' = CicUniv.fresh() in + let ugraph1 = CicUniv.add_ge t' t1 ugraph in + let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in + C.Sort (C.Type t'),subst,metasenv,ugraph2 + | (C.Sort _,C.Sort (C.Type t1)) -> + C.Sort (C.Type t1),subst,metasenv,ugraph + | (C.Meta _, C.Sort _) -> t2'',subst,metasenv,ugraph + | (C.Sort _,C.Meta _) | (C.Meta _,C.Meta _) -> + (* TODO how can we force the meta to become a sort? If we don't we + * brake the invariant that refine produce only well typed terms *) + (* TODO if we check the non meta term and if it is a sort then we + * are likely to know the exact value of the result e.g. if the rhs + * is a Sort (Prop | Set | CProp) then the result is the rhs *) + let (metasenv,idx) = + CicMkImplicit.mk_implicit_sort metasenv subst in + let (subst, metasenv,ugraph1) = + fo_unif_subst subst context_for_t2 metasenv + (C.Meta (idx,[])) t2'' ugraph + in + t2'',subst,metasenv,ugraph1 + | _,_ -> + raise + (RefineFailure + (lazy + (sprintf + ("Two sorts were expected, found %s " ^^ + "(that reduces to %s) and %s (that reduces to %s)") + (CicPp.ppterm t1) (CicPp.ppterm t1'') (CicPp.ppterm t2) + (CicPp.ppterm t2'')))) + + and eat_prods + allow_coercions subst metasenv context hetype tlbody_and_type ugraph + = + let rec mk_prod metasenv context' = + function + [] -> + let (metasenv, idx) = + CicMkImplicit.mk_implicit_type metasenv subst context' + in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context' + in + metasenv,Cic.Meta (idx, irl) + | (_,argty)::tl -> + let (metasenv, idx) = + CicMkImplicit.mk_implicit_type metasenv subst context' + in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context' + in + let meta = Cic.Meta (idx,irl) in + let name = + (* The name must be fresh for context. *) + (* Nevertheless, argty is well-typed only in context. *) + (* Thus I generate a name (name_hint) in context and *) + (* then I generate a name --- using the hint name_hint *) + (* --- that is fresh in context'. *) + let name_hint = + (* Cic.Name "pippo" *) + FreshNamesGenerator.mk_fresh_name ~subst metasenv + (* (CicMetaSubst.apply_subst_metasenv subst metasenv) *) + (CicMetaSubst.apply_subst_context subst context) + Cic.Anonymous + ~typ:(CicMetaSubst.apply_subst subst argty) + in + (* [] and (Cic.Sort Cic.prop) are dummy: they will not be used *) + FreshNamesGenerator.mk_fresh_name ~subst + [] context' name_hint ~typ:(Cic.Sort Cic.Prop) + in + let metasenv,target = + mk_prod metasenv ((Some (name, Cic.Decl meta))::context') tl + in + metasenv,Cic.Prod (name,meta,target) + in + let metasenv,hetype' = mk_prod metasenv context tlbody_and_type in + let (subst, metasenv,ugraph1) = + try + fo_unif_subst subst context metasenv hetype hetype' ugraph + with exn -> + debug_print (lazy (Printf.sprintf "hetype=%s\nhetype'=%s\nmetasenv=%s\nsubst=%s" + (CicPp.ppterm hetype) + (CicPp.ppterm hetype') + (CicMetaSubst.ppmetasenv [] metasenv) + (CicMetaSubst.ppsubst subst))); + raise exn + + in + let rec eat_prods metasenv subst context hetype ugraph = + function + | [] -> [],metasenv,subst,hetype,ugraph + | (hete, hety)::tl -> + (match hetype with + Cic.Prod (n,s,t) -> + let arg,subst,metasenv,ugraph1 = + try + let subst,metasenv,ugraph1 = + fo_unif_subst subst context metasenv hety s ugraph + in + hete,subst,metasenv,ugraph1 + with exn when allow_coercions && !insert_coercions -> + (* we search a coercion from hety to s *) + let coer, tgt_carr = + let carr t subst context = + CicMetaSubst.apply_subst subst t + in + let c_hety = carr hety subst context in + let c_s = carr s subst context in + CoercGraph.look_for_coercion c_hety c_s, c_s + in + (match coer with + | CoercGraph.NoCoercion + | CoercGraph.NotHandled _ -> + enrich localization_tbl hete + (RefineFailure + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst hete + context ^ " has type " ^ + CicMetaSubst.ppterm_in_context subst hety + context ^ " but is here used with type " ^ + CicMetaSubst.ppterm_in_context subst s context + (* "\nReason: " ^ Lazy.force e*)))) + | CoercGraph.NotMetaClosed -> + enrich localization_tbl hete + (Uncertain + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst hete + context ^ " has type " ^ + CicMetaSubst.ppterm_in_context subst hety + context ^ " but is here used with type " ^ + CicMetaSubst.ppterm_in_context subst s context + (* "\nReason: " ^ Lazy.force e*)))) + | CoercGraph.SomeCoercion c -> + let newt, _, subst, metasenv, ugraph = + avoid_double_coercion + subst metasenv ugraph + (Cic.Appl[c;hete]) tgt_carr in + try + let newty,newhety,subst,metasenv,ugraph = + type_of_aux subst metasenv context newt ugraph in + let subst,metasenv,ugraph1 = + fo_unif_subst subst context metasenv + newhety s ugraph + in + newt, subst, metasenv, ugraph + with exn -> + enrich localization_tbl hete + ~f:(fun _ -> + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst hete + context ^ " has type " ^ + CicMetaSubst.ppterm_in_context subst hety + context ^ " but is here used with type " ^ + CicMetaSubst.ppterm_in_context subst s context + (* "\nReason: " ^ Lazy.force e*)))) exn) + | exn -> + enrich localization_tbl hete + ~f:(fun _ -> + (lazy ("The term " ^ + CicMetaSubst.ppterm_in_context subst hete + context ^ " has type " ^ + CicMetaSubst.ppterm_in_context subst hety + context ^ " but is here used with type " ^ + CicMetaSubst.ppterm_in_context subst s context + (* "\nReason: " ^ Lazy.force e*)))) exn + in + let coerced_args,metasenv',subst',t',ugraph2 = + eat_prods metasenv subst context + (CicSubstitution.subst arg t) ugraph1 tl + in + arg::coerced_args,metasenv',subst',t',ugraph2 + | _ -> assert false + ) + in + let coerced_args,metasenv,subst,t,ugraph2 = + eat_prods metasenv subst context hetype' ugraph1 tlbody_and_type + in + coerced_args,t,subst,metasenv,ugraph2 + in + + (* eat prods ends here! *) + + let t',ty,subst',metasenv',ugraph1 = + type_of_aux [] metasenv context t ugraph + in + let substituted_t = CicMetaSubst.apply_subst subst' t' in + let substituted_ty = CicMetaSubst.apply_subst subst' ty in + (* Andrea: ho rimesso qui l'applicazione della subst al + metasenv dopo che ho droppato l'invariante che il metsaenv + e' sempre istanziato *) + let substituted_metasenv = + CicMetaSubst.apply_subst_metasenv subst' metasenv' in + (* metasenv' *) + (* substituted_t,substituted_ty,substituted_metasenv *) + (* ANDREA: spostare tutta questa robaccia da un altra parte *) + let cleaned_t = + FreshNamesGenerator.clean_dummy_dependent_types substituted_t in + let cleaned_ty = + FreshNamesGenerator.clean_dummy_dependent_types substituted_ty in + let cleaned_metasenv = + List.map + (function (n,context,ty) -> + let ty' = FreshNamesGenerator.clean_dummy_dependent_types ty in + let context' = + List.map + (function + None -> None + | Some (n, Cic.Decl t) -> + Some (n, + Cic.Decl (FreshNamesGenerator.clean_dummy_dependent_types t)) + | Some (n, Cic.Def (bo,ty)) -> + let bo' = FreshNamesGenerator.clean_dummy_dependent_types bo in + let ty' = + match ty with + None -> None + | Some ty -> + Some (FreshNamesGenerator.clean_dummy_dependent_types ty) + in + Some (n, Cic.Def (bo',ty')) + ) context + in + (n,context',ty') + ) substituted_metasenv + in + (cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1) +;; + +let type_of_aux' ?localization_tbl metasenv context term ugraph = + try + type_of_aux' ?localization_tbl metasenv context term ugraph + with + CicUniv.UniverseInconsistency msg -> raise (RefineFailure (lazy msg)) + +let undebrujin uri typesno tys t = + snd + (List.fold_right + (fun (name,_,_,_) (i,t) -> + (* here the explicit_named_substituion is assumed to be *) + (* of length 0 *) + let t' = Cic.MutInd (uri,i,[]) in + let t = CicSubstitution.subst t' t in + i - 1,t + ) tys (typesno - 1,t)) + +let map_first_n n start f g l = + let rec aux acc k l = + if k < n then + match l with + | [] -> raise (Invalid_argument "map_first_n") + | hd :: tl -> f hd k (aux acc (k+1) tl) + else + g acc l + in + aux start 0 l + +(*CSC: this is a very rough approximation; to be finished *) +let are_all_occurrences_positive metasenv ugraph uri tys leftno = + let subst,metasenv,ugraph,tys = + List.fold_right + (fun (name,ind,arity,cl) (subst,metasenv,ugraph,acc) -> + let subst,metasenv,ugraph,cl = + List.fold_right + (fun (name,ty) (subst,metasenv,ugraph,acc) -> + let rec aux ctx k subst = function + | Cic.Appl((Cic.MutInd (uri',_,_)as hd)::tl) when uri = uri'-> + let subst,metasenv,ugraph,tl = + map_first_n leftno + (subst,metasenv,ugraph,[]) + (fun t n (subst,metasenv,ugraph,acc) -> + let subst,metasenv,ugraph = + fo_unif_subst + subst ctx metasenv t (Cic.Rel (k-n)) ugraph + in + subst,metasenv,ugraph,(t::acc)) + (fun (s,m,g,acc) tl -> assert(acc=[]);(s,m,g,tl)) + tl + in + subst,metasenv,ugraph,(Cic.Appl (hd::tl)) + | Cic.MutInd(uri',_,_) as t when uri = uri'-> + subst,metasenv,ugraph,t + | Cic.Prod (name,s,t) -> + let ctx = (Some (name,Cic.Decl s))::ctx in + let subst,metasenv,ugraph,t = aux ctx (k+1) subst t in + subst,metasenv,ugraph,Cic.Prod (name,s,t) + | _ -> + raise + (RefineFailure + (lazy "not well formed constructor type")) + in + let subst,metasenv,ugraph,ty = aux [] 0 subst ty in + subst,metasenv,ugraph,(name,ty) :: acc) + cl (subst,metasenv,ugraph,[]) + in + subst,metasenv,ugraph,(name,ind,arity,cl)::acc) + tys ([],metasenv,ugraph,[]) + in + let substituted_tys = + List.map + (fun (name,ind,arity,cl) -> + let cl = + List.map (fun (name, ty) -> name,CicMetaSubst.apply_subst subst ty) cl + in + name,ind,CicMetaSubst.apply_subst subst arity,cl) + tys + in + metasenv,ugraph,substituted_tys + +let typecheck metasenv uri obj ~localization_tbl = + let ugraph = CicUniv.empty_ugraph in + match obj with + Cic.Constant (name,Some bo,ty,args,attrs) -> + let bo',boty,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv [] bo ugraph in + let ty',_,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv [] ty ugraph in + let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in + let bo' = CicMetaSubst.apply_subst subst bo' in + let ty' = CicMetaSubst.apply_subst subst ty' in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + Cic.Constant (name,Some bo',ty',args,attrs),metasenv,ugraph + | Cic.Constant (name,None,ty,args,attrs) -> + let ty',_,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv [] ty ugraph + in + Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph + | Cic.CurrentProof (name,metasenv',bo,ty,args,attrs) -> + assert (metasenv' = metasenv); + (* Here we do not check the metasenv for correctness *) + let bo',boty,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv [] bo ugraph in + let ty',sort,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv [] ty ugraph in + begin + match sort with + Cic.Sort _ + (* instead of raising Uncertain, let's hope that the meta will become + a sort *) + | Cic.Meta _ -> () + | _ -> raise (RefineFailure (lazy "The term provided is not a type")) + end; + let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in + let bo' = CicMetaSubst.apply_subst subst bo' in + let ty' = CicMetaSubst.apply_subst subst ty' in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + Cic.CurrentProof (name,metasenv,bo',ty',args,attrs),metasenv,ugraph + | Cic.Variable _ -> assert false (* not implemented *) + | Cic.InductiveDefinition (tys,args,paramsno,attrs) -> + (*CSC: this code is greately simplified and many many checks are missing *) + (*CSC: e.g. the constructors are not required to build their own types, *) + (*CSC: the arities are not required to have as type a sort, etc. *) + let uri = match uri with Some uri -> uri | None -> assert false in + let typesno = List.length tys in + (* first phase: we fix only the types *) + let metasenv,ugraph,tys = + List.fold_right + (fun (name,b,ty,cl) (metasenv,ugraph,res) -> + let ty',_,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv [] ty ugraph + in + metasenv,ugraph,(name,b,ty',cl)::res + ) tys (metasenv,ugraph,[]) in + let con_context = + List.rev_map (fun (name,_,ty,_)-> Some (Cic.Name name,Cic.Decl ty)) tys in + (* second phase: we fix only the constructors *) + let metasenv,ugraph,tys = + List.fold_right + (fun (name,b,ty,cl) (metasenv,ugraph,res) -> + let metasenv,ugraph,cl' = + List.fold_right + (fun (name,ty) (metasenv,ugraph,res) -> + let ty = + CicTypeChecker.debrujin_constructor + ~cb:(relocalize localization_tbl) uri typesno ty in + let ty',_,metasenv,ugraph = + type_of_aux' ~localization_tbl metasenv con_context ty ugraph in + let ty' = undebrujin uri typesno tys ty' in + metasenv,ugraph,(name,ty')::res + ) cl (metasenv,ugraph,[]) + in + metasenv,ugraph,(name,b,ty,cl')::res + ) tys (metasenv,ugraph,[]) in + (* third phase: we check the positivity condition *) + let metasenv,ugraph,tys = + are_all_occurrences_positive metasenv ugraph uri tys paramsno + in + Cic.InductiveDefinition (tys,args,paramsno,attrs),metasenv,ugraph + +(* DEBUGGING ONLY +let type_of_aux' metasenv context term = + try + let (t,ty,m) = + type_of_aux' metasenv context term in + debug_print (lazy + ("@@@ REFINE SUCCESSFUL: " ^ CicPp.ppterm t ^ " : " ^ CicPp.ppterm ty)); + debug_print (lazy + ("@@@ REFINE SUCCESSFUL (metasenv):\n" ^ CicMetaSubst.ppmetasenv ~sep:";" m [])); + (t,ty,m) + with + | RefineFailure msg as e -> + debug_print (lazy ("@@@ REFINE FAILED: " ^ msg)); + raise e + | Uncertain msg as e -> + debug_print (lazy ("@@@ REFINE UNCERTAIN: " ^ msg)); + raise e +;; *) + +let profiler2 = HExtlib.profile "CicRefine" + +let type_of_aux' ?localization_tbl metasenv context term ugraph = + profiler2.HExtlib.profile + (type_of_aux' ?localization_tbl metasenv context term) ugraph + +let typecheck ~localization_tbl metasenv uri obj = + profiler2.HExtlib.profile (typecheck ~localization_tbl metasenv uri) obj diff --git a/helm/software/components/cic_unification/cicRefine.mli b/helm/software/components/cic_unification/cicRefine.mli new file mode 100644 index 000000000..224a7586c --- /dev/null +++ b/helm/software/components/cic_unification/cicRefine.mli @@ -0,0 +1,48 @@ +(* 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 RefineFailure of string Lazy.t;; +exception Uncertain of string Lazy.t;; +exception AssertFailure of string Lazy.t;; + +(* type_of_aux' metasenv context term graph *) +(* refines [term] and returns the refined form of [term], *) +(* its type, the new metasenv and universe graph. *) +val type_of_aux': + ?localization_tbl:Token.flocation Cic.CicHash.t -> + Cic.metasenv -> Cic.context -> Cic.term -> CicUniv.universe_graph -> + Cic.term * Cic.term * Cic.metasenv * CicUniv.universe_graph + +(* typecheck metasenv uri obj graph *) +(* refines [obj] and returns the refined form of [obj], *) +(* the new metasenv and universe graph. *) +(* the [uri] is required only for inductive definitions *) +val typecheck : + localization_tbl:Token.flocation Cic.CicHash.t -> + Cic.metasenv -> UriManager.uri option -> Cic.obj -> + Cic.obj * Cic.metasenv * CicUniv.universe_graph + +val insert_coercions: bool ref (* initially true *) + diff --git a/helm/software/components/cic_unification/cicUnification.ml b/helm/software/components/cic_unification/cicUnification.ml new file mode 100644 index 000000000..d1e010ca6 --- /dev/null +++ b/helm/software/components/cic_unification/cicUnification.ml @@ -0,0 +1,800 @@ +(* 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/. + *) + +(* $Id$ *) + +open Printf + +exception UnificationFailure of string Lazy.t;; +exception Uncertain of string Lazy.t;; +exception AssertFailure of string Lazy.t;; + +let verbose = false;; +let debug_print = fun _ -> () + +let profiler_toa = HExtlib.profile "fo_unif_subst.type_of_aux'" +let profiler_beta_expand = HExtlib.profile "fo_unif_subst.beta_expand" +let profiler_deref = HExtlib.profile "fo_unif_subst.deref'" +let profiler_are_convertible = HExtlib.profile "fo_unif_subst.are_convertible" + +let type_of_aux' metasenv subst context term ugraph = +let foo () = + try + CicTypeChecker.type_of_aux' ~subst metasenv context term ugraph + with + CicTypeChecker.TypeCheckerFailure msg -> + let msg = + lazy + (sprintf + "Kernel Type checking error: +%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad." + (CicMetaSubst.ppterm subst term) + (CicMetaSubst.ppterm [] term) + (CicMetaSubst.ppcontext subst context) + (CicMetaSubst.ppmetasenv subst metasenv) + (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in + raise (AssertFailure msg) + | CicTypeChecker.AssertFailure msg -> + let msg = lazy + (sprintf + "Kernel Type checking assertion failure: +%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad." + (CicMetaSubst.ppterm subst term) + (CicMetaSubst.ppterm [] term) + (CicMetaSubst.ppcontext subst context) + (CicMetaSubst.ppmetasenv subst metasenv) + (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in + raise (AssertFailure msg) +in profiler_toa.HExtlib.profile foo () +;; + +let exists_a_meta l = + List.exists (function Cic.Meta _ -> true | _ -> false) l + +let rec deref subst t = + let snd (_,a,_) = a in + match t with + Cic.Meta(n,l) -> + (try + deref subst + (CicSubstitution.subst_meta + l (snd (CicUtil.lookup_subst n subst))) + with + CicUtil.Subst_not_found _ -> t) + | Cic.Appl(Cic.Meta(n,l)::args) -> + (match deref subst (Cic.Meta(n,l)) with + | Cic.Lambda _ as t -> + deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args))) + | r -> Cic.Appl(r::args)) + | Cic.Appl(((Cic.Lambda _) as t)::args) -> + deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args))) + | t -> t +;; + +let deref subst t = + let foo () = deref subst t + in profiler_deref.HExtlib.profile foo () + +exception WrongShape;; +let eta_reduce after_beta_expansion after_beta_expansion_body + before_beta_expansion + = + try + match before_beta_expansion,after_beta_expansion_body with + Cic.Appl l, Cic.Appl l' -> + let rec all_but_last check_last = + function + [] -> assert false + | [Cic.Rel 1] -> [] + | [_] -> if check_last then raise WrongShape else [] + | he::tl -> he::(all_but_last check_last tl) + in + let all_but_last check_last l = + match all_but_last check_last l with + [] -> assert false + | [he] -> he + | l -> Cic.Appl l + in + let t = CicSubstitution.subst (Cic.Rel (-1)) (all_but_last true l') in + let all_but_last = all_but_last false l in + (* here we should test alpha-equivalence; however we know by + construction that here alpha_equivalence is equivalent to = *) + if t = all_but_last then + all_but_last + else + after_beta_expansion + | _,_ -> after_beta_expansion + with + WrongShape -> after_beta_expansion + +let rec beta_expand test_equality_only metasenv subst context t arg ugraph = + let module S = CicSubstitution in + let module C = Cic in +let foo () = + let rec aux metasenv subst n context t' ugraph = + try + + let subst,metasenv,ugraph1 = + fo_unif_subst test_equality_only subst context metasenv + (CicSubstitution.lift n arg) t' ugraph + + in + subst,metasenv,C.Rel (1 + n),ugraph1 + with + Uncertain _ + | UnificationFailure _ -> + match t' with + | C.Rel m -> subst,metasenv, + (if m <= n then C.Rel m else C.Rel (m+1)),ugraph + | C.Var (uri,exp_named_subst) -> + let subst,metasenv,exp_named_subst',ugraph1 = + aux_exp_named_subst metasenv subst n context exp_named_subst ugraph + in + subst,metasenv,C.Var (uri,exp_named_subst'),ugraph1 + | C.Meta (i,l) -> + (* andrea: in general, beta_expand can create badly typed + terms. This happens quite seldom in practice, UNLESS we + iterate on the local context. For this reason, we renounce + to iterate and just lift *) + let l = + List.map + (function + Some t -> Some (CicSubstitution.lift 1 t) + | None -> None) l in + subst, metasenv, C.Meta (i,l), ugraph + | C.Sort _ + | C.Implicit _ as t -> subst,metasenv,t,ugraph + | C.Cast (te,ty) -> + let subst,metasenv,te',ugraph1 = + aux metasenv subst n context te ugraph in + let subst,metasenv,ty',ugraph2 = + aux metasenv subst n context ty ugraph1 in + (* TASSI: sure this is in serial? *) + subst,metasenv,(C.Cast (te', ty')),ugraph2 + | C.Prod (nn,s,t) -> + let subst,metasenv,s',ugraph1 = + aux metasenv subst n context s ugraph in + let subst,metasenv,t',ugraph2 = + aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t + ugraph1 + in + (* TASSI: sure this is in serial? *) + subst,metasenv,(C.Prod (nn, s', t')),ugraph2 + | C.Lambda (nn,s,t) -> + let subst,metasenv,s',ugraph1 = + aux metasenv subst n context s ugraph in + let subst,metasenv,t',ugraph2 = + aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t ugraph1 + in + (* TASSI: sure this is in serial? *) + subst,metasenv,(C.Lambda (nn, s', t')),ugraph2 + | C.LetIn (nn,s,t) -> + let subst,metasenv,s',ugraph1 = + aux metasenv subst n context s ugraph in + let subst,metasenv,t',ugraph2 = + aux metasenv subst (n+1) ((Some (nn, C.Def (s,None)))::context) t + ugraph1 + in + (* TASSI: sure this is in serial? *) + subst,metasenv,(C.LetIn (nn, s', t')),ugraph2 + | C.Appl l -> + let subst,metasenv,revl',ugraph1 = + List.fold_left + (fun (subst,metasenv,appl,ugraph) t -> + let subst,metasenv,t',ugraph1 = + aux metasenv subst n context t ugraph in + subst,metasenv,(t'::appl),ugraph1 + ) (subst,metasenv,[],ugraph) l + in + subst,metasenv,(C.Appl (List.rev revl')),ugraph1 + | C.Const (uri,exp_named_subst) -> + let subst,metasenv,exp_named_subst',ugraph1 = + aux_exp_named_subst metasenv subst n context exp_named_subst ugraph + in + subst,metasenv,(C.Const (uri,exp_named_subst')),ugraph1 + | C.MutInd (uri,i,exp_named_subst) -> + let subst,metasenv,exp_named_subst',ugraph1 = + aux_exp_named_subst metasenv subst n context exp_named_subst ugraph + in + subst,metasenv,(C.MutInd (uri,i,exp_named_subst')),ugraph1 + | C.MutConstruct (uri,i,j,exp_named_subst) -> + let subst,metasenv,exp_named_subst',ugraph1 = + aux_exp_named_subst metasenv subst n context exp_named_subst ugraph + in + subst,metasenv,(C.MutConstruct (uri,i,j,exp_named_subst')),ugraph1 + | C.MutCase (sp,i,outt,t,pl) -> + let subst,metasenv,outt',ugraph1 = + aux metasenv subst n context outt ugraph in + let subst,metasenv,t',ugraph2 = + aux metasenv subst n context t ugraph1 in + let subst,metasenv,revpl',ugraph3 = + List.fold_left + (fun (subst,metasenv,pl,ugraph) t -> + let subst,metasenv,t',ugraph1 = + aux metasenv subst n context t ugraph in + subst,metasenv,(t'::pl),ugraph1 + ) (subst,metasenv,[],ugraph2) pl + in + subst,metasenv,(C.MutCase (sp,i,outt', t', List.rev revpl')),ugraph3 + (* TASSI: not sure this is serial *) + | C.Fix (i,fl) -> +(*CSC: not implemented + 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) +*) + subst,metasenv,(CicSubstitution.lift 1 t' ),ugraph + | C.CoFix (i,fl) -> +(*CSC: not implemented + 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) + +*) + subst,metasenv,(CicSubstitution.lift 1 t'), ugraph + + and aux_exp_named_subst metasenv subst n context ens ugraph = + List.fold_right + (fun (uri,t) (subst,metasenv,l,ugraph) -> + let subst,metasenv,t',ugraph1 = aux metasenv subst n context t ugraph in + subst,metasenv,((uri,t')::l),ugraph1) ens (subst,metasenv,[],ugraph) + in + let argty,ugraph1 = type_of_aux' metasenv subst context arg ugraph in + let fresh_name = + FreshNamesGenerator.mk_fresh_name ~subst + metasenv context (Cic.Name "Hbeta") ~typ:argty + in + let subst,metasenv,t',ugraph2 = aux metasenv subst 0 context t ugraph1 in + let t'' = eta_reduce (C.Lambda (fresh_name,argty,t')) t' t in + subst, metasenv, t'', ugraph2 +in profiler_beta_expand.HExtlib.profile foo () + + +and beta_expand_many test_equality_only metasenv subst context t args ugraph = + let subst,metasenv,hd,ugraph = + List.fold_right + (fun arg (subst,metasenv,t,ugraph) -> + let subst,metasenv,t,ugraph1 = + beta_expand test_equality_only + metasenv subst context t arg ugraph + in + subst,metasenv,t,ugraph1 + ) args (subst,metasenv,t,ugraph) + in + subst,metasenv,hd,ugraph + + +(* NUOVA UNIFICAZIONE *) +(* A substitution is a (int * Cic.term) list that associates a + metavariable i with its body. + A metaenv is a (int * Cic.term) list that associate a metavariable + i with is type. + fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back + a new substitution which is _NOT_ unwinded. It must be unwinded before + applying it. *) + +and fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph = + let module C = Cic in + let module R = CicReduction in + let module S = CicSubstitution in + let t1 = deref subst t1 in + let t2 = deref subst t2 in + let b,ugraph = +let foo () = + R.are_convertible ~subst ~metasenv context t1 t2 ugraph +in profiler_are_convertible.HExtlib.profile foo () + in + if b then + subst, metasenv, ugraph + else + match (t1, t2) with + | (C.Meta (n,ln), C.Meta (m,lm)) when n=m -> + let _,subst,metasenv,ugraph1 = + (try + List.fold_left2 + (fun (j,subst,metasenv,ugraph) t1 t2 -> + match t1,t2 with + None,_ + | _,None -> j+1,subst,metasenv,ugraph + | Some t1', Some t2' -> + (* First possibility: restriction *) + (* Second possibility: unification *) + (* Third possibility: convertibility *) + let b, ugraph1 = + R.are_convertible + ~subst ~metasenv context t1' t2' ugraph + in + if b then + j+1,subst,metasenv, ugraph1 + else + (try + let subst,metasenv,ugraph2 = + fo_unif_subst + test_equality_only + subst context metasenv t1' t2' ugraph + in + j+1,subst,metasenv,ugraph2 + with + Uncertain _ + | UnificationFailure _ -> +debug_print (lazy ("restringo Meta n." ^ (string_of_int n) ^ "on variable n." ^ (string_of_int j))); + let metasenv, subst = + CicMetaSubst.restrict + subst [(n,j)] metasenv in + j+1,subst,metasenv,ugraph1) + ) (1,subst,metasenv,ugraph) ln lm + with + Exit -> + raise + (UnificationFailure (lazy "1")) + (* + (sprintf + "Error trying to unify %s with %s: the algorithm tried to check whether the two substitutions are convertible; if they are not, it tried to unify the two substitutions. No restriction was attempted." + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2))) *) + | Invalid_argument _ -> + raise + (UnificationFailure (lazy "2"))) + (* + (sprintf + "Error trying to unify %s with %s: the lengths of the two local contexts do not match." + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2)))) *) + in subst,metasenv,ugraph1 + | (C.Meta (n,_), C.Meta (m,_)) when n>m -> + fo_unif_subst test_equality_only subst context metasenv t2 t1 ugraph + | (C.Meta (n,l), t) + | (t, C.Meta (n,l)) -> + let swap = + match t1,t2 with + C.Meta (n,_), C.Meta (m,_) when n < m -> false + | _, C.Meta _ -> false + | _,_ -> true + in + let lower = fun x y -> if swap then y else x in + let upper = fun x y -> if swap then x else y in + let fo_unif_subst_ordered + test_equality_only subst context metasenv m1 m2 ugraph = + fo_unif_subst test_equality_only subst context metasenv + (lower m1 m2) (upper m1 m2) ugraph + in + begin + let subst,metasenv,ugraph1 = + let (_,_,meta_type) = CicUtil.lookup_meta n metasenv in + (try + let tyt,ugraph1 = + type_of_aux' metasenv subst context t ugraph + in + fo_unif_subst + test_equality_only + subst context metasenv tyt (S.subst_meta l meta_type) ugraph1 + with + UnificationFailure _ as e -> raise e + | Uncertain msg -> raise (UnificationFailure msg) + | AssertFailure _ -> + debug_print (lazy "siamo allo huge hack"); + (* TODO huge hack!!!! + * we keep on unifying/refining in the hope that + * the problem will be eventually solved. + * In the meantime we're breaking a big invariant: + * the terms that we are unifying are no longer well + * typed in the current context (in the worst case + * we could even diverge) *) + (subst, metasenv,ugraph)) in + let t',metasenv,subst = + try + CicMetaSubst.delift n subst context metasenv l t + with + (CicMetaSubst.MetaSubstFailure msg)-> + raise (UnificationFailure msg) + | (CicMetaSubst.Uncertain msg) -> raise (Uncertain msg) + in + let t'',ugraph2 = + match t' with + C.Sort (C.Type u) when not test_equality_only -> + let u' = CicUniv.fresh () in + let s = C.Sort (C.Type u') in + let ugraph2 = + CicUniv.add_ge (upper u u') (lower u u') ugraph1 + in + s,ugraph2 + | _ -> t',ugraph1 + in + (* Unifying the types may have already instantiated n. Let's check *) + try + let (_, oldt,_) = CicUtil.lookup_subst n subst in + let lifted_oldt = S.subst_meta l oldt in + fo_unif_subst_ordered + test_equality_only subst context metasenv t lifted_oldt ugraph2 + with + CicUtil.Subst_not_found _ -> + let (_, context, ty) = CicUtil.lookup_meta n metasenv in + let subst = (n, (context, t'',ty)) :: subst in + let metasenv = + List.filter (fun (m,_,_) -> not (n = m)) metasenv in + subst, metasenv, ugraph2 + end + | (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 test_equality_only subst context metasenv + exp_named_subst1 exp_named_subst2 ugraph + else + raise (UnificationFailure (lazy + (sprintf + "Can't unify %s with %s due to different constants" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2)))) + | 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 + test_equality_only + subst context metasenv exp_named_subst1 exp_named_subst2 ugraph + else + raise (UnificationFailure (lazy "4")) + (* (sprintf + "Can't unify %s with %s due to different inductive principles" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2))) *) + | 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 + test_equality_only + subst context metasenv exp_named_subst1 exp_named_subst2 ugraph + else + raise (UnificationFailure (lazy "5")) + (* (sprintf + "Can't unify %s with %s due to different inductive constructors" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2))) *) + | (C.Implicit _, _) | (_, C.Implicit _) -> assert false + | (C.Cast (te,ty), t2) -> fo_unif_subst test_equality_only + subst context metasenv te t2 ugraph + | (t1, C.Cast (te,ty)) -> fo_unif_subst test_equality_only + subst context metasenv t1 te ugraph + | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) -> + let subst',metasenv',ugraph1 = + fo_unif_subst true subst context metasenv s1 s2 ugraph + in + fo_unif_subst test_equality_only + subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1 + | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) -> + let subst',metasenv',ugraph1 = + fo_unif_subst test_equality_only subst context metasenv s1 s2 ugraph + in + fo_unif_subst test_equality_only + subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1 + | (C.LetIn (_,s1,t1), t2) + | (t2, C.LetIn (_,s1,t1)) -> + fo_unif_subst + test_equality_only subst context metasenv t2 (S.subst s1 t1) ugraph + | (C.Appl l1, C.Appl l2) -> + (* andrea: this case should be probably rewritten in the + spirit of deref *) + (match l1,l2 with + | C.Meta (i,_)::args1, C.Meta (j,_)::args2 when i = j -> + (try + List.fold_left2 + (fun (subst,metasenv,ugraph) t1 t2 -> + fo_unif_subst + test_equality_only subst context metasenv t1 t2 ugraph) + (subst,metasenv,ugraph) l1 l2 + with (Invalid_argument msg) -> + raise (UnificationFailure (lazy msg))) + | C.Meta (i,l)::args, _ when not(exists_a_meta args) -> + (* we verify that none of the args is a Meta, + since beta expanding with respoect to a metavariable + makes no sense *) + (* + (try + let (_,t,_) = CicUtil.lookup_subst i subst in + let lifted = S.subst_meta l t in + let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in + fo_unif_subst + test_equality_only + subst context metasenv reduced t2 ugraph + with CicUtil.Subst_not_found _ -> *) + let subst,metasenv,beta_expanded,ugraph1 = + beta_expand_many + test_equality_only metasenv subst context t2 args ugraph + in + fo_unif_subst test_equality_only subst context metasenv + (C.Meta (i,l)) beta_expanded ugraph1 + | _, C.Meta (i,l)::args when not(exists_a_meta args) -> + (* (try + let (_,t,_) = CicUtil.lookup_subst i subst in + let lifted = S.subst_meta l t in + let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in + fo_unif_subst + test_equality_only + subst context metasenv t1 reduced ugraph + with CicUtil.Subst_not_found _ -> *) + let subst,metasenv,beta_expanded,ugraph1 = + beta_expand_many + test_equality_only + metasenv subst context t1 args ugraph + in + fo_unif_subst test_equality_only subst context metasenv + (C.Meta (i,l)) beta_expanded ugraph1 + | _,_ -> + let lr1 = List.rev l1 in + let lr2 = List.rev l2 in + let rec + fo_unif_l test_equality_only subst metasenv (l1,l2) ugraph = + match (l1,l2) with + [],_ + | _,[] -> assert false + | ([h1],[h2]) -> + fo_unif_subst + test_equality_only subst context metasenv h1 h2 ugraph + | ([h],l) + | (l,[h]) -> + fo_unif_subst test_equality_only subst context metasenv + h (C.Appl (List.rev l)) ugraph + | ((h1::l1),(h2::l2)) -> + let subst', metasenv',ugraph1 = + fo_unif_subst + test_equality_only + subst context metasenv h1 h2 ugraph + in + fo_unif_l + test_equality_only subst' metasenv' (l1,l2) ugraph1 + in + (try + fo_unif_l + test_equality_only subst metasenv (lr1, lr2) ugraph + with + | UnificationFailure _ + | Uncertain _ as exn -> + (match l1, l2 with + | (((Cic.Const (uri1, ens1)) as c1) :: tl1), + (((Cic.Const (uri2, ens2)) as c2) :: tl2) when + CoercGraph.is_a_coercion c1 && + CoercGraph.is_a_coercion c2 -> + let body1, attrs1, ugraph = + match CicEnvironment.get_obj ugraph uri1 with + | Cic.Constant (_,Some bo, _, _, attrs),u -> bo,attrs,u + | _ -> assert false + in + let body2, attrs2, ugraph = + match CicEnvironment.get_obj ugraph uri2 with + | Cic.Constant (_,Some bo, _, _, attrs),u -> bo, attrs,u + | _ -> assert false + in + let is_composite1 = + List.exists ((=) (`Class `Coercion)) attrs1 in + let is_composite2 = + List.exists ((=) (`Class `Coercion)) attrs2 in + (match is_composite1, is_composite2 with + | false, false -> raise exn + | true, false -> + let body1 = CicSubstitution.subst_vars ens1 body1 in + let appl = Cic.Appl (body1::tl1) in + let redappl = CicReduction.head_beta_reduce appl in + fo_unif_subst + test_equality_only subst context metasenv + redappl t2 ugraph + | false, true -> + let body2 = CicSubstitution.subst_vars ens2 body2 in + let appl = Cic.Appl (body2::tl2) in + let redappl = CicReduction.head_beta_reduce appl in + fo_unif_subst + test_equality_only subst context metasenv + t1 redappl ugraph + | true, true -> + let body1 = CicSubstitution.subst_vars ens1 body1 in + let appl1 = Cic.Appl (body1::tl1) in + let redappl1 = CicReduction.head_beta_reduce appl1 in + let body2 = CicSubstitution.subst_vars ens2 body2 in + let appl2 = Cic.Appl (body2::tl2) in + let redappl2 = CicReduction.head_beta_reduce appl2 in + fo_unif_subst + test_equality_only subst context metasenv + redappl1 redappl2 ugraph) + | _ -> raise exn))) + | (C.MutCase (_,_,outt1,t1',pl1), C.MutCase (_,_,outt2,t2',pl2))-> + let subst', metasenv',ugraph1 = + fo_unif_subst test_equality_only subst context metasenv outt1 outt2 + ugraph in + let subst'',metasenv'',ugraph2 = + fo_unif_subst test_equality_only subst' context metasenv' t1' t2' + ugraph1 in + (try + List.fold_left2 + (fun (subst,metasenv,ugraph) t1 t2 -> + fo_unif_subst + test_equality_only subst context metasenv t1 t2 ugraph + ) (subst'',metasenv'',ugraph2) pl1 pl2 + with + Invalid_argument _ -> + raise (UnificationFailure (lazy "6.1"))) + (* (sprintf + "Error trying to unify %s with %s: the number of branches is not the same." + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2)))) *) + | (C.Rel _, _) | (_, C.Rel _) -> + if t1 = t2 then + subst, metasenv,ugraph + else + raise (UnificationFailure (lazy + (sprintf + "Can't unify %s with %s because they are not convertible" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2)))) + | (C.Appl (C.Meta(i,l)::args),t2) when not(exists_a_meta args) -> + let subst,metasenv,beta_expanded,ugraph1 = + beta_expand_many + test_equality_only metasenv subst context t2 args ugraph + in + fo_unif_subst test_equality_only subst context metasenv + (C.Meta (i,l)) beta_expanded ugraph1 + | (t1,C.Appl (C.Meta(i,l)::args)) when not(exists_a_meta args) -> + let subst,metasenv,beta_expanded,ugraph1 = + beta_expand_many + test_equality_only metasenv subst context t1 args ugraph + in + fo_unif_subst test_equality_only subst context metasenv + beta_expanded (C.Meta (i,l)) ugraph1 + | (C.Sort _ ,_) | (_, C.Sort _) + | (C.Const _, _) | (_, C.Const _) + | (C.MutInd _, _) | (_, C.MutInd _) + | (C.MutConstruct _, _) | (_, C.MutConstruct _) + | (C.Fix _, _) | (_, C.Fix _) + | (C.CoFix _, _) | (_, C.CoFix _) -> + if t1 = t2 then + subst, metasenv, ugraph + else + let b,ugraph1 = + R.are_convertible ~subst ~metasenv context t1 t2 ugraph + in + if b then + subst, metasenv, ugraph1 + else + raise + (UnificationFailure (lazy (sprintf + "Can't unify %s with %s because they are not convertible" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2)))) + | (C.Prod _, t2) -> + let t2' = R.whd ~subst context t2 in + (match t2' with + C.Prod _ -> + fo_unif_subst test_equality_only + subst context metasenv t1 t2' ugraph + | _ -> raise (UnificationFailure (lazy "8"))) + | (t1, C.Prod _) -> + let t1' = R.whd ~subst context t1 in + (match t1' with + C.Prod _ -> + fo_unif_subst test_equality_only + subst context metasenv t1' t2 ugraph + | _ -> (* raise (UnificationFailure "9")) *) + raise + (UnificationFailure (lazy (sprintf + "Can't unify %s with %s because they are not convertible" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2))))) + | (_,_) -> + raise (UnificationFailure (lazy "10")) + (* (sprintf + "Can't unify %s with %s because they are not convertible" + (CicMetaSubst.ppterm subst t1) + (CicMetaSubst.ppterm subst t2))) *) + +and fo_unif_subst_exp_named_subst test_equality_only subst context metasenv + exp_named_subst1 exp_named_subst2 ugraph += + try + List.fold_left2 + (fun (subst,metasenv,ugraph) (uri1,t1) (uri2,t2) -> + assert (uri1=uri2) ; + fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph + ) (subst,metasenv,ugraph) exp_named_subst1 exp_named_subst2 + with + Invalid_argument _ -> + let print_ens ens = + String.concat " ; " + (List.map + (fun (uri,t) -> + UriManager.string_of_uri uri ^ " := " ^ (CicMetaSubst.ppterm subst t) + ) ens) + in + raise (UnificationFailure (lazy (sprintf + "Error trying to unify the two explicit named substitutions (local contexts) %s and %s: their lengths is different." (print_ens exp_named_subst1) (print_ens exp_named_subst2)))) + +(* A substitution is a (int * Cic.term) list that associates a *) +(* metavariable i with its body. *) +(* metasenv is of type Cic.metasenv *) +(* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back *) +(* a new substitution which is already unwinded and ready to be applied and *) +(* a new metasenv in which some hypothesis in the contexts of the *) +(* metavariables may have been restricted. *) +let fo_unif metasenv context t1 t2 ugraph = + fo_unif_subst false [] context metasenv t1 t2 ugraph ;; + +let enrich_msg msg subst context metasenv t1 t2 ugraph = + lazy ( + if verbose then + sprintf "[Verbose] Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nand substitution\n%s\nbecause %s" + (CicMetaSubst.ppterm subst t1) + (try + let ty_t1,_ = type_of_aux' metasenv subst context t1 ugraph in + CicPp.ppterm ty_t1 + with + | UnificationFailure s + | Uncertain s + | AssertFailure s -> sprintf "MALFORMED(t1): \n%s\n" (Lazy.force s)) + (CicMetaSubst.ppterm subst t2) + (try + let ty_t2,_ = type_of_aux' metasenv subst context t2 ugraph in + CicPp.ppterm ty_t2 + with + | UnificationFailure s + | Uncertain s + | AssertFailure s -> sprintf "MALFORMED(t2): \n%s\n" (Lazy.force s)) + (CicMetaSubst.ppcontext subst context) + (CicMetaSubst.ppmetasenv subst metasenv) + (CicMetaSubst.ppsubst subst) (Lazy.force msg) + else + sprintf "Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nbecause %s" + (CicMetaSubst.ppterm_in_context subst t1 context) + (try + let ty_t1,_ = type_of_aux' metasenv subst context t1 ugraph in + CicMetaSubst.ppterm_in_context subst ty_t1 context + with + | UnificationFailure s + | Uncertain s + | AssertFailure s -> sprintf "MALFORMED(t1): \n%s\n" (Lazy.force s)) + (CicMetaSubst.ppterm_in_context subst t2 context) + (try + let ty_t2,_ = type_of_aux' metasenv subst context t2 ugraph in + CicMetaSubst.ppterm_in_context subst ty_t2 context + with + | UnificationFailure s + | Uncertain s + | AssertFailure s -> sprintf "MALFORMED(t2): \n%s\n" (Lazy.force s)) + (CicMetaSubst.ppcontext subst context) + (CicMetaSubst.ppmetasenv subst metasenv) + (Lazy.force msg) + ) + +let fo_unif_subst subst context metasenv t1 t2 ugraph = + try + fo_unif_subst false subst context metasenv t1 t2 ugraph + with + | AssertFailure msg -> + raise (AssertFailure (enrich_msg msg subst context metasenv t1 t2 ugraph)) + | UnificationFailure msg -> + raise (UnificationFailure (enrich_msg msg subst context metasenv t1 t2 ugraph)) +;; diff --git a/helm/software/components/cic_unification/cicUnification.mli b/helm/software/components/cic_unification/cicUnification.mli new file mode 100644 index 000000000..e1a6c2899 --- /dev/null +++ b/helm/software/components/cic_unification/cicUnification.mli @@ -0,0 +1,58 @@ +(* 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 UnificationFailure of string Lazy.t;; +exception Uncertain of string Lazy.t;; +exception AssertFailure of string Lazy.t;; + +(* fo_unif metasenv context t1 t2 *) +(* 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 -> CicUniv.universe_graph -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph + +(* 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 : + Cic.substitution -> Cic.context -> Cic.metasenv -> + Cic.term -> Cic.term -> CicUniv.universe_graph -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph + diff --git a/helm/software/components/content_pres/.depend b/helm/software/components/content_pres/.depend new file mode 100644 index 000000000..60e25ecd8 --- /dev/null +++ b/helm/software/components/content_pres/.depend @@ -0,0 +1,36 @@ +cicNotationPres.cmi: mpresentation.cmi box.cmi +boxPp.cmi: cicNotationPres.cmi +content2pres.cmi: cicNotationPres.cmi +sequent2pres.cmi: cicNotationPres.cmi +renderingAttrs.cmo: renderingAttrs.cmi +renderingAttrs.cmx: renderingAttrs.cmi +cicNotationLexer.cmo: cicNotationLexer.cmi +cicNotationLexer.cmx: cicNotationLexer.cmi +cicNotationParser.cmo: cicNotationLexer.cmi cicNotationParser.cmi +cicNotationParser.cmx: cicNotationLexer.cmx cicNotationParser.cmi +mpresentation.cmo: mpresentation.cmi +mpresentation.cmx: mpresentation.cmi +box.cmo: renderingAttrs.cmi box.cmi +box.cmx: renderingAttrs.cmx box.cmi +content2presMatcher.cmo: content2presMatcher.cmi +content2presMatcher.cmx: content2presMatcher.cmi +termContentPres.cmo: renderingAttrs.cmi content2presMatcher.cmi \ + termContentPres.cmi +termContentPres.cmx: renderingAttrs.cmx content2presMatcher.cmx \ + termContentPres.cmi +cicNotationPres.cmo: renderingAttrs.cmi mpresentation.cmi box.cmi \ + cicNotationPres.cmi +cicNotationPres.cmx: renderingAttrs.cmx mpresentation.cmx box.cmx \ + cicNotationPres.cmi +boxPp.cmo: renderingAttrs.cmi mpresentation.cmi cicNotationPres.cmi box.cmi \ + boxPp.cmi +boxPp.cmx: renderingAttrs.cmx mpresentation.cmx cicNotationPres.cmx box.cmx \ + boxPp.cmi +content2pres.cmo: termContentPres.cmi renderingAttrs.cmi mpresentation.cmi \ + cicNotationPres.cmi box.cmi content2pres.cmi +content2pres.cmx: termContentPres.cmx renderingAttrs.cmx mpresentation.cmx \ + cicNotationPres.cmx box.cmx content2pres.cmi +sequent2pres.cmo: termContentPres.cmi mpresentation.cmi cicNotationPres.cmi \ + box.cmi sequent2pres.cmi +sequent2pres.cmx: termContentPres.cmx mpresentation.cmx cicNotationPres.cmx \ + box.cmx sequent2pres.cmi diff --git a/helm/software/components/content_pres/Makefile b/helm/software/components/content_pres/Makefile new file mode 100644 index 000000000..0cd8b4226 --- /dev/null +++ b/helm/software/components/content_pres/Makefile @@ -0,0 +1,60 @@ +PACKAGE = content_pres +PREDICATES = + +INTERFACE_FILES = \ + renderingAttrs.mli \ + cicNotationLexer.mli \ + cicNotationParser.mli \ + mpresentation.mli \ + box.mli \ + content2presMatcher.mli \ + termContentPres.mli \ + cicNotationPres.mli \ + boxPp.mli \ + content2pres.mli \ + sequent2pres.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) + +cicNotationPres.cmi: OCAMLOPTIONS += -rectypes +cicNotationPres.cmo: OCAMLOPTIONS += -rectypes +cicNotationPres.cmx: OCAMLOPTIONS += -rectypes + +all: test_lexer +clean: clean_tests + +LOCAL_LINKOPTS = -package helm-content_pres -linkpkg +test: test_lexer +test_lexer: test_lexer.ml $(PACKAGE).cma + @echo " OCAMLC $<" + @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< + +clean_tests: + rm -f test_lexer{,.opt} + +cicNotationLexer.cmo: OCAMLC = $(OCAMLC_P4) +cicNotationParser.cmo: OCAMLC = $(OCAMLC_P4) +cicNotationLexer.cmx: OCAMLOPT = $(OCAMLOPT_P4) +cicNotationParser.cmx: OCAMLOPT = $(OCAMLOPT_P4) +cicNotationLexer.ml.annot: OCAMLC = $(OCAMLC_P4) +cicNotationParser.ml.annot: OCAMLC = $(OCAMLC_P4) + +include ../../Makefile.defs +include ../Makefile.common + +# cross compatibility among ocaml 3.09 and ocaml 3.08, to be removed as +# soon as we have ocaml 3.09 everywhere and "loc" occurrences are replaced by +# "_loc" occurrences +UTF8DIR := $(shell $(OCAMLFIND) query helm-utf8_macros) +ULEXDIR := $(shell $(OCAMLFIND) query ulex) +MY_SYNTAXOPTIONS = -pp "camlp4o -I $(UTF8DIR) -I $(ULEXDIR) pa_extend.cmo pa_ulex.cma pa_unicode_macro.cma -loc loc" +cicNotationLexer.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +cicNotationParser.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +cicNotationLexer.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +cicNotationParser.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +cicNotationLexer.ml.annot: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +cicNotationParser.ml.annot: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +depend: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +# + diff --git a/helm/software/components/content_pres/box.ml b/helm/software/components/content_pres/box.ml new file mode 100644 index 000000000..7c5069262 --- /dev/null +++ b/helm/software/components/content_pres/box.ml @@ -0,0 +1,153 @@ +(* Copyright (C) 2000-2005, 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 *) +(* *) +(* Andrea Asperti *) +(* 13/2/2004 *) +(* *) +(*************************************************************************) + +(* $Id$ *) + +type + 'expr box = + Text of attr * string + | Space of attr + | Ink of attr + | H of attr * ('expr box) list + | V of attr * ('expr box) list + | HV of attr * ('expr box) list + | HOV of attr * ('expr box) list + | Object of attr * 'expr + | Action of attr * ('expr box) list + +and attr = (string option * string * string) list + +let smallskip = Space([None,"width","0.5em"]);; +let skip = Space([None,"width","1em"]);; + +let indent t = H([],[skip;t]);; + +(* BoxML prefix *) +let prefix = "b";; + +let tag_of_box = function + | H _ -> "h" + | V _ -> "v" + | HV _ -> "hv" + | HOV _ -> "hov" + | _ -> assert false + +let box2xml ~obj2xml box = + let rec aux = + let module X = Xml in + function + Text (attr,s) -> X.xml_nempty ~prefix "text" attr (X.xml_cdata s) + | Space attr -> X.xml_empty ~prefix "space" attr + | Ink attr -> X.xml_empty ~prefix "ink" attr + | H (attr,l) + | V (attr,l) + | HV (attr,l) + | HOV (attr,l) as box -> + X.xml_nempty ~prefix (tag_of_box box) attr + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) + >] + | Object (attr,m) -> + X.xml_nempty ~prefix "obj" attr [< obj2xml m >] + | Action (attr,l) -> + X.xml_nempty ~prefix "action" attr + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >] + in + aux box +;; + +let rec map f = function + | (Text _) as box -> box + | (Space _) as box -> box + | (Ink _) as box -> box + | H (attr, l) -> H (attr, List.map (map f) l) + | V (attr, l) -> V (attr, List.map (map f) l) + | HV (attr, l) -> HV (attr, List.map (map f) l) + | HOV (attr, l) -> HOV (attr, List.map (map f) l) + | Action (attr, l) -> Action (attr, List.map (map f) l) + | Object (attr, obj) -> Object (attr, f obj) +;; + +(* +let document_of_box ~obj2xml pres = + [< Xml.xml_cdata "\n" ; + Xml.xml_cdata "\n"; + Xml.xml_nempty ~prefix "box" + [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ; + Some "xmlns","b","http://helm.cs.unibo.it/2003/BoxML" ; + Some "xmlns","helm","http://www.cs.unibo.it/helm" ; + Some "xmlns","xlink","http://www.w3.org/1999/xlink" + ] (print_box pres) + >] +*) + +let b_h a b = H(a,b) +let b_v a b = V(a,b) +let b_hv a b = HV(a,b) +let b_hov a b = HOV(a,b) +let b_text a b = Text(a,b) +let b_object b = Object ([],b) +let b_indent = indent +let b_space = Space [None, "width", "0.5em"] +let b_kw = b_text (RenderingAttrs.object_keyword_attributes `BoxML) +let b_toggle items = Action ([ None, "type", "toggle"], items) + +let pp_attr attr = + let pp (ns, n, v) = + Printf.sprintf "%s%s=%s" (match ns with None -> "" | Some s -> s ^ ":") n v + in + String.concat " " (List.map pp attr) + +let get_attr = function + | Text (attr, _) + | Space attr + | Ink attr + | H (attr, _) + | V (attr, _) + | HV (attr, _) + | HOV (attr, _) + | Object (attr, _) + | Action (attr, _) -> + attr + +let set_attr attr = function + | Text (_, x) -> Text (attr, x) + | Space _ -> Space attr + | Ink _ -> Ink attr + | H (_, x) -> H (attr, x) + | V (_, x) -> V (attr, x) + | HV (_, x) -> HV (attr, x) + | HOV (_, x) -> HOV (attr, x) + | Object (_, x) -> Object (attr, x) + | Action (_, x) -> Action (attr, x) + diff --git a/helm/software/components/content_pres/box.mli b/helm/software/components/content_pres/box.mli new file mode 100644 index 000000000..d2ca17bdd --- /dev/null +++ b/helm/software/components/content_pres/box.mli @@ -0,0 +1,79 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 13/2/2004 *) +(* *) +(*************************************************************************) + +type + 'expr box = + Text of attr * string + | Space of attr + | Ink of attr + | H of attr * ('expr box) list + | V of attr * ('expr box) list + | HV of attr * ('expr box) list + | HOV of attr * ('expr box) list + | Object of attr * 'expr + | Action of attr * ('expr box) list + +and attr = (string option * string * string) list + +val get_attr: 'a box -> attr +val set_attr: attr -> 'a box -> 'a box + +val smallskip : 'expr box +val skip: 'expr box +val indent : 'expr box -> 'expr box + +val box2xml: + obj2xml:('a -> Xml.token Stream.t) -> 'a box -> + Xml.token Stream.t + +val map: ('a -> 'b) -> 'a box -> 'b box + +(* +val document_of_box : + ~obj2xml:('a -> Xml.token Stream.t) -> 'a box -> Xml.token Stream.t +*) + +val b_h: attr -> 'expr box list -> 'expr box +val b_v: attr -> 'expr box list -> 'expr box +val b_hv: attr -> 'expr box list -> 'expr box (** default indent and spacing *) +val b_hov: attr -> 'expr box list -> 'expr box (** default indent and spacing *) +val b_text: attr -> string -> 'expr box +val b_object: 'expr -> 'expr box +val b_indent: 'expr box -> 'expr box +val b_space: 'expr box +val b_kw: string -> 'expr box +val b_toggle: 'expr box list -> 'expr box (** action which toggle among items *) + +val pp_attr: attr -> string + diff --git a/helm/software/components/content_pres/boxPp.ml b/helm/software/components/content_pres/boxPp.ml new file mode 100644 index 000000000..7a2fa9912 --- /dev/null +++ b/helm/software/components/content_pres/boxPp.ml @@ -0,0 +1,241 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +module Pres = Mpresentation + +(** {2 Pretty printing from BoxML to strings} *) + +let string_space = " " +let string_space_len = String.length string_space +let string_indent = string_space +let string_indent_len = String.length string_indent +let string_ink = "##" +let string_ink_len = String.length string_ink + +let contains_attrs contained container = + List.for_all (fun attr -> List.mem attr container) contained + +let want_indent = contains_attrs (RenderingAttrs.indent_attributes `BoxML) +let want_spacing = contains_attrs (RenderingAttrs.spacing_attributes `BoxML) + +let indent_string s = string_indent ^ s +let indent_children (size, children) = + let children' = List.map indent_string children in + size + string_space_len, children' + +let choose_rendering size (best, other) = + let best_size, _ = best in + if size >= best_size then best else other + +let merge_columns sep cols = + let sep_len = String.length sep in + let indent = ref 0 in + let res_rows = ref [] in + let add_row ~continue row = + match !res_rows with + | last :: prev when continue -> + res_rows := (String.concat sep [last; row]) :: prev; + indent := !indent + String.length last + sep_len + | _ -> res_rows := (String.make !indent ' ' ^ row) :: !res_rows; + in + List.iter + (fun rows -> + match rows with + | hd :: tl -> + add_row ~continue:true hd; + List.iter (add_row ~continue:false) tl + | [] -> ()) + cols; + List.rev !res_rows + +let max_len = + List.fold_left (fun max_size s -> max (String.length s) max_size) 0 + +let render_row available_space spacing children = + let spacing_bonus = if spacing then string_space_len else 0 in + let rem_space = ref available_space in + let renderings = ref [] in + List.iter + (fun f -> + let occupied_space, rendering = f !rem_space in + renderings := rendering :: !renderings; + rem_space := !rem_space - (occupied_space + spacing_bonus)) + children; + let sep = if spacing then string_space else "" in + let rendering = merge_columns sep (List.rev !renderings) in + max_len rendering, rendering + +let fixed_rendering s = + let s_len = String.length s in + (fun _ -> s_len, [s]) + +let render_to_strings size markup = + let max_size = max_int in + let rec aux_box = + function + | Box.Text (_, t) -> fixed_rendering t + | Box.Space _ -> fixed_rendering string_space + | Box.Ink _ -> fixed_rendering string_ink + | Box.Action (_, []) -> assert false + | Box.Action (_, hd :: _) -> aux_box hd + | Box.Object (_, o) -> aux_mpres o + | Box.H (attrs, children) -> + let spacing = want_spacing attrs in + let children' = List.map aux_box children in + (fun size -> render_row size spacing children') + | Box.HV (attrs, children) -> + let spacing = want_spacing attrs in + let children' = List.map aux_box children in + (fun size -> + let (size', renderings) as res = + render_row max_size spacing children' + in + if size' <= size then (* children fit in a row *) + res + else (* break needed, re-render using a Box.V *) + aux_box (Box.V (attrs, children)) size) + | Box.V (attrs, []) -> assert false + | Box.V (attrs, [child]) -> aux_box child + | Box.V (attrs, hd :: tl) -> + let indent = want_indent attrs in + let hd_f = aux_box hd in + let tl_fs = List.map aux_box tl in + (fun size -> + let _, hd_rendering = hd_f size in + let children_size = + max 0 (if indent then size - string_indent_len else size) + in + let tl_renderings = + List.map + (fun f -> +(* let indent_header = if indent then string_indent else "" in *) + snd (indent_children (f children_size))) + tl_fs + in + let rows = hd_rendering @ List.concat tl_renderings in + max_len rows, rows) + | Box.HOV (attrs, []) -> assert false + | Box.HOV (attrs, [child]) -> aux_box child + | Box.HOV (attrs, children) -> + let spacing = want_spacing attrs in + let indent = want_indent attrs in + let spacing_bonus = if spacing then string_space_len else 0 in + let indent_bonus = if indent then string_indent_len else 0 in + let sep = if spacing then string_space else "" in + let fs = List.map aux_box children in + (fun size -> + let rows = ref [] in + let renderings = ref [] in + let rem_space = ref size in + let first_row = ref true in + let use_rendering (space, rendering) = + let use_indent = !renderings = [] && not !first_row in + let rendering' = + if use_indent then List.map indent_string rendering + else rendering + in + renderings := rendering' :: !renderings; + let bonus = if use_indent then indent_bonus else spacing_bonus in + rem_space := !rem_space - (space + bonus) + in + let end_cluster () = + let new_rows = merge_columns sep (List.rev !renderings) in + rows := List.rev_append new_rows !rows; + rem_space := size - indent_bonus; + renderings := []; + first_row := false + in + List.iter + (fun f -> + let (best_space, _) as best = f max_size in + if best_space <= !rem_space then + use_rendering best + else begin + end_cluster (); + if best_space <= !rem_space then use_rendering best + else use_rendering (f size) + end) + fs; + if !renderings <> [] then end_cluster (); + max_len !rows, List.rev !rows) + and aux_mpres = + let text s = Pres.Mtext ([], s) in + let mrow c = Pres.Mrow ([], c) in + function + | Pres.Mi (_, s) + | Pres.Mn (_, s) + | Pres.Mtext (_, s) + | Pres.Ms (_, s) + | Pres.Mgliph (_, s) -> fixed_rendering s + | Pres.Mo (_, s) -> + let s = + if String.length s > 1 then + (* heuristic to guess which operators need to be expanded in their + * TeX like format *) + Utf8Macro.tex_of_unicode s ^ " " + else s + in + fixed_rendering s + | Pres.Mspace _ -> fixed_rendering string_space + | Pres.Mrow (attrs, children) -> + let children' = List.map aux_mpres children in + (fun size -> render_row size false children') + | Pres.Mfrac (_, m, n) -> + aux_mpres (mrow [ text "\\frac("; text ")"; text "("; n; text ")" ]) + | Pres.Msqrt (_, m) -> aux_mpres (mrow [ text "\\sqrt("; m; text ")" ]) + | Pres.Mroot (_, r, i) -> + aux_mpres (mrow [ + text "\\root("; i; text ")"; text "\\of("; r; text ")" ]) + | Pres.Mstyle (_, m) + | Pres.Merror (_, m) + | Pres.Mpadded (_, m) + | Pres.Mphantom (_, m) + | Pres.Menclose (_, m) -> aux_mpres m + | Pres.Mfenced (_, children) -> aux_mpres (mrow children) + | Pres.Maction (_, []) -> assert false + | Pres.Msub (_, m, n) -> + aux_mpres (mrow [ text "("; m; text ")\\sub("; n; text ")" ]) + | Pres.Msup (_, m, n) -> + aux_mpres (mrow [ text "("; m; text ")\\sup("; n; text ")" ]) + | Pres.Munder (_, m, n) -> + aux_mpres (mrow [ text "("; m; text ")\\below("; n; text ")" ]) + | Pres.Mover (_, m, n) -> + aux_mpres (mrow [ text "("; m; text ")\\above("; n; text ")" ]) + | Pres.Msubsup _ + | Pres.Munderover _ + | Pres.Mtable _ -> + prerr_endline + "MathML presentation element not yet available in concrete syntax"; + assert false + | Pres.Maction (_, hd :: _) -> aux_mpres hd + | Pres.Mobject (_, o) -> aux_box (o: CicNotationPres.boxml_markup) + in + snd (aux_mpres markup size) + +let render_to_string size markup = + String.concat "\n" (render_to_strings size markup) + diff --git a/helm/software/components/content_pres/boxPp.mli b/helm/software/components/content_pres/boxPp.mli new file mode 100644 index 000000000..6b7c3cec8 --- /dev/null +++ b/helm/software/components/content_pres/boxPp.mli @@ -0,0 +1,33 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + + (** @return rows list of rows *) +val render_to_strings: int -> CicNotationPres.markup -> string list + + (** helper function + * @return s, concatenation of the return value of render_to_strings above + * with newlines as separators *) +val render_to_string: int -> CicNotationPres.markup -> string + diff --git a/helm/software/components/content_pres/cicNotationLexer.ml b/helm/software/components/content_pres/cicNotationLexer.ml new file mode 100644 index 000000000..8848a3ce5 --- /dev/null +++ b/helm/software/components/content_pres/cicNotationLexer.ml @@ -0,0 +1,353 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +exception Error of int * int * string + +let regexp number = xml_digit+ + + (* ZACK: breaks unicode's binder followed by an ascii letter without blank *) +(* let regexp ident_letter = xml_letter *) + +let regexp ident_letter = [ 'a' - 'z' 'A' - 'Z' ] + + (* must be in sync with "is_ligature_char" below *) +let regexp ligature_char = [ "'`~!?@*()[]<>-+=|:;.,/\"" ] +let regexp ligature = ligature_char ligature_char+ + +let is_ligature_char = + (* must be in sync with "regexp ligature_char" above *) + let chars = "'`~!?@*()[]<>-+=|:;.,/\"" in + (fun char -> + (try + ignore (String.index chars char); + true + with Not_found -> false)) + +let regexp ident_decoration = '\'' | '?' | '`' +let regexp ident_cont = ident_letter | xml_digit | '_' +let regexp ident = ident_letter ident_cont* ident_decoration* + +let regexp tex_token = '\\' ident + +let regexp delim_begin = "\\[" +let regexp delim_end = "\\]" + +let regexp qkeyword = "'" ident "'" + +let regexp implicit = '?' +let regexp placeholder = '%' +let regexp meta = implicit number + +let regexp csymbol = '\'' ident + +let regexp begin_group = "@{" | "${" +let regexp end_group = '}' +let regexp wildcard = "$_" +let regexp ast_ident = "@" ident +let regexp ast_csymbol = "@" csymbol +let regexp meta_ident = "$" ident +let regexp meta_anonymous = "$_" +let regexp qstring = '"' [^ '"']* '"' + +let regexp begincomment = "(**" xml_blank +let regexp beginnote = "(*" +let regexp endcomment = "*)" +(* let regexp comment_char = [^'*'] | '*'[^')'] +let regexp note = "|+" ([^'*'] | "**") comment_char* "+|" *) + +let level1_layouts = + [ "sub"; "sup"; + "below"; "above"; + "over"; "atop"; "frac"; + "sqrt"; "root" + ] + +let level1_keywords = + [ "hbox"; "hvbox"; "hovbox"; "vbox"; + "break"; + "list0"; "list1"; "sep"; + "opt"; + "term"; "ident"; "number" + ] @ level1_layouts + +let level2_meta_keywords = + [ "if"; "then"; "else"; + "fold"; "left"; "right"; "rec"; + "fail"; + "default"; + "anonymous"; "ident"; "number"; "term"; "fresh" + ] + + (* (string, unit) Hashtbl.t, to exploit multiple bindings *) +let level2_ast_keywords = Hashtbl.create 23 +let _ = + List.iter (fun k -> Hashtbl.add level2_ast_keywords k ()) + [ "CProp"; "Prop"; "Type"; "Set"; "let"; "rec"; "corec"; "match"; + "with"; "in"; "and"; "to"; "as"; "on"; "return" ] + +let add_level2_ast_keyword k = Hashtbl.add level2_ast_keywords k () +let remove_level2_ast_keyword k = Hashtbl.remove level2_ast_keywords k + + (* (string, int) Hashtbl.t, with multiple bindings. + * int is the unicode codepoint *) +let ligatures = Hashtbl.create 23 +let _ = + List.iter + (fun (ligature, symbol) -> Hashtbl.add ligatures ligature symbol) + [ ("->", <:unicode>); ("=>", <:unicode>); + ("<=", <:unicode>); (">=", <:unicode>); + ("<>", <:unicode>); (":=", <:unicode>); + ] + +let regexp uri_step = [ 'a' - 'z' 'A' - 'Z' '0' - '9' '_' '-' ]+ + +let regexp uri = + ("cic:/" | "theory:/") (* schema *) +(* ident ('/' ident)* |+ path +| *) + uri_step ('/' uri_step)* (* path *) + ('.' ident)+ (* ext *) + ("#xpointer(" number ('/' number)+ ")")? (* xpointer *) + +let error lexbuf msg = + let begin_cnum, end_cnum = Ulexing.loc lexbuf in + raise (Error (begin_cnum, end_cnum, msg)) +let error_at_end lexbuf msg = + let begin_cnum, end_cnum = Ulexing.loc lexbuf in + raise (Error (begin_cnum, end_cnum, msg)) + +let return_with_loc token begin_cnum end_cnum = + (* TODO handle line/column numbers *) + let flocation_begin = + { Lexing.pos_fname = ""; + Lexing.pos_lnum = -1; Lexing.pos_bol = -1; + Lexing.pos_cnum = begin_cnum } + in + let flocation_end = { flocation_begin with Lexing.pos_cnum = end_cnum } in + (token, (flocation_begin, flocation_end)) + +let return lexbuf token = + let begin_cnum, end_cnum = Ulexing.loc lexbuf in + return_with_loc token begin_cnum end_cnum + +let return_lexeme lexbuf name = return lexbuf (name, Ulexing.utf8_lexeme lexbuf) + +let return_symbol lexbuf s = return lexbuf ("SYMBOL", s) +let return_eoi lexbuf = return lexbuf ("EOI", "") + +let remove_quotes s = String.sub s 1 (String.length s - 2) + +let mk_lexer token = + let tok_func stream = +(* let lexbuf = Ulexing.from_utf8_stream stream in *) +(** XXX Obj.magic rationale. + * The problem. + * camlp4 constraints the tok_func field of Token.glexer to have type: + * Stream.t char -> (Stream.t 'te * flocation_function) + * In order to use ulex we have (in theory) to instantiate a new lexbuf each + * time a char Stream.t is passed, destroying the previous lexbuf which may + * have consumed a character from the old stream which is lost forever :-( + * The "solution". + * Instead of passing to camlp4 a char Stream.t we pass a lexbuf, casting it to + * char Stream.t with Obj.magic where needed. + *) + let lexbuf = Obj.magic stream in + Token.make_stream_and_flocation + (fun () -> + try + token lexbuf + with + | Ulexing.Error -> error_at_end lexbuf "Unexpected character" + | Ulexing.InvalidCodepoint p -> + error_at_end lexbuf (sprintf "Invalid code point: %d" p)) + in + { + Token.tok_func = tok_func; + Token.tok_using = (fun _ -> ()); + Token.tok_removing = (fun _ -> ()); + Token.tok_match = Token.default_match; + Token.tok_text = Token.lexer_text; + Token.tok_comm = None; + } + +let expand_macro lexbuf = + let macro = + Ulexing.utf8_sub_lexeme lexbuf 1 (Ulexing.lexeme_length lexbuf - 1) + in + try + ("SYMBOL", Utf8Macro.expand macro) + with Utf8Macro.Macro_not_found _ -> "SYMBOL", Ulexing.utf8_lexeme lexbuf + +let remove_quotes s = String.sub s 1 (String.length s - 2) +let remove_left_quote s = String.sub s 1 (String.length s - 1) + +let rec level2_pattern_token_group counter buffer = + lexer + | end_group -> + if (counter > 0) then + Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ; + snd (Ulexing.loc lexbuf) + | begin_group -> + Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ; + ignore (level2_pattern_token_group (counter + 1) buffer lexbuf) ; + level2_pattern_token_group counter buffer lexbuf + | _ -> + Buffer.add_string buffer (Ulexing.utf8_lexeme lexbuf) ; + level2_pattern_token_group counter buffer lexbuf + +let read_unparsed_group token_name lexbuf = + let buffer = Buffer.create 16 in + let begin_cnum, _ = Ulexing.loc lexbuf in + let end_cnum = level2_pattern_token_group 0 buffer lexbuf in + return_with_loc (token_name, Buffer.contents buffer) begin_cnum end_cnum + +let rec level2_meta_token = + lexer + | xml_blank+ -> level2_meta_token lexbuf + | ident -> + let s = Ulexing.utf8_lexeme lexbuf in + begin + if List.mem s level2_meta_keywords then + return lexbuf ("", s) + else + return lexbuf ("IDENT", s) + end + | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf + | ast_ident -> + return lexbuf ("UNPARSED_AST", + remove_left_quote (Ulexing.utf8_lexeme lexbuf)) + | ast_csymbol -> + return lexbuf ("UNPARSED_AST", + remove_left_quote (Ulexing.utf8_lexeme lexbuf)) + | eof -> return_eoi lexbuf + +let rec comment_token acc depth = + lexer + | beginnote -> + let acc = acc ^ Ulexing.utf8_lexeme lexbuf in + comment_token acc (depth + 1) lexbuf + | endcomment -> + let acc = acc ^ Ulexing.utf8_lexeme lexbuf in + if depth = 0 + then acc + else comment_token acc (depth - 1) lexbuf + | _ -> + let acc = acc ^ Ulexing.utf8_lexeme lexbuf in + comment_token acc depth lexbuf + + (** @param k continuation to be invoked when no ligature has been found *) +let rec ligatures_token k = + lexer + | ligature -> + let lexeme = Ulexing.utf8_lexeme lexbuf in + (match List.rev (Hashtbl.find_all ligatures lexeme) with + | [] -> (* ligature not found, rollback and try default lexer *) + Ulexing.rollback lexbuf; + k lexbuf + | default_lig :: _ -> (* ligatures found, use the default one *) + return_symbol lexbuf default_lig) + | eof -> return_eoi lexbuf + | _ -> (* not a ligature, rollback and try default lexer *) + Ulexing.rollback lexbuf; + k lexbuf + +and level2_ast_token = + lexer + | xml_blank+ -> ligatures_token level2_ast_token lexbuf + | meta -> return lexbuf ("META", Ulexing.utf8_lexeme lexbuf) + | implicit -> return lexbuf ("IMPLICIT", "") + | placeholder -> return lexbuf ("PLACEHOLDER", "") + | ident -> + let lexeme = Ulexing.utf8_lexeme lexbuf in + if Hashtbl.mem level2_ast_keywords lexeme then + return lexbuf ("", lexeme) + else + return lexbuf ("IDENT", lexeme) + | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf) + | tex_token -> return lexbuf (expand_macro lexbuf) + | uri -> return lexbuf ("URI", Ulexing.utf8_lexeme lexbuf) + | qstring -> + return lexbuf ("QSTRING", remove_quotes (Ulexing.utf8_lexeme lexbuf)) + | csymbol -> + return lexbuf ("CSYMBOL", remove_left_quote (Ulexing.utf8_lexeme lexbuf)) + | "${" -> read_unparsed_group "UNPARSED_META" lexbuf + | "@{" -> read_unparsed_group "UNPARSED_AST" lexbuf + | '(' -> return lexbuf ("LPAREN", "") + | ')' -> return lexbuf ("RPAREN", "") + | meta_ident -> + return lexbuf ("UNPARSED_META", + remove_left_quote (Ulexing.utf8_lexeme lexbuf)) + | meta_anonymous -> return lexbuf ("UNPARSED_META", "anonymous") + | beginnote -> + let _comment = comment_token (Ulexing.utf8_lexeme lexbuf) 0 lexbuf in +(* let comment = + Ulexing.utf8_sub_lexeme lexbuf 2 (Ulexing.lexeme_length lexbuf - 4) + in + return lexbuf ("NOTE", comment) *) + ligatures_token level2_ast_token lexbuf + | begincomment -> return lexbuf ("BEGINCOMMENT","") + | endcomment -> return lexbuf ("ENDCOMMENT","") + | eof -> return_eoi lexbuf + | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf) + +and level1_pattern_token = + lexer + | xml_blank+ -> ligatures_token level1_pattern_token lexbuf + | number -> return lexbuf ("NUMBER", Ulexing.utf8_lexeme lexbuf) + | ident -> + let s = Ulexing.utf8_lexeme lexbuf in + begin + if List.mem s level1_keywords then + return lexbuf ("", s) + else + return lexbuf ("IDENT", s) + end + | tex_token -> return lexbuf (expand_macro lexbuf) + | qkeyword -> + return lexbuf ("QKEYWORD", remove_quotes (Ulexing.utf8_lexeme lexbuf)) + | '(' -> return lexbuf ("LPAREN", "") + | ')' -> return lexbuf ("RPAREN", "") + | eof -> return_eoi lexbuf + | _ -> return_symbol lexbuf (Ulexing.utf8_lexeme lexbuf) + +let level1_pattern_token = ligatures_token level1_pattern_token +let level2_ast_token = ligatures_token level2_ast_token + +(* API implementation *) + +let level1_pattern_lexer = mk_lexer level1_pattern_token +let level2_ast_lexer = mk_lexer level2_ast_token +let level2_meta_lexer = mk_lexer level2_meta_token + +let lookup_ligatures lexeme = + try + if lexeme.[0] = '\\' + then [ Utf8Macro.expand (String.sub lexeme 1 (String.length lexeme - 1)) ] + else List.rev (Hashtbl.find_all ligatures lexeme) + with Invalid_argument _ | Utf8Macro.Macro_not_found _ -> [] + diff --git a/helm/software/components/content_pres/cicNotationLexer.mli b/helm/software/components/content_pres/cicNotationLexer.mli new file mode 100644 index 000000000..cd5f0876d --- /dev/null +++ b/helm/software/components/content_pres/cicNotationLexer.mli @@ -0,0 +1,48 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + + (** begin of error offset (counted in unicode codepoint) + * end of error offset (counted as above) + * error message *) +exception Error of int * int * string + + (** XXX ZACK DEFCON 4 BEGIN: never use the tok_func field of the glexers below + * passing values of type char Stream.t, they should be in fact Ulexing.lexbuf + * casted with Obj.magic :-/ Read the comment in the .ml for the rationale *) + +val level1_pattern_lexer: (string * string) Token.glexer +val level2_ast_lexer: (string * string) Token.glexer +val level2_meta_lexer: (string * string) Token.glexer + + (** XXX ZACK DEFCON 4 END *) + +val add_level2_ast_keyword: string -> unit (** non idempotent *) +val remove_level2_ast_keyword: string -> unit (** non idempotent *) + +(** {2 Ligatures} *) + +val is_ligature_char: char -> bool +val lookup_ligatures: string -> string list + diff --git a/helm/software/components/content_pres/cicNotationParser.ml b/helm/software/components/content_pres/cicNotationParser.ml new file mode 100644 index 000000000..5750ad816 --- /dev/null +++ b/helm/software/components/content_pres/cicNotationParser.ml @@ -0,0 +1,647 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt +module Env = CicNotationEnv + +exception Parse_error of string +exception Level_not_found of int + +let level1_pattern_grammar = + Grammar.gcreate CicNotationLexer.level1_pattern_lexer +let level2_ast_grammar = Grammar.gcreate CicNotationLexer.level2_ast_lexer +let level2_meta_grammar = Grammar.gcreate CicNotationLexer.level2_meta_lexer + +let min_precedence = 0 +let max_precedence = 100 + +let level1_pattern = + Grammar.Entry.create level1_pattern_grammar "level1_pattern" +let level2_ast = Grammar.Entry.create level2_ast_grammar "level2_ast" +let term = Grammar.Entry.create level2_ast_grammar "term" +let let_defs = Grammar.Entry.create level2_ast_grammar "let_defs" +let level2_meta = Grammar.Entry.create level2_meta_grammar "level2_meta" + +let int_of_string s = + try + Pervasives.int_of_string s + with Failure _ -> + failwith (sprintf "Lexer failure: string_of_int \"%s\" failed" s) + +(** {2 Grammar extension} *) + +let gram_symbol s = Gramext.Stoken ("SYMBOL", s) +let gram_ident s = Gramext.Stoken ("IDENT", s) +let gram_number s = Gramext.Stoken ("NUMBER", s) +let gram_keyword s = Gramext.Stoken ("", s) +let gram_term = Gramext.Sself + +let gram_of_literal = + function + | `Symbol s -> gram_symbol s + | `Keyword s -> gram_keyword s + | `Number s -> gram_number s + +type binding = + | NoBinding + | Binding of string * Env.value_type + | Env of (string * Env.value_type) list + +let make_action action bindings = + let rec aux (vl : CicNotationEnv.t) = + function + [] -> Gramext.action (fun (loc: Ast.location) -> action vl loc) + | NoBinding :: tl -> Gramext.action (fun _ -> aux vl tl) + (* LUCA: DEFCON 3 BEGIN *) + | Binding (name, Env.TermType) :: tl -> + Gramext.action + (fun (v:Ast.term) -> + aux ((name, (Env.TermType, Env.TermValue v))::vl) tl) + | Binding (name, Env.StringType) :: tl -> + Gramext.action + (fun (v:string) -> + aux ((name, (Env.StringType, Env.StringValue v)) :: vl) tl) + | Binding (name, Env.NumType) :: tl -> + Gramext.action + (fun (v:string) -> + aux ((name, (Env.NumType, Env.NumValue v)) :: vl) tl) + | Binding (name, Env.OptType t) :: tl -> + Gramext.action + (fun (v:'a option) -> + aux ((name, (Env.OptType t, Env.OptValue v)) :: vl) tl) + | Binding (name, Env.ListType t) :: tl -> + Gramext.action + (fun (v:'a list) -> + aux ((name, (Env.ListType t, Env.ListValue v)) :: vl) tl) + | Env _ :: tl -> + Gramext.action (fun (v:CicNotationEnv.t) -> aux (v @ vl) tl) + (* LUCA: DEFCON 3 END *) + in + aux [] (List.rev bindings) + +let flatten_opt = + let rec aux acc = + function + [] -> List.rev acc + | NoBinding :: tl -> aux acc tl + | Env names :: tl -> aux (List.rev names @ acc) tl + | Binding (name, ty) :: tl -> aux ((name, ty) :: acc) tl + in + aux [] + + (* given a level 1 pattern computes the new RHS of "term" grammar entry *) +let extract_term_production pattern = + let rec aux = function + | Ast.AttributedTerm (_, t) -> aux t + | Ast.Literal l -> aux_literal l + | Ast.Layout l -> aux_layout l + | Ast.Magic m -> aux_magic m + | Ast.Variable v -> aux_variable v + | t -> + prerr_endline (CicNotationPp.pp_term t); + assert false + and aux_literal = + function + | `Symbol s -> [NoBinding, gram_symbol s] + | `Keyword s -> + (* assumption: s will be registered as a keyword with the lexer *) + [NoBinding, gram_keyword s] + | `Number s -> [NoBinding, gram_number s] + and aux_layout = function + | Ast.Sub (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sub"] @ aux p2 + | Ast.Sup (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\sup"] @ aux p2 + | Ast.Below (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\below"] @ aux p2 + | Ast.Above (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\above"] @ aux p2 + | Ast.Frac (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\frac"] @ aux p2 + | Ast.Atop (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\atop"] @ aux p2 + | Ast.Over (p1, p2) -> aux p1 @ [NoBinding, gram_symbol "\\over"] @ aux p2 + | Ast.Root (p1, p2) -> + [NoBinding, gram_symbol "\\root"] @ aux p2 + @ [NoBinding, gram_symbol "\\of"] @ aux p1 + | Ast.Sqrt p -> [NoBinding, gram_symbol "\\sqrt"] @ aux p + | Ast.Break -> [] + | Ast.Box (_, pl) -> List.flatten (List.map aux pl) + | Ast.Group pl -> List.flatten (List.map aux pl) + and aux_magic magic = + match magic with + | Ast.Opt p -> + let p_bindings, p_atoms, p_names, p_action = inner_pattern p in + let action (env_opt : CicNotationEnv.t option) (loc : Ast.location) = + match env_opt with + | Some env -> List.map Env.opt_binding_some env + | None -> List.map Env.opt_binding_of_name p_names + in + [ Env (List.map Env.opt_declaration p_names), + Gramext.srules + [ [ Gramext.Sopt (Gramext.srules [ p_atoms, p_action ]) ], + Gramext.action action ] ] + | Ast.List0 (p, _) + | Ast.List1 (p, _) -> + let p_bindings, p_atoms, p_names, p_action = inner_pattern p in +(* let env0 = List.map list_binding_of_name p_names in + let grow_env_entry env n v = + List.map + (function + | (n', (ty, ListValue vl)) as entry -> + if n' = n then n', (ty, ListValue (v :: vl)) else entry + | _ -> assert false) + env + in + let grow_env env_i env = + List.fold_left + (fun env (n, (_, v)) -> grow_env_entry env n v) + env env_i + in *) + let action (env_list : CicNotationEnv.t list) (loc : Ast.location) = + CicNotationEnv.coalesce_env p_names env_list + in + let gram_of_list s = + match magic with + | Ast.List0 (_, None) -> Gramext.Slist0 s + | Ast.List1 (_, None) -> Gramext.Slist1 s + | Ast.List0 (_, Some l) -> Gramext.Slist0sep (s, gram_of_literal l) + | Ast.List1 (_, Some l) -> Gramext.Slist1sep (s, gram_of_literal l) + | _ -> assert false + in + [ Env (List.map Env.list_declaration p_names), + Gramext.srules + [ [ gram_of_list (Gramext.srules [ p_atoms, p_action ]) ], + Gramext.action action ] ] + | _ -> assert false + and aux_variable = + function + | Ast.NumVar s -> [Binding (s, Env.NumType), gram_number ""] + | Ast.TermVar s -> [Binding (s, Env.TermType), gram_term] + | Ast.IdentVar s -> [Binding (s, Env.StringType), gram_ident ""] + | Ast.Ascription (p, s) -> assert false (* TODO *) + | Ast.FreshVar _ -> assert false + and inner_pattern p = + let p_bindings, p_atoms = List.split (aux p) in + let p_names = flatten_opt p_bindings in + let action = + make_action (fun (env : CicNotationEnv.t) (loc : Ast.location) -> env) + p_bindings + in + p_bindings, p_atoms, p_names, action + in + aux pattern + +let level_of precedence associativity = + if precedence < min_precedence || precedence > max_precedence then + raise (Level_not_found precedence); + let assoc_string = + match associativity with + | Gramext.NonA -> "N" + | Gramext.LeftA -> "L" + | Gramext.RightA -> "R" + in + string_of_int precedence ^ assoc_string + +type rule_id = Token.t Gramext.g_symbol list + + (* mapping: rule_id -> owned keywords. (rule_id, string list) Hashtbl.t *) +let owned_keywords = Hashtbl.create 23 + +let extend level1_pattern ~precedence ~associativity action = + let p_bindings, p_atoms = + List.split (extract_term_production level1_pattern) + in + let level = level_of precedence associativity in +(* let p_names = flatten_opt p_bindings in *) + let _ = + Grammar.extend + [ Grammar.Entry.obj (term: 'a Grammar.Entry.e), + Some (Gramext.Level level), + [ None, + Some associativity, + [ p_atoms, + (make_action + (fun (env: CicNotationEnv.t) (loc: Ast.location) -> + (action env loc)) + p_bindings) ]]] + in + let keywords = CicNotationUtil.keywords_of_term level1_pattern in + let rule_id = p_atoms in + List.iter CicNotationLexer.add_level2_ast_keyword keywords; + Hashtbl.add owned_keywords rule_id keywords; (* keywords may be [] *) + rule_id + +let delete rule_id = + let atoms = rule_id in + (try + let keywords = Hashtbl.find owned_keywords rule_id in + List.iter CicNotationLexer.remove_level2_ast_keyword keywords + with Not_found -> assert false); + Grammar.delete_rule term atoms + +(** {2 Grammar} *) + +let parse_level1_pattern_ref = ref (fun _ -> assert false) +let parse_level2_ast_ref = ref (fun _ -> assert false) +let parse_level2_meta_ref = ref (fun _ -> assert false) + +let fold_cluster binder terms ty body = + List.fold_right + (fun term body -> Ast.Binder (binder, (term, ty), body)) + terms body (* terms are names: either Ident or FreshVar *) + +let fold_exists terms ty body = + List.fold_right + (fun term body -> + let lambda = Ast.Binder (`Lambda, (term, ty), body) in + Ast.Appl [ Ast.Symbol ("exists", 0); lambda ]) + terms body + +let fold_binder binder pt_names body = + List.fold_right + (fun (names, ty) body -> fold_cluster binder names ty body) + pt_names body + +let return_term loc term = Ast.AttributedTerm (`Loc loc, term) + + (* create empty precedence level for "term" *) +let _ = + let dummy_action = + Gramext.action (fun _ -> + failwith "internal error, lexer generated a dummy token") + in + (* Needed since campl4 on "delete_rule" remove the precedence level if it gets + * empty after the deletion. The lexer never generate the Stoken below. *) + let dummy_prod = [ [ Gramext.Stoken ("DUMMY", "") ], dummy_action ] in + let mk_level_list first last = + let rec aux acc = function + | i when i < first -> acc + | i -> + aux + ((Some (string_of_int i ^ "N"), Some Gramext.NonA, dummy_prod) + :: (Some (string_of_int i ^ "L"), Some Gramext.LeftA, dummy_prod) + :: (Some (string_of_int i ^ "R"), Some Gramext.RightA, dummy_prod) + :: acc) + (i - 1) + in + aux [] last + in + Grammar.extend + [ Grammar.Entry.obj (term: 'a Grammar.Entry.e), + None, + mk_level_list min_precedence max_precedence ] + +(* {{{ Grammar for concrete syntax patterns, notation level 1 *) +EXTEND + GLOBAL: level1_pattern; + + level1_pattern: [ [ p = l1_pattern; EOI -> CicNotationUtil.boxify p ] ]; + l1_pattern: [ [ p = LIST1 l1_simple_pattern -> p ] ]; + literal: [ + [ s = SYMBOL -> `Symbol s + | k = QKEYWORD -> `Keyword k + | n = NUMBER -> `Number n + ] + ]; + sep: [ [ "sep"; sep = literal -> sep ] ]; +(* row_sep: [ [ "rowsep"; sep = literal -> sep ] ]; + field_sep: [ [ "fieldsep"; sep = literal -> sep ] ]; *) + l1_magic_pattern: [ + [ "list0"; p = l1_simple_pattern; sep = OPT sep -> Ast.List0 (p, sep) + | "list1"; p = l1_simple_pattern; sep = OPT sep -> Ast.List1 (p, sep) + | "opt"; p = l1_simple_pattern -> Ast.Opt p + ] + ]; + l1_pattern_variable: [ + [ "term"; id = IDENT -> Ast.TermVar id + | "number"; id = IDENT -> Ast.NumVar id + | "ident"; id = IDENT -> Ast.IdentVar id + ] + ]; + l1_simple_pattern: + [ "layout" LEFTA + [ p1 = SELF; SYMBOL "\\sub"; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Sub (p1, p2))) + | p1 = SELF; SYMBOL "\\sup"; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Sup (p1, p2))) + | p1 = SELF; SYMBOL "\\below"; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Below (p1, p2))) + | p1 = SELF; SYMBOL "\\above"; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Above (p1, p2))) + | p1 = SELF; SYMBOL "\\over"; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Over (p1, p2))) + | p1 = SELF; SYMBOL "\\atop"; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Atop (p1, p2))) +(* | "array"; p = SELF; csep = OPT field_sep; rsep = OPT row_sep -> + return_term loc (Array (p, csep, rsep)) *) + | SYMBOL "\\frac"; p1 = SELF; p2 = SELF -> + return_term loc (Ast.Layout (Ast.Frac (p1, p2))) + | SYMBOL "\\sqrt"; p = SELF -> return_term loc (Ast.Layout (Ast.Sqrt p)) + | SYMBOL "\\root"; index = SELF; SYMBOL "\\of"; arg = SELF -> + return_term loc (Ast.Layout (Ast.Root (arg, index))) + | "hbox"; LPAREN; p = l1_pattern; RPAREN -> + return_term loc (Ast.Layout (Ast.Box ((Ast.H, false, false), p))) + | "vbox"; LPAREN; p = l1_pattern; RPAREN -> + return_term loc (Ast.Layout (Ast.Box ((Ast.V, false, false), p))) + | "hvbox"; LPAREN; p = l1_pattern; RPAREN -> + return_term loc (Ast.Layout (Ast.Box ((Ast.HV, false, false), p))) + | "hovbox"; LPAREN; p = l1_pattern; RPAREN -> + return_term loc (Ast.Layout (Ast.Box ((Ast.HOV, false, false), p))) + | "break" -> return_term loc (Ast.Layout Ast.Break) +(* | SYMBOL "\\SPACE" -> return_term loc (Layout Space) *) + | LPAREN; p = l1_pattern; RPAREN -> + return_term loc (CicNotationUtil.group p) + ] + | "simple" NONA + [ i = IDENT -> return_term loc (Ast.Variable (Ast.TermVar i)) + | m = l1_magic_pattern -> return_term loc (Ast.Magic m) + | v = l1_pattern_variable -> return_term loc (Ast.Variable v) + | l = literal -> return_term loc (Ast.Literal l) + ] + ]; + END +(* }}} *) + +(* {{{ Grammar for ast magics, notation level 2 *) +EXTEND + GLOBAL: level2_meta; + l2_variable: [ + [ "term"; id = IDENT -> Ast.TermVar id + | "number"; id = IDENT -> Ast.NumVar id + | "ident"; id = IDENT -> Ast.IdentVar id + | "fresh"; id = IDENT -> Ast.FreshVar id + | "anonymous" -> Ast.TermVar "_" + | id = IDENT -> Ast.TermVar id + ] + ]; + l2_magic: [ + [ "fold"; kind = [ "left" -> `Left | "right" -> `Right ]; + base = level2_meta; "rec"; id = IDENT; recursive = level2_meta -> + Ast.Fold (kind, base, [id], recursive) + | "default"; some = level2_meta; none = level2_meta -> + Ast.Default (some, none) + | "if"; p_test = level2_meta; + "then"; p_true = level2_meta; + "else"; p_false = level2_meta -> + Ast.If (p_test, p_true, p_false) + | "fail" -> Ast.Fail + ] + ]; + level2_meta: [ + [ magic = l2_magic -> Ast.Magic magic + | var = l2_variable -> Ast.Variable var + | blob = UNPARSED_AST -> + !parse_level2_ast_ref (Ulexing.from_utf8_string blob) + ] + ]; +END +(* }}} *) + +(* {{{ Grammar for ast patterns, notation level 2 *) +EXTEND + GLOBAL: level2_ast term let_defs; + level2_ast: [ [ p = term -> p ] ]; + sort: [ + [ "Prop" -> `Prop + | "Set" -> `Set + | "Type" -> `Type (CicUniv.fresh ()) + | "CProp" -> `CProp + ] + ]; + explicit_subst: [ + [ SYMBOL "\\subst"; (* to avoid catching frequent "a [1]" cases *) + SYMBOL "["; + substs = LIST1 [ + i = IDENT; SYMBOL <:unicode> (* ≔ *); t = term -> (i, t) + ] SEP SYMBOL ";"; + SYMBOL "]" -> + substs + ] + ]; + meta_subst: [ + [ s = SYMBOL "_" -> None + | p = term -> Some p ] + ]; + meta_substs: [ + [ SYMBOL "["; substs = LIST0 meta_subst; SYMBOL "]" -> substs ] + ]; + possibly_typed_name: [ + [ LPAREN; id = single_arg; SYMBOL ":"; typ = term; RPAREN -> + id, Some typ + | arg = single_arg -> arg, None + ] + ]; + match_pattern: [ + [ id = IDENT -> id, None, [] + | LPAREN; id = IDENT; vars = LIST1 possibly_typed_name; RPAREN -> + id, None, vars + ] + ]; + binder: [ + [ SYMBOL <:unicode> (* Π *) -> `Pi +(* | SYMBOL <:unicode> |+ ∃ +| -> `Exists *) + | SYMBOL <:unicode> (* ∀ *) -> `Forall + | SYMBOL <:unicode> (* λ *) -> `Lambda + ] + ]; + arg: [ + [ LPAREN; names = LIST1 IDENT SEP SYMBOL ","; + SYMBOL ":"; ty = term; RPAREN -> + List.map (fun n -> Ast.Ident (n, None)) names, Some ty + | name = IDENT -> [Ast.Ident (name, None)], None + | blob = UNPARSED_META -> + let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in + match meta with + | Ast.Variable (Ast.FreshVar _) -> [meta], None + | Ast.Variable (Ast.TermVar "_") -> [Ast.Ident ("_", None)], None + | _ -> failwith "Invalid bound name." + ] + ]; + single_arg: [ + [ name = IDENT -> Ast.Ident (name, None) + | blob = UNPARSED_META -> + let meta = !parse_level2_meta_ref (Ulexing.from_utf8_string blob) in + match meta with + | Ast.Variable (Ast.FreshVar _) + | Ast.Variable (Ast.IdentVar _) -> meta + | Ast.Variable (Ast.TermVar "_") -> Ast.Ident ("_", None) + | _ -> failwith "Invalid index name." + ] + ]; + induction_kind: [ + [ "rec" -> `Inductive + | "corec" -> `CoInductive + ] + ]; + let_defs: [ + [ defs = LIST1 [ + name = single_arg; + args = LIST1 arg; + index_name = OPT [ "on"; id = single_arg -> id ]; + ty = OPT [ SYMBOL ":" ; p = term -> p ]; + SYMBOL <:unicode> (* ≝ *); body = term -> + let body = fold_binder `Lambda args body in + let ty = + match ty with + | None -> None + | Some ty -> Some (fold_binder `Pi args ty) + in + let rec position_of name p = function + | [] -> None, p + | n :: _ when n = name -> Some p, p + | _ :: tl -> position_of name (p + 1) tl + in + let rec find_arg name n = function + | [] -> + Ast.fail loc (sprintf "Argument %s not found" + (CicNotationPp.pp_term name)) + | (l,_) :: tl -> + (match position_of name 0 l with + | None, len -> find_arg name (n + len) tl + | Some where, len -> n + where) + in + let index = + match index_name with + | None -> 0 + | Some index_name -> find_arg index_name 0 args + in + (name, ty), body, index + ] SEP "and" -> + defs + ] + ]; + binder_vars: [ + [ vars = [ + l = LIST1 single_arg SEP SYMBOL "," -> l + | SYMBOL "_" -> [Ast.Ident ("_", None)] ]; + typ = OPT [ SYMBOL ":"; t = term -> t ] -> (vars, typ) + | LPAREN; + vars = [ + l = LIST1 single_arg SEP SYMBOL "," -> l + | SYMBOL "_" -> [Ast.Ident ("_", None)] ]; + typ = OPT [ SYMBOL ":"; t = term -> t ]; + RPAREN -> (vars, typ) + ] + ]; + term: LEVEL "10N" [ (* let in *) + [ "let"; var = possibly_typed_name; SYMBOL <:unicode> (* ≝ *); + p1 = term; "in"; p2 = term -> + return_term loc (Ast.LetIn (var, p1, p2)) + | "let"; k = induction_kind; defs = let_defs; "in"; + body = term -> + return_term loc (Ast.LetRec (k, defs, body)) + ] + ]; + term: LEVEL "20R" (* binder *) + [ + [ b = binder; (vars, typ) = binder_vars; SYMBOL "."; body = term -> + return_term loc (fold_cluster b vars typ body) + | SYMBOL <:unicode> (* ∃ *); + (vars, typ) = binder_vars; SYMBOL "."; body = term -> + return_term loc (fold_exists vars typ body) + ] + ]; + term: LEVEL "70L" (* apply *) + [ + [ p1 = term; p2 = term -> + let rec aux = function + | Ast.Appl (hd :: tl) + | Ast.AttributedTerm (_, Ast.Appl (hd :: tl)) -> + aux hd @ tl + | term -> [term] + in + return_term loc (Ast.Appl (aux p1 @ [p2])) + ] + ]; + term: LEVEL "90N" (* simple *) + [ + [ id = IDENT -> return_term loc (Ast.Ident (id, None)) + | id = IDENT; s = explicit_subst -> + return_term loc (Ast.Ident (id, Some s)) + | s = CSYMBOL -> return_term loc (Ast.Symbol (s, 0)) + | u = URI -> return_term loc (Ast.Uri (u, None)) + | n = NUMBER -> return_term loc (Ast.Num (n, 0)) + | IMPLICIT -> return_term loc (Ast.Implicit) + | PLACEHOLDER -> return_term loc Ast.UserInput + | m = META -> return_term loc (Ast.Meta (int_of_string m, [])) + | m = META; s = meta_substs -> + return_term loc (Ast.Meta (int_of_string m, s)) + | s = sort -> return_term loc (Ast.Sort s) + | "match"; t = term; + indty_ident = OPT [ "in"; id = IDENT -> id, None ]; + outtyp = OPT [ "return"; ty = term -> ty ]; + "with"; SYMBOL "["; + patterns = LIST0 [ + lhs = match_pattern; SYMBOL <:unicode> (* ⇒ *); + rhs = term -> + lhs, rhs + ] SEP SYMBOL "|"; + SYMBOL "]" -> + return_term loc (Ast.Case (t, indty_ident, outtyp, patterns)) + | LPAREN; p1 = term; SYMBOL ":"; p2 = term; RPAREN -> + return_term loc (Ast.Cast (p1, p2)) + | LPAREN; p = term; RPAREN -> p + | blob = UNPARSED_META -> + !parse_level2_meta_ref (Ulexing.from_utf8_string blob) + ] + ]; +END +(* }}} *) + +(** {2 API implementation} *) + +let exc_located_wrapper f = + try + f () + with + | Stdpp.Exc_located (floc, Stream.Error msg) -> + raise (HExtlib.Localized (floc, Parse_error msg)) + | Stdpp.Exc_located (floc, exn) -> + raise (HExtlib.Localized (floc, (Parse_error (Printexc.to_string exn)))) + +let parse_level1_pattern lexbuf = + exc_located_wrapper + (fun () -> Grammar.Entry.parse level1_pattern (Obj.magic lexbuf)) + +let parse_level2_ast lexbuf = + exc_located_wrapper + (fun () -> Grammar.Entry.parse level2_ast (Obj.magic lexbuf)) + +let parse_level2_meta lexbuf = + exc_located_wrapper + (fun () -> Grammar.Entry.parse level2_meta (Obj.magic lexbuf)) + +let _ = + parse_level1_pattern_ref := parse_level1_pattern; + parse_level2_ast_ref := parse_level2_ast; + parse_level2_meta_ref := parse_level2_meta + +(** {2 Debugging} *) + +let print_l2_pattern () = + Grammar.print_entry Format.std_formatter (Grammar.Entry.obj term); + Format.pp_print_flush Format.std_formatter (); + flush stdout + +(* vim:set encoding=utf8 foldmethod=marker: *) diff --git a/helm/software/components/content_pres/cicNotationParser.mli b/helm/software/components/content_pres/cicNotationParser.mli new file mode 100644 index 000000000..e25968bbb --- /dev/null +++ b/helm/software/components/content_pres/cicNotationParser.mli @@ -0,0 +1,66 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +exception Parse_error of string +exception Level_not_found of int + +(** {2 Parsing functions} *) + + (** concrete syntax pattern: notation level 1 *) +val parse_level1_pattern: Ulexing.lexbuf -> CicNotationPt.term + + (** AST pattern: notation level 2 *) +val parse_level2_ast: Ulexing.lexbuf -> CicNotationPt.term +val parse_level2_meta: Ulexing.lexbuf -> CicNotationPt.term + +(** {2 Grammar extension} *) + +type rule_id + +val extend: + CicNotationPt.term -> (* level 1 pattern *) + precedence:int -> + associativity:Gramext.g_assoc -> + (CicNotationEnv.t -> CicNotationPt.location -> CicNotationPt.term) -> + rule_id + +val delete: rule_id -> unit + +(** {2 Grammar entries} + * needed by grafite parser *) + +val level2_ast_grammar: Grammar.g + +val term : CicNotationPt.term Grammar.Entry.e + +val let_defs : + (CicNotationPt.capture_variable * CicNotationPt.term * int) list + Grammar.Entry.e + +(** {2 Debugging} *) + + (** print "level2_pattern" entry on stdout, flushing afterwards *) +val print_l2_pattern: unit -> unit + diff --git a/helm/software/components/content_pres/cicNotationPres.ml b/helm/software/components/content_pres/cicNotationPres.ml new file mode 100644 index 000000000..308f23d22 --- /dev/null +++ b/helm/software/components/content_pres/cicNotationPres.ml @@ -0,0 +1,433 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt +module Mpres = Mpresentation + +type mathml_markup = boxml_markup Mpres.mpres +and boxml_markup = mathml_markup Box.box + +type markup = mathml_markup + +let atop_attributes = [None, "linethickness", "0pt"] + +let to_unicode = Utf8Macro.unicode_of_tex + +let rec make_attributes l1 = function + | [] -> [] + | hd :: tl -> + (match hd with + | None -> make_attributes (List.tl l1) tl + | Some s -> + let p,n = List.hd l1 in + (p,n,s) :: make_attributes (List.tl l1) tl) + +let box_of_mpres = + function + | Mpresentation.Mobject (attrs, box) -> + assert (attrs = []); + box + | mpres -> Box.Object ([], mpres) + +let mpres_of_box = + function + | Box.Object (attrs, mpres) -> + assert (attrs = []); + mpres + | box -> Mpresentation.Mobject ([], box) + +let rec genuine_math = + function + | Mpresentation.Mobject ([], obj) -> not (genuine_box obj) + | _ -> true +and genuine_box = + function + | Box.Object ([], mpres) -> not (genuine_math mpres) + | _ -> true + +let rec eligible_math = + function + | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> eligible_math mpres + | Mpresentation.Mobject ([], _) -> false + | _ -> true + +let rec promote_to_math = + function + | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres + | math -> math + +let small_skip = + Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML) + +let rec add_mpres_attributes new_attr = function + | Mpresentation.Mobject (attr, box) -> + Mpresentation.Mobject (attr, add_box_attributes new_attr box) + | mpres -> + Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres +and add_box_attributes new_attr = function + | Box.Object (attr, mpres) -> + Box.Object (attr, add_mpres_attributes new_attr mpres) + | box -> Box.set_attr (new_attr @ Box.get_attr box) box + +let box_of mathonly spec attrs children = + match children with + | [t] -> add_mpres_attributes attrs t + | _ -> + let kind, spacing, indent = spec in + let dress children = + if spacing then + CicNotationUtil.dress small_skip children + else + children + in + if mathonly then Mpresentation.Mrow (attrs, dress children) + else + let attrs' = + (if spacing then RenderingAttrs.spacing_attributes `BoxML else []) + @ (if indent then RenderingAttrs.indent_attributes `BoxML else []) + @ attrs + in + match kind with + | Ast.H -> + if List.for_all eligible_math children then + Mpresentation.Mrow (attrs', + dress (List.map promote_to_math children)) + else + mpres_of_box (Box.H (attrs', + List.map box_of_mpres children)) +(* | Ast.H when List.for_all genuine_math children -> + Mpresentation.Mrow (attrs', dress children) *) + | Ast.V -> + mpres_of_box (Box.V (attrs', + List.map box_of_mpres children)) + | Ast.HV -> + mpres_of_box (Box.HV (attrs', + List.map box_of_mpres children)) + | Ast.HOV -> + mpres_of_box (Box.HOV (attrs', + List.map box_of_mpres children)) + +let open_paren = Mpresentation.Mo ([], "(") +let closed_paren = Mpresentation.Mo ([], ")") +let open_brace = Mpresentation.Mo ([], "{") +let closed_brace = Mpresentation.Mo ([], "}") +let hidden_substs = Mpresentation.Mtext ([], "{...}") +let open_box_paren = Box.Text ([], "(") +let closed_box_paren = Box.Text ([], ")") +let semicolon = Mpresentation.Mo ([], ";") +let toggle_action children = + Mpresentation.Maction ([None, "actiontype", "toggle"], children) + +type child_pos = [ `Left | `Right | `Inner ] + +let pp_assoc = + function + | Gramext.LeftA -> "LeftA" + | Gramext.RightA -> "RightA" + | Gramext.NonA -> "NonA" + +let is_atomic t = + let rec aux_mpres = function + | Mpres.Mi _ + | Mpres.Mo _ + | Mpres.Mn _ + | Mpres.Ms _ + | Mpres.Mtext _ + | Mpres.Mspace _ -> true + | Mpres.Mobject (_, box) -> aux_box box + | Mpres.Maction (_, [mpres]) + | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres + | _ -> false + and aux_box = function + | Box.Space _ + | Box.Ink _ + | Box.Text _ -> true + | Box.Object (_, mpres) -> aux_mpres mpres + | Box.H (_, [box]) + | Box.V (_, [box]) + | Box.HV (_, [box]) + | Box.HOV (_, [box]) + | Box.Action (_, [box]) -> aux_box box + | _ -> false + in + aux_mpres t + +let add_parens child_prec child_assoc child_pos curr_prec t = +(* eprintf + ("add_parens: " ^^ + "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d\n\n%!") + child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos child_pos) + curr_prec; *) + if is_atomic t then t + else if child_prec >= 0 + && (child_prec < curr_prec + || (child_prec = curr_prec && + child_assoc = Gramext.LeftA && + child_pos <> `Left) + || (child_prec = curr_prec && + child_assoc = Gramext.RightA && + child_pos <> `Right)) + then begin (* parens should be added *) +(* prerr_endline "adding parens!"; *) + match t with + | Mpresentation.Mobject (_, box) -> + mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ])) + | mpres -> Mpresentation.Mrow ([], [open_paren; t; closed_paren]) + end else + t + +let render ids_to_uris = + let module A = Ast in + let module P = Mpresentation in +(* let use_unicode = true in *) + let lookup_uri id = + (try + let uri = Hashtbl.find ids_to_uris id in + Some (UriManager.string_of_uri uri) + with Not_found -> None) + in + let make_href xmlattrs xref = + let xref_uris = + List.fold_right + (fun xref uris -> + match lookup_uri xref with + | None -> uris + | Some uri -> uri :: uris) + !xref [] + in + let xmlattrs_uris, xmlattrs = + let xref_attrs, other_attrs = + List.partition + (function Some "xlink", "href", _ -> true | _ -> false) + xmlattrs + in + List.map (fun (_, _, uri) -> uri) xref_attrs, + other_attrs + in + let uris = + match xmlattrs_uris @ xref_uris with + | [] -> None + | uris -> + Some (String.concat " " + (HExtlib.list_uniq (List.sort String.compare uris))) + in + let xrefs = + match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs) + in + xref := []; + xmlattrs + @ make_attributes [Some "helm", "xref"; Some "xlink", "href"] + [xrefs; uris] + in + let make_xref xref = + let xrefs = + match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs) + in + xref := []; + make_attributes [Some "helm","xref"] [xrefs] + in + (* when mathonly is true no boxes should be generated, only mrows *) + (* "xref" is *) + let rec aux xmlattrs mathonly xref pos prec t = + match t with + | A.AttributedTerm _ -> + aux_attributes xmlattrs mathonly xref pos prec t + | A.Num (literal, _) -> + let attrs = + (RenderingAttrs.number_attributes `MathML) + @ make_href xmlattrs xref + in + Mpres.Mn (attrs, literal) + | A.Symbol (literal, _) -> + let attrs = + (RenderingAttrs.symbol_attributes `MathML) + @ make_href xmlattrs xref + in + Mpres.Mo (attrs, to_unicode literal) + | A.Ident (literal, subst) + | A.Uri (literal, subst) -> + let attrs = + (RenderingAttrs.ident_attributes `MathML) + @ make_href xmlattrs xref + in + let name = Mpres.Mi (attrs, to_unicode literal) in + (match subst with + | Some [] + | None -> name + | Some substs -> + let substs' = + box_of mathonly (A.H, false, false) [] + (open_brace + :: (CicNotationUtil.dress semicolon + (List.map + (fun (name, t) -> + box_of mathonly (A.H, false, false) [] [ + Mpres.Mi ([], name); + Mpres.Mo ([], to_unicode "\\def"); + aux [] mathonly xref pos prec t ]) + substs)) + @ [ closed_brace ]) + in + let substs_maction = toggle_action [ hidden_substs; substs' ] in + box_of mathonly (A.H, false, false) [] [ name; substs_maction ]) + | A.Literal l -> aux_literal xmlattrs xref prec l + | A.UserInput -> Mpres.Mtext ([], "%") + | A.Layout l -> aux_layout mathonly xref pos prec l + | A.Magic _ + | A.Variable _ -> assert false (* should have been instantiated *) + | t -> + prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t); + assert false + and aux_attributes xmlattrs mathonly xref pos prec t = + let reset = ref false in + let new_level = ref None in + let new_xref = ref [] in + let new_xmlattrs = ref [] in + let new_pos = ref pos in +(* let reinit = ref false in *) + let rec aux_attribute = + function + | A.AttributedTerm (attr, t) -> + (match attr with + | `Loc _ + | `Raw _ -> () + | `Level (-1, _) -> reset := true + | `Level (child_prec, child_assoc) -> + new_level := Some (child_prec, child_assoc) + | `IdRef xref -> new_xref := xref :: !new_xref + | `ChildPos pos -> new_pos := pos + | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs); + aux_attribute t + | t -> + (match !new_level with + | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t + | Some (child_prec, child_assoc) -> + let t' = + aux !new_xmlattrs mathonly new_xref !new_pos child_prec t in + if !reset + then t' + else add_parens child_prec child_assoc !new_pos prec t') + in + aux_attribute t + and aux_literal xmlattrs xref prec l = + let attrs = make_href xmlattrs xref in + (match l with + | `Symbol s -> Mpres.Mo (attrs, to_unicode s) + | `Keyword s -> Mpres.Mo (attrs, to_unicode s) + | `Number s -> Mpres.Mn (attrs, to_unicode s)) + and aux_layout mathonly xref pos prec l = + let attrs = make_xref xref in + let invoke' t = aux [] true (ref []) pos prec t in + (* use the one below to reset precedence and associativity *) + let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in + match l with + | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2) + | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2) + | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2) + | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2) + | A.Frac (t1, t2) + | A.Over (t1, t2) -> + Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2) + | A.Atop (t1, t2) -> + Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1, + invoke_reinit t2) + | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t) + | A.Root (t1, t2) -> + Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2) + | A.Box ((_, spacing, _) as kind, terms) -> + let children = + aux_children mathonly spacing xref pos prec + (CicNotationUtil.ungroup terms) + in + box_of mathonly kind attrs children + | A.Group terms -> + let children = + aux_children mathonly false xref pos prec + (CicNotationUtil.ungroup terms) + in + box_of mathonly (A.H, false, false) attrs children + | A.Break -> assert false (* TODO? *) + and aux_children mathonly spacing xref pos prec terms = + let find_clusters = + let rec aux_list first clusters acc = + function + [] when acc = [] -> List.rev clusters + | [] -> aux_list first (List.rev acc :: clusters) [] [] + | (A.Layout A.Break) :: tl when acc = [] -> + aux_list first clusters [] tl + | (A.Layout A.Break) :: tl -> + aux_list first (List.rev acc :: clusters) [] tl + | [hd] -> +(* let pos' = + if first then + pos + else + match pos with + `None -> `Right + | `Inner -> `Inner + | `Right -> `Right + | `Left -> `Inner + in *) + aux_list false clusters + (aux [] mathonly xref pos prec hd :: acc) [] + | hd :: tl -> +(* let pos' = + match pos, first with + `None, true -> `Left + | `None, false -> `Inner + | `Left, true -> `Left + | `Left, false -> `Inner + | `Right, _ -> `Inner + | `Inner, _ -> `Inner + in *) + aux_list false clusters + (aux [] mathonly xref pos prec hd :: acc) tl + in + aux_list true [] [] + in + let boxify_pres = + function + [t] -> t + | tl -> box_of mathonly (A.H, spacing, false) [] tl + in + List.map boxify_pres (find_clusters terms) + in + aux [] false (ref []) `Inner ~-1 + +let rec print_box (t: boxml_markup) = + Box.box2xml print_mpres t +and print_mpres (t: mathml_markup) = + Mpresentation.print_mpres print_box t + +let print_xml = print_mpres + +(* let render_to_boxml id_to_uri t = + let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in + Xml.add_xml_declaration xml_stream *) + diff --git a/helm/software/components/content_pres/cicNotationPres.mli b/helm/software/components/content_pres/cicNotationPres.mli new file mode 100644 index 000000000..04411df2b --- /dev/null +++ b/helm/software/components/content_pres/cicNotationPres.mli @@ -0,0 +1,52 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +type mathml_markup = boxml_markup Mpresentation.mpres +and boxml_markup = mathml_markup Box.box + +type markup = mathml_markup + +(** {2 Markup conversions} *) + +val mpres_of_box: boxml_markup -> mathml_markup +val box_of_mpres: mathml_markup -> boxml_markup + +(** {2 Rendering} *) + +(** level 1 -> level 0 + * @param ids_to_uris mapping id -> uri for hyperlinking *) +val render: (Cic.id, UriManager.uri) Hashtbl.t -> CicNotationPt.term -> markup + +(** level 0 -> xml stream *) +val print_xml: markup -> Xml.token Stream.t + +(* |+* level 1 -> xml stream + * @param ids_to_uris +| +val render_to_boxml: + (Cic.id, string) Hashtbl.t -> CicNotationPt.term -> Xml.token Stream.t *) + +val print_box: boxml_markup -> Xml.token Stream.t +val print_mpres: mathml_markup -> Xml.token Stream.t + diff --git a/helm/software/components/content_pres/content2pres.ml b/helm/software/components/content_pres/content2pres.ml new file mode 100644 index 000000000..abac7cb5d --- /dev/null +++ b/helm/software/components/content_pres/content2pres.ml @@ -0,0 +1,821 @@ +(* Copyright (C) 2003-2005, 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 *) +(* *) +(* Andrea Asperti *) +(* 17/06/2003 *) +(* *) +(***************************************************************************) + +(* $Id$ *) + +module P = Mpresentation +module B = Box +module Con = Content + +let p_mtr a b = Mpresentation.Mtr(a,b) +let p_mtd a b = Mpresentation.Mtd(a,b) +let p_mtable a b = Mpresentation.Mtable(a,b) +let p_mtext a b = Mpresentation.Mtext(a,b) +let p_mi a b = Mpresentation.Mi(a,b) +let p_mo a b = Mpresentation.Mo(a,b) +let p_mrow a b = Mpresentation.Mrow(a,b) +let p_mphantom a b = Mpresentation.Mphantom(a,b) + +let rec split n l = + if n = 0 then [],l + else let l1,l2 = + split (n-1) (List.tl l) in + (List.hd l)::l1,l2 + +let get_xref = function + | `Declaration d + | `Hypothesis d -> d.Con.dec_id + | `Proof p -> p.Con.proof_id + | `Definition d -> d.Con.def_id + | `Joint jo -> jo.Con.joint_id + +let hv_attrs = + RenderingAttrs.spacing_attributes `BoxML + @ RenderingAttrs.indent_attributes `BoxML + +let make_row items concl = + B.b_hv hv_attrs (items @ [ concl ]) +(* match concl with + B.V _ -> |+ big! +| + B.b_v attrs [B.b_h [] items; B.b_indent concl] + | _ -> |+ small +| + B.b_h attrs (items@[B.b_space; concl]) *) + +let make_concl ?(attrs=[]) verb concl = + B.b_hv (hv_attrs @ attrs) [ B.b_kw verb; concl ] +(* match concl with + B.V _ -> |+ big! +| + B.b_v attrs [ B.b_kw verb; B.b_indent concl] + | _ -> |+ small +| + B.b_h attrs [ B.b_kw verb; B.b_space; concl ] *) + +let make_args_for_apply term2pres args = + let make_arg_for_apply is_first arg row = + let res = + match arg with + Con.Aux n -> assert false + | Con.Premise prem -> + let name = + (match prem.Con.premise_binder with + None -> "previous" + | Some s -> s) in + (B.b_object (P.Mi ([], name)))::row + | Con.Lemma lemma -> + let lemma_attrs = [ + Some "helm", "xref", lemma.Con.lemma_id; + Some "xlink", "href", lemma.Con.lemma_uri ] + in + (B.b_object (P.Mi(lemma_attrs,lemma.Con.lemma_name)))::row + | Con.Term t -> + if is_first then + (term2pres t)::row + else (B.b_object (P.Mi([],"_")))::row + | Con.ArgProof _ + | Con.ArgMethod _ -> + (B.b_object (P.Mi([],"_")))::row + in + if is_first then res else B.skip::res + in + match args with + hd::tl -> + make_arg_for_apply true hd + (List.fold_right (make_arg_for_apply false) tl []) + | _ -> assert false + +let get_name = function + | Some s -> s + | None -> "_" + +let add_xref id = function + | B.Text (attrs, t) -> B.Text (((Some "helm", "xref", id) :: attrs), t) + | _ -> assert false (* TODO, add_xref is meaningful for all boxes *) + +let rec justification term2pres p = + if ((p.Con.proof_conclude.Con.conclude_method = "Exact") or + ((p.Con.proof_context = []) & + (p.Con.proof_apply_context = []) & + (p.Con.proof_conclude.Con.conclude_method = "Apply"))) then + let pres_args = + make_args_for_apply term2pres p.Con.proof_conclude.Con.conclude_args in + B.H([], + (B.b_kw "by")::B.b_space:: + B.Text([],"(")::pres_args@[B.Text([],")")]) + else proof2pres term2pres p + +and proof2pres term2pres p = + let rec proof2pres p = + let indent = + let is_decl e = + (match e with + `Declaration _ + | `Hypothesis _ -> true + | _ -> false) in + ((List.filter is_decl p.Con.proof_context) != []) in + let omit_conclusion = (not indent) && (p.Con.proof_context != []) in + let concl = + (match p.Con.proof_conclude.Con.conclude_conclusion with + None -> None + | Some t -> Some (term2pres t)) in + let body = + let presconclude = + conclude2pres p.Con.proof_conclude indent omit_conclusion in + let presacontext = + acontext2pres p.Con.proof_apply_context presconclude indent in + context2pres p.Con.proof_context presacontext in + match p.Con.proof_name with + None -> body + | Some name -> + let action = + match concl with + None -> body + | Some ac -> + let concl = + make_concl ~attrs:[ Some "helm", "xref", p.Con.proof_id ] + "proof of" ac in + B.b_toggle [ concl; body ] + in + B.V ([], + [B.Text ([],"(" ^ name ^ ")"); + B.indent action]) + + and context2pres c continuation = + (* we generate a subtable for each context element, for selection + purposes + The table generated by the head-element does not have an xref; + the whole context-proof is already selectable *) + match c with + [] -> continuation + | hd::tl -> + let continuation' = + List.fold_right + (fun ce continuation -> + let xref = get_xref ce in + B.V([Some "helm", "xref", xref ], + [B.H([Some "helm", "xref", "ce_"^xref], + [ce2pres_in_proof_context_element ce]); + continuation])) tl continuation in + let hd_xref= get_xref hd in + B.V([], + [B.H([Some "helm", "xref", "ce_"^hd_xref], + [ce2pres_in_proof_context_element hd]); + continuation']) + + and ce2pres_in_joint_context_element = function + | `Inductive _ -> assert false (* TODO *) + | (`Declaration _) as x -> ce2pres x + | (`Hypothesis _) as x -> ce2pres x + | (`Proof _) as x -> ce2pres x + | (`Definition _) as x -> ce2pres x + + and ce2pres_in_proof_context_element = function + | `Joint ho -> + B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs)) + | (`Declaration _) as x -> ce2pres x + | (`Hypothesis _) as x -> ce2pres x + | (`Proof _) as x -> ce2pres x + | (`Definition _) as x -> ce2pres x + + and ce2pres = + function + `Declaration d -> + (match d.Con.dec_name with + Some s -> + let ty = term2pres d.Con.dec_type in + B.H ([], + [(B.b_kw "Assume"); + B.b_space; + B.Object ([], P.Mi([],s)); + B.Text([],":"); + ty]) + | None -> + prerr_endline "NO NAME!!"; assert false) + | `Hypothesis h -> + (match h.Con.dec_name with + Some s -> + let ty = term2pres h.Con.dec_type in + B.H ([], + [(B.b_kw "Suppose"); + B.b_space; + B.Text([],"("); + B.Object ([], P.Mi ([],s)); + B.Text([],")"); + B.b_space; + ty]) + | None -> + prerr_endline "NO NAME!!"; assert false) + | `Proof p -> + proof2pres p + | `Definition d -> + (match d.Con.def_name with + Some s -> + let term = term2pres d.Con.def_term in + B.H ([], + [ B.b_kw "Let"; B.b_space; + B.Object ([], P.Mi([],s)); + B.Text([]," = "); + term]) + | None -> + prerr_endline "NO NAME!!"; assert false) + + and acontext2pres ac continuation indent = + List.fold_right + (fun p continuation -> + let hd = + if indent then + B.indent (proof2pres p) + else + proof2pres p in + B.V([Some "helm","xref",p.Con.proof_id], + [B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]); + continuation])) ac continuation + + and conclude2pres conclude indent omit_conclusion = + let tconclude_body = + match conclude.Con.conclude_conclusion with + Some t when + not omit_conclusion or + (* CSC: I ignore the omit_conclusion flag in this case. *) + (* CSC: Is this the correct behaviour? In the stylesheets *) + (* CSC: we simply generated nothing (i.e. the output type *) + (* CSC: of the function should become an option. *) + conclude.Con.conclude_method = "BU_Conversion" -> + let concl = (term2pres t) in + if conclude.Con.conclude_method = "BU_Conversion" then + make_concl "that is equivalent to" concl + else if conclude.Con.conclude_method = "FalseInd" then + (* false ind is in charge to add the conclusion *) + falseind conclude + else + let conclude_body = conclude_aux conclude in + let ann_concl = + if conclude.Con.conclude_method = "TD_Conversion" then + make_concl "that is equivalent to" concl + else make_concl "we conclude" concl in + B.V ([], [conclude_body; ann_concl]) + | _ -> conclude_aux conclude in + if indent then + B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id], + [tconclude_body])) + else + B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body]) + + and conclude_aux conclude = + if conclude.Con.conclude_method = "TD_Conversion" then + let expected = + (match conclude.Con.conclude_conclusion with + None -> B.Text([],"NO EXPECTED!!!") + | Some c -> term2pres c) in + let subproof = + (match conclude.Con.conclude_args with + [Con.ArgProof p] -> p + | _ -> assert false) in + let synth = + (match subproof.Con.proof_conclude.Con.conclude_conclusion with + None -> B.Text([],"NO SYNTH!!!") + | Some c -> (term2pres c)) in + B.V + ([], + [make_concl "we must prove" expected; + make_concl "or equivalently" synth; + proof2pres subproof]) + else if conclude.Con.conclude_method = "BU_Conversion" then + assert false + else if conclude.Con.conclude_method = "Exact" then + let arg = + (match conclude.Con.conclude_args with + [Con.Term t] -> term2pres t + | [Con.Premise p] -> + (match p.Con.premise_binder with + | None -> assert false; (* unnamed hypothesis ??? *) + | Some s -> B.Text([],s)) + | err -> assert false) in + (match conclude.Con.conclude_conclusion with + None -> + B.b_h [] [B.b_kw "Consider"; B.b_space; arg] + | Some c -> let conclusion = term2pres c in + make_row + [arg; B.b_space; B.b_kw "proves"] + conclusion + ) + else if conclude.Con.conclude_method = "Intros+LetTac" then + (match conclude.Con.conclude_args with + [Con.ArgProof p] -> proof2pres p + | _ -> assert false) +(* OLD CODE + let conclusion = + (match conclude.Con.conclude_conclusion with + None -> B.Text([],"NO Conclusion!!!") + | Some c -> term2pres c) in + (match conclude.Con.conclude_args with + [Con.ArgProof p] -> + B.V + ([None,"align","baseline 1"; None,"equalrows","false"; + None,"columnalign","left"], + [B.H([],[B.Object([],proof2pres p)]); + B.H([],[B.Object([], + (make_concl "we proved 1" conclusion))])]); + | _ -> assert false) +*) + else if (conclude.Con.conclude_method = "Case") then + case conclude + else if (conclude.Con.conclude_method = "ByInduction") then + byinduction conclude + else if (conclude.Con.conclude_method = "Exists") then + exists conclude + else if (conclude.Con.conclude_method = "AndInd") then + andind conclude + else if (conclude.Con.conclude_method = "FalseInd") then + falseind conclude + else if (conclude.Con.conclude_method = "Rewrite") then + let justif = + (match (List.nth conclude.Con.conclude_args 6) with + Con.ArgProof p -> justification term2pres p + | _ -> assert false) in + let term1 = + (match List.nth conclude.Con.conclude_args 2 with + Con.Term t -> term2pres t + | _ -> assert false) in + let term2 = + (match List.nth conclude.Con.conclude_args 5 with + Con.Term t -> term2pres t + | _ -> assert false) in + B.V ([], + [B.H ([],[ + (B.b_kw "rewrite"); + B.b_space; term1; + B.b_space; (B.b_kw "with"); + B.b_space; term2; + B.indent justif])]) + else if conclude.Con.conclude_method = "Apply" then + let pres_args = + make_args_for_apply term2pres conclude.Con.conclude_args in + B.H([], + (B.b_kw "by"):: + B.b_space:: + B.Text([],"(")::pres_args@[B.Text([],")")]) + else + B.V ([], [ + B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to"); + (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))]) + + and args2pres l = List.map arg2pres l + + and arg2pres = + function + Con.Aux n -> B.b_kw ("aux " ^ n) + | Con.Premise prem -> B.b_kw "premise" + | Con.Lemma lemma -> B.b_kw "lemma" + | Con.Term t -> term2pres t + | Con.ArgProof p -> proof2pres p + | Con.ArgMethod s -> B.b_kw "method" + + and case conclude = + let proof_conclusion = + (match conclude.Con.conclude_conclusion with + None -> B.b_kw "No conclusion???" + | Some t -> term2pres t) in + let arg,args_for_cases = + (match conclude.Con.conclude_args with + Con.Aux(_)::Con.Aux(_)::Con.Term(_)::arg::tl -> + arg,tl + | _ -> assert false) in + let case_on = + let case_arg = + (match arg with + Con.Aux n -> B.b_kw "an aux???" + | Con.Premise prem -> + (match prem.Con.premise_binder with + None -> B.b_kw "the previous result" + | Some n -> B.Object ([], P.Mi([],n))) + | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name)) + | Con.Term t -> + term2pres t + | Con.ArgProof p -> B.b_kw "a proof???" + | Con.ArgMethod s -> B.b_kw "a method???") + in + (make_concl "we proceed by cases on" case_arg) in + let to_prove = + (make_concl "to prove" proof_conclusion) in + B.V ([], case_on::to_prove::(make_cases args_for_cases)) + + and byinduction conclude = + let proof_conclusion = + (match conclude.Con.conclude_conclusion with + None -> B.b_kw "No conclusion???" + | Some t -> term2pres t) in + let inductive_arg,args_for_cases = + (match conclude.Con.conclude_args with + Con.Aux(n)::_::tl -> + let l1,l2 = split (int_of_string n) tl in + let last_pos = (List.length l2)-1 in + List.nth l2 last_pos,l1 + | _ -> assert false) in + let induction_on = + let arg = + (match inductive_arg with + Con.Aux n -> B.b_kw "an aux???" + | Con.Premise prem -> + (match prem.Con.premise_binder with + None -> B.b_kw "the previous result" + | Some n -> B.Object ([], P.Mi([],n))) + | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name)) + | Con.Term t -> + term2pres t + | Con.ArgProof p -> B.b_kw "a proof???" + | Con.ArgMethod s -> B.b_kw "a method???") in + (make_concl "we proceed by induction on" arg) in + let to_prove = + (make_concl "to prove" proof_conclusion) in + B.V ([], induction_on::to_prove:: (make_cases args_for_cases)) + + and make_cases l = List.map make_case l + + and make_case = + function + Con.ArgProof p -> + let name = + (match p.Con.proof_name with + None -> B.b_kw "no name for case!!" + | Some n -> B.Object ([], P.Mi([],n))) in + let indhyps,args = + List.partition + (function + `Hypothesis h -> h.Con.dec_inductive + | _ -> false) p.Con.proof_context in + let pattern_aux = + List.fold_right + (fun e p -> + let dec = + (match e with + `Declaration h + | `Hypothesis h -> + let name = + (match h.Con.dec_name with + None -> "NO NAME???" + | Some n ->n) in + [B.b_space; + B.Object ([], P.Mi ([],name)); + B.Text([],":"); + (term2pres h.Con.dec_type)] + | _ -> [B.Text ([],"???")]) in + dec@p) args [] in + let pattern = + B.H ([], + (B.b_kw "Case"::B.b_space::name::pattern_aux)@ + [B.b_space; + B.Text([], Utf8Macro.unicode_of_tex "\\Rightarrow")]) in + let subconcl = + (match p.Con.proof_conclude.Con.conclude_conclusion with + None -> B.b_kw "No conclusion!!!" + | Some t -> term2pres t) in + let asubconcl = B.indent (make_concl "the thesis becomes" subconcl) in + let induction_hypothesis = + (match indhyps with + [] -> [] + | _ -> + let text = B.indent (B.b_kw "by induction hypothesis we know") in + let make_hyp = + function + `Hypothesis h -> + let name = + (match h.Con.dec_name with + None -> "no name" + | Some s -> s) in + B.indent (B.H ([], + [B.Text([],"("); + B.Object ([], P.Mi ([],name)); + B.Text([],")"); + B.b_space; + term2pres h.Con.dec_type])) + | _ -> assert false in + let hyps = List.map make_hyp indhyps in + text::hyps) in + (* let acontext = + acontext2pres_old p.Con.proof_apply_context true in *) + let body = conclude2pres p.Con.proof_conclude true false in + let presacontext = + let acontext_id = + match p.Con.proof_apply_context with + [] -> p.Con.proof_conclude.Con.conclude_id + | {Con.proof_id = id}::_ -> id + in + B.Action([None,"type","toggle"], + [ B.indent (add_xref acontext_id (B.b_kw "Proof")); + acontext2pres p.Con.proof_apply_context body true]) in + B.V ([], pattern::asubconcl::induction_hypothesis@[presacontext]) + | _ -> assert false + + and falseind conclude = + let proof_conclusion = + (match conclude.Con.conclude_conclusion with + None -> B.b_kw "No conclusion???" + | Some t -> term2pres t) in + let case_arg = + (match conclude.Con.conclude_args with + [Con.Aux(n);_;case_arg] -> case_arg + | _ -> assert false; + (* + List.map (ContentPp.parg 0) conclude.Con.conclude_args; + assert false *)) in + let arg = + (match case_arg with + Con.Aux n -> assert false + | Con.Premise prem -> + (match prem.Con.premise_binder with + None -> [B.b_kw "Contradiction, hence"] + | Some n -> + [ B.Object ([],P.Mi([],n)); B.skip; + B.b_kw "is contradictory, hence"]) + | Con.Lemma lemma -> + [ B.Object ([], P.Mi([],lemma.Con.lemma_name)); B.skip; + B.b_kw "is contradictory, hence" ] + | _ -> assert false) in + (* let body = proof2pres {proof with Con.proof_context = tl} in *) + make_row arg proof_conclusion + + and andind conclude = + let proof,case_arg = + (match conclude.Con.conclude_args with + [Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg + | _ -> assert false; + (* + List.map (ContentPp.parg 0) conclude.Con.conclude_args; + assert false *)) in + let arg = + (match case_arg with + Con.Aux n -> assert false + | Con.Premise prem -> + (match prem.Con.premise_binder with + None -> [] + | Some n -> [(B.b_kw "by"); B.b_space; B.Object([], P.Mi([],n))]) + | Con.Lemma lemma -> + [(B.b_kw "by");B.skip; + B.Object([], P.Mi([],lemma.Con.lemma_name))] + | _ -> assert false) in + match proof.Con.proof_context with + `Hypothesis hyp1::`Hypothesis hyp2::tl -> + let get_name hyp = + (match hyp.Con.dec_name with + None -> "_" + | Some s -> s) in + let preshyp1 = + B.H ([], + [B.Text([],"("); + B.Object ([], P.Mi([],get_name hyp1)); + B.Text([],")"); + B.skip; + term2pres hyp1.Con.dec_type]) in + let preshyp2 = + B.H ([], + [B.Text([],"("); + B.Object ([], P.Mi([],get_name hyp2)); + B.Text([],")"); + B.skip; + term2pres hyp2.Con.dec_type]) in + (* let body = proof2pres {proof with Con.proof_context = tl} in *) + let body = conclude2pres proof.Con.proof_conclude false true in + let presacontext = + acontext2pres proof.Con.proof_apply_context body false in + B.V + ([], + [B.H ([],arg@[B.skip; B.b_kw "we have"]); + preshyp1; + B.b_kw "and"; + preshyp2; + presacontext]); + | _ -> assert false + + and exists conclude = + let proof = + (match conclude.Con.conclude_args with + [Con.Aux(n);_;Con.ArgProof proof;_] -> proof + | _ -> assert false; + (* + List.map (ContentPp.parg 0) conclude.Con.conclude_args; + assert false *)) in + match proof.Con.proof_context with + `Declaration decl::`Hypothesis hyp::tl + | `Hypothesis decl::`Hypothesis hyp::tl -> + let get_name decl = + (match decl.Con.dec_name with + None -> "_" + | Some s -> s) in + let presdecl = + B.H ([], + [(B.b_kw "let"); + B.skip; + B.Object ([], P.Mi([],get_name decl)); + B.Text([],":"); term2pres decl.Con.dec_type]) in + let suchthat = + B.H ([], + [(B.b_kw "such that"); + B.skip; + B.Text([],"("); + B.Object ([], P.Mi([],get_name hyp)); + B.Text([],")"); + B.skip; + term2pres hyp.Con.dec_type]) in + (* let body = proof2pres {proof with Con.proof_context = tl} in *) + let body = conclude2pres proof.Con.proof_conclude false true in + let presacontext = + acontext2pres proof.Con.proof_apply_context body false in + B.V + ([], + [presdecl; + suchthat; + presacontext]); + | _ -> assert false + + in + proof2pres p + +exception ToDo + +let counter = ref 0 + +let conjecture2pres term2pres (id, n, context, ty) = + B.b_indent + (B.b_hv [Some "helm", "xref", id] + ((B.b_toggle [ + B.b_h [] [B.b_text [] "{...}"; B.b_space]; + B.b_hv [] (List.map + (function + | None -> + B.b_h [] + [ B.b_object (p_mi [] "_") ; + B.b_object (p_mo [] ":?") ; + B.b_object (p_mi [] "_")] + | Some (`Declaration d) + | Some (`Hypothesis d) -> + let { Content.dec_name = + dec_name ; Content.dec_type = ty } = d + in + B.b_h [] + [ B.b_object + (p_mi [] + (match dec_name with + None -> "_" + | Some n -> n)); + B.b_text [] ":"; + term2pres ty ] + | Some (`Definition d) -> + let + { Content.def_name = def_name ; + Content.def_term = bo } = d + in + B.b_h [] + [ B.b_object (p_mi [] + (match def_name with + None -> "_" + | Some n -> n)) ; + B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign"); + term2pres bo] + | Some (`Proof p) -> + let proof_name = p.Content.proof_name in + B.b_h [] + [ B.b_object (p_mi [] + (match proof_name with + None -> "_" + | Some n -> n)) ; + B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign"); + proof2pres term2pres p]) + (List.rev context)) ] :: + [ B.b_h [] + [ B.b_text [] (Utf8Macro.unicode_of_tex "\\vdash"); + B.b_object (p_mi [] (string_of_int n)) ; + B.b_text [] ":" ; + term2pres ty ]]))) + +let metasenv2pres term2pres = function + | None -> [] + | Some metasenv' -> + (* Conjectures are in their own table to make *) + (* diffing the DOM trees easier. *) + [B.b_v [] + ((B.b_kw ("Conjectures:" ^ + (let _ = incr counter; in (string_of_int !counter)))) :: + (List.map (conjecture2pres term2pres) metasenv'))] + +let params2pres params = + let param2pres uri = + B.b_text [Some "xlink", "href", UriManager.string_of_uri uri] + (UriManager.name_of_uri uri) + in + let rec spatiate = function + | [] -> [] + | hd :: [] -> [hd] + | hd :: tl -> hd :: B.b_text [] ", " :: spatiate tl + in + match params with + | [] -> [] + | p -> + let params = spatiate (List.map param2pres p) in + [B.b_space; + B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])] + +let recursion_kind2pres params kind = + let kind = + match kind with + | `Recursive _ -> "Recursive definition" + | `CoRecursive -> "CoRecursive definition" + | `Inductive _ -> "Inductive definition" + | `CoInductive _ -> "CoInductive definition" + in + B.b_h [] (B.b_kw kind :: params2pres params) + +let inductive2pres term2pres ind = + let constructor2pres decl = + B.b_h [] [ + B.b_text [] ("| " ^ get_name decl.Content.dec_name ^ ":"); + B.b_space; + term2pres decl.Content.dec_type + ] + in + B.b_v [] + (B.b_h [] [ + B.b_kw (ind.Content.inductive_name ^ " of arity"); + B.smallskip; + term2pres ind.Content.inductive_type ] + :: List.map constructor2pres ind.Content.inductive_constructors) + +let joint_def2pres term2pres def = + match def with + | `Inductive ind -> inductive2pres term2pres ind + | _ -> assert false (* ZACK or raise ToDo? *) + +let content2pres term2pres (id,params,metasenv,obj) = + match obj with + | `Def (Content.Const, thesis, `Proof p) -> + let name = get_name p.Content.proof_name in + B.b_v + [Some "helm","xref","id"] + ([ B.b_h [] (B.b_kw ("Proof " ^ name) :: params2pres params); + B.b_kw "Thesis:"; + B.indent (term2pres thesis) ] @ + metasenv2pres term2pres metasenv @ + [proof2pres term2pres p]) + | `Def (_, ty, `Definition body) -> + let name = get_name body.Content.def_name in + B.b_v + [Some "helm","xref","id"] + ([B.b_h [] (B.b_kw ("Definition " ^ name) :: params2pres params); + B.b_kw "Type:"; + B.indent (term2pres ty)] @ + metasenv2pres term2pres metasenv @ + [B.b_kw "Body:"; term2pres body.Content.def_term]) + | `Decl (_, `Declaration decl) + | `Decl (_, `Hypothesis decl) -> + let name = get_name decl.Content.dec_name in + B.b_v + [Some "helm","xref","id"] + ([B.b_h [] (B.b_kw ("Axiom " ^ name) :: params2pres params); + B.b_kw "Type:"; + B.indent (term2pres decl.Content.dec_type)] @ + metasenv2pres term2pres metasenv) + | `Joint joint -> + B.b_v [] + (recursion_kind2pres params joint.Content.joint_kind + :: List.map (joint_def2pres term2pres) joint.Content.joint_defs) + | _ -> raise ToDo + +let content2pres ~ids_to_inner_sorts = + content2pres + (fun annterm -> + let ast, ids_to_uris = + TermAcicContent.ast_of_acic ids_to_inner_sorts annterm + in + CicNotationPres.box_of_mpres + (CicNotationPres.render ids_to_uris + (TermContentPres.pp_ast ast))) + diff --git a/helm/software/components/content_pres/content2pres.mli b/helm/software/components/content_pres/content2pres.mli new file mode 100644 index 000000000..793c31a4f --- /dev/null +++ b/helm/software/components/content_pres/content2pres.mli @@ -0,0 +1,39 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 27/6/2003 *) +(* *) +(**************************************************************************) + +val content2pres: + ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> + Cic.annterm Content.cobj -> + CicNotationPres.boxml_markup + diff --git a/helm/software/components/content_pres/content2presMatcher.ml b/helm/software/components/content_pres/content2presMatcher.ml new file mode 100644 index 000000000..7e080ea69 --- /dev/null +++ b/helm/software/components/content_pres/content2presMatcher.ml @@ -0,0 +1,233 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt +module Env = CicNotationEnv +module Pp = CicNotationPp +module Util = CicNotationUtil + +let get_tag term0 = + let subterms = ref [] in + let map_term t = + subterms := t :: !subterms ; + Ast.Implicit + in + let rec aux t = CicNotationUtil.visit_ast ~special_k map_term t + and special_k = function + | Ast.AttributedTerm (_, t) -> aux t + | _ -> assert false + in + let term_mask = aux term0 in + let tag = Hashtbl.hash term_mask in + tag, List.rev !subterms + +module Matcher21 = +struct + module Pattern21 = + struct + type pattern_t = Ast.term + type term_t = Ast.term + let rec classify = function + | Ast.AttributedTerm (_, t) -> classify t + | Ast.Variable _ -> PatternMatcher.Variable + | Ast.Magic _ + | Ast.Layout _ + | Ast.Literal _ -> assert false + | _ -> PatternMatcher.Constructor + let tag_of_pattern = get_tag + let tag_of_term t = get_tag t + let string_of_term = CicNotationPp.pp_term + let string_of_pattern = CicNotationPp.pp_term + end + + module M = PatternMatcher.Matcher (Pattern21) + + let extract_magic term = + let magic_map = ref [] in + let add_magic m = + let name = Util.fresh_name () in + magic_map := (name, m) :: !magic_map; + Ast.Variable (Ast.TermVar name) + in + let rec aux = function + | Ast.AttributedTerm (_, t) -> assert false + | Ast.Literal _ + | Ast.Layout _ -> assert false + | Ast.Variable v -> Ast.Variable v + | Ast.Magic m -> add_magic m + | t -> Util.visit_ast aux t + in + let term' = aux term in + term', !magic_map + + let env_of_matched pl tl = + try + List.map2 + (fun p t -> + match p, t with + Ast.Variable (Ast.TermVar name), _ -> + name, (Env.TermType, Env.TermValue t) + | Ast.Variable (Ast.NumVar name), (Ast.Num (s, _)) -> + name, (Env.NumType, Env.NumValue s) + | Ast.Variable (Ast.IdentVar name), (Ast.Ident (s, None)) -> + name, (Env.StringType, Env.StringValue s) + | _ -> assert false) + pl tl + with Invalid_argument _ -> assert false + + let rec compiler rows = + let rows', magic_maps = + List.split + (List.map + (fun (p, pid) -> + let p', map = extract_magic p in + (p', pid), (pid, map)) + rows) + in + let magichecker map = + List.fold_left + (fun f (name, m) -> + let m_checker = compile_magic m in + (fun env ctors -> + match m_checker (Env.lookup_term env name) env ctors with + | None -> None + | Some (env, ctors) -> f env ctors)) + (fun env ctors -> Some (env, ctors)) + map + in + let magichooser candidates = + List.fold_left + (fun f (pid, pl, checker) -> + (fun matched_terms constructors -> + let env = env_of_matched pl matched_terms in + match checker env constructors with + | None -> f matched_terms constructors + | Some (env, ctors') -> + let magic_map = + try List.assoc pid magic_maps with Not_found -> assert false + in + let env' = Env.remove_names env (List.map fst magic_map) in + Some (env', ctors', pid))) + (fun _ _ -> None) + (List.rev candidates) + in + let match_cb rows = + let candidates = + List.map + (fun (pl, pid) -> + let magic_map = + try List.assoc pid magic_maps with Not_found -> assert false + in + pid, pl, magichecker magic_map) + rows + in + magichooser candidates + in + M.compiler rows' match_cb (fun _ -> None) + + and compile_magic = function + | Ast.Fold (kind, p_base, names, p_rec) -> + let p_rec_decls = Env.declarations_of_term p_rec in + (* LUCA: p_rec_decls should not contain "names" *) + let acc_name = try List.hd names with Failure _ -> assert false in + let compiled_base = compiler [p_base, 0] + and compiled_rec = compiler [p_rec, 0] in + (fun term env ctors -> + let aux_base term = + match compiled_base term with + | None -> None + | Some (env', ctors', _) -> Some (env', ctors', []) + in + let rec aux term = + match compiled_rec term with + | None -> aux_base term + | Some (env', ctors', _) -> + begin + let acc = Env.lookup_term env' acc_name in + let env'' = Env.remove_name env' acc_name in + match aux acc with + | None -> aux_base term + | Some (base_env, ctors', rec_envl) -> + let ctors'' = ctors' @ ctors in + Some (base_env, ctors'',env'' :: rec_envl) + end + in + match aux term with + | None -> None + | Some (base_env, ctors, rec_envl) -> + let env' = + base_env @ Env.coalesce_env p_rec_decls rec_envl @ env + (* @ env LUCA!!! *) + in + Some (env', ctors)) + + | Ast.Default (p_some, p_none) -> (* p_none can't bound names *) + let p_some_decls = Env.declarations_of_term p_some in + let p_none_decls = Env.declarations_of_term p_none in + let p_opt_decls = + List.filter + (fun decl -> not (List.mem decl p_none_decls)) + p_some_decls + in + let none_env = List.map Env.opt_binding_of_name p_opt_decls in + let compiled = compiler [p_some, 0] in + (fun term env ctors -> + match compiled term with + | None -> Some (none_env, ctors) (* LUCA: @ env ??? *) + | Some (env', ctors', 0) -> + let env' = + List.map + (fun (name, (ty, v)) as binding -> + if List.exists (fun (name', _) -> name = name') p_opt_decls + then Env.opt_binding_some binding + else binding) + env' + in + Some (env' @ env, ctors' @ ctors) + | _ -> assert false) + + | Ast.If (p_test, p_true, p_false) -> + let compiled_test = compiler [p_test, 0] + and compiled_true = compiler [p_true, 0] + and compiled_false = compiler [p_false, 0] in + (fun term env ctors -> + let branch = + match compiled_test term with + | None -> compiled_false + | Some _ -> compiled_true + in + match branch term with + | None -> None + | Some (env', ctors', _) -> Some (env' @ env, ctors' @ ctors)) + + | Ast.Fail -> (fun _ _ _ -> None) + + | _ -> assert false +end + diff --git a/helm/software/components/content_pres/content2presMatcher.mli b/helm/software/components/content_pres/content2presMatcher.mli new file mode 100644 index 000000000..86b97b6d8 --- /dev/null +++ b/helm/software/components/content_pres/content2presMatcher.mli @@ -0,0 +1,34 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +module Matcher21: +sig + (** @param l2_patterns level 2 (AST) patterns *) + val compiler : + (CicNotationPt.term * int) list -> + (CicNotationPt.term -> + (CicNotationEnv.t * CicNotationPt.term list * int) option) +end + diff --git a/helm/software/components/content_pres/mpresentation.ml b/helm/software/components/content_pres/mpresentation.ml new file mode 100644 index 000000000..1aa5db129 --- /dev/null +++ b/helm/software/components/content_pres/mpresentation.ml @@ -0,0 +1,258 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 16/62003 *) +(* *) +(**************************************************************************) + +(* $Id$ *) + +type 'a mpres = + Mi of attr * string + | Mn of attr * string + | Mo of attr * string + | Mtext of attr * string + | Mspace of attr + | Ms of attr * string + | Mgliph of attr * string + | Mrow of attr * 'a mpres list + | Mfrac of attr * 'a mpres * 'a mpres + | Msqrt of attr * 'a mpres + | Mroot of attr * 'a mpres * 'a mpres + | Mstyle of attr * 'a mpres + | Merror of attr * 'a mpres + | Mpadded of attr * 'a mpres + | Mphantom of attr * 'a mpres + | Mfenced of attr * 'a mpres list + | Menclose of attr * 'a mpres + | Msub of attr * 'a mpres * 'a mpres + | Msup of attr * 'a mpres * 'a mpres + | Msubsup of attr * 'a mpres * 'a mpres *'a mpres + | Munder of attr * 'a mpres * 'a mpres + | Mover of attr * 'a mpres * 'a mpres + | Munderover of attr * 'a mpres * 'a mpres *'a mpres +(* | Multiscripts of ??? NOT IMPLEMEMENTED *) + | Mtable of attr * 'a row list + | Maction of attr * 'a mpres list + | Mobject of attr * 'a +and 'a row = Mtr of attr * 'a mtd list +and 'a mtd = Mtd of attr * 'a mpres +and attr = (string option * string * string) list +;; + +let smallskip = Mspace([None,"width","0.5em"]);; +let indentation = Mspace([None,"width","1em"]);; + +let indented elem = + Mrow([],[indentation;elem]);; + +let standard_tbl_attr = + [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"] +;; + +let two_rows_table attr a b = + Mtable(attr@standard_tbl_attr, + [Mtr([],[Mtd([],a)]); + Mtr([],[Mtd([],b)])]);; + +let two_rows_table_with_brackets attr a b op = + (* only the open bracket is added; the closed bracket must be in b *) + Mtable(attr@standard_tbl_attr, + [Mtr([],[Mtd([],Mrow([],[Mtext([],"(");a]))]); + Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);; + +let two_rows_table_without_brackets attr a b op = + Mtable(attr@standard_tbl_attr, + [Mtr([],[Mtd([],a)]); + Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);; + +let row_with_brackets attr a b op = + (* by analogy with two_rows_table_with_brackets we only add the + open brackets *) + Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")]) + +let row_without_brackets attr a b op = + Mrow(attr,[a;op;b]) + +(* MathML prefix *) +let prefix = "m";; + +let print_mpres obj_printer mpres = + let module X = Xml in + let rec aux = + function + Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s) + | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s) + | Mo (attr,s) -> + let s = + let len = String.length s in + if len > 1 && s.[0] = '\\' + then String.sub s 1 (len - 1) + else s + in + X.xml_nempty ~prefix "mo" attr (X.xml_cdata s) + | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s) + | Mspace attr -> X.xml_empty ~prefix "mspace" attr + | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s) + | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s) + (* General Layout Schemata *) + | Mrow (attr,l) -> + X.xml_nempty ~prefix "mrow" attr + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) + >] + | Mfrac (attr,m1,m2) -> + X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >] + | Msqrt (attr,m) -> + X.xml_nempty ~prefix "msqrt" attr [< aux m >] + | Mroot (attr,m1,m2) -> + X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >] + | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >] + | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >] + | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >] + | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >] + | Mfenced (attr,l) -> + X.xml_nempty ~prefix "mfenced" attr + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) + >] + | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >] + (* Script and Limit Schemata *) + | Msub (attr,m1,m2) -> + X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >] + | Msup (attr,m1,m2) -> + X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >] + | Msubsup (attr,m1,m2,m3) -> + X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >] + | Munder (attr,m1,m2) -> + X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >] + | Mover (attr,m1,m2) -> + X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >] + | Munderover (attr,m1,m2,m3) -> + X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >] + (* | Multiscripts of ??? NOT IMPLEMEMENTED *) + (* Tables and Matrices *) + | Mtable (attr, rl) -> + X.xml_nempty ~prefix "mtable" attr + [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >] + (* Enlivening Expressions *) + | Maction (attr, l) -> + X.xml_nempty ~prefix "maction" attr + [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >] + | Mobject (attr, obj) -> + let box_stream = obj_printer obj in + X.xml_nempty ~prefix "semantics" attr + [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"] + box_stream >] + + and aux_mrow = + let module X = Xml in + function + Mtr (attr, l) -> + X.xml_nempty ~prefix "mtr" attr + [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>]) + >] + and aux_mtd = + let module X = Xml in + function + Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr + [< (aux m) ; + X.xml_nempty ~prefix "mphantom" [] + (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >] + in + aux mpres +;; + +let document_of_mpres pres = + [< Xml.xml_cdata "\n" ; + Xml.xml_cdata "\n"; + Xml.xml_nempty ~prefix "math" + [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ; + Some "xmlns","helm","http://www.cs.unibo.it/helm" ; + Some "xmlns","xlink","http://www.w3.org/1999/xlink" + ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None, + "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres)) + >] + +let get_attr = function + | Maction (attr, _) + | Menclose (attr, _) + | Merror (attr, _) + | Mfenced (attr, _) + | Mfrac (attr, _, _) + | Mgliph (attr, _) + | Mi (attr, _) + | Mn (attr, _) + | Mo (attr, _) + | Mobject (attr, _) + | Mover (attr, _, _) + | Mpadded (attr, _) + | Mphantom (attr, _) + | Mroot (attr, _, _) + | Mrow (attr, _) + | Ms (attr, _) + | Mspace attr + | Msqrt (attr, _) + | Mstyle (attr, _) + | Msub (attr, _, _) + | Msubsup (attr, _, _, _) + | Msup (attr, _, _) + | Mtable (attr, _) + | Mtext (attr, _) + | Munder (attr, _, _) + | Munderover (attr, _, _, _) -> + attr + +let set_attr attr = function + | Maction (_, x) -> Maction (attr, x) + | Menclose (_, x) -> Menclose (attr, x) + | Merror (_, x) -> Merror (attr, x) + | Mfenced (_, x) -> Mfenced (attr, x) + | Mfrac (_, x, y) -> Mfrac (attr, x, y) + | Mgliph (_, x) -> Mgliph (attr, x) + | Mi (_, x) -> Mi (attr, x) + | Mn (_, x) -> Mn (attr, x) + | Mo (_, x) -> Mo (attr, x) + | Mobject (_, x) -> Mobject (attr, x) + | Mover (_, x, y) -> Mover (attr, x, y) + | Mpadded (_, x) -> Mpadded (attr, x) + | Mphantom (_, x) -> Mphantom (attr, x) + | Mroot (_, x, y) -> Mroot (attr, x, y) + | Mrow (_, x) -> Mrow (attr, x) + | Ms (_, x) -> Ms (attr, x) + | Mspace _ -> Mspace attr + | Msqrt (_, x) -> Msqrt (attr, x) + | Mstyle (_, x) -> Mstyle (attr, x) + | Msub (_, x, y) -> Msub (attr, x, y) + | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z) + | Msup (_, x, y) -> Msup (attr, x, y) + | Mtable (_, x) -> Mtable (attr, x) + | Mtext (_, x) -> Mtext (attr, x) + | Munder (_, x, y) -> Munder (attr, x, y) + | Munderover (_, x, y, z) -> Munderover (attr, x, y, z) + diff --git a/helm/software/components/content_pres/mpresentation.mli b/helm/software/components/content_pres/mpresentation.mli new file mode 100644 index 000000000..8252517a6 --- /dev/null +++ b/helm/software/components/content_pres/mpresentation.mli @@ -0,0 +1,86 @@ +(* 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/. + *) + +type 'a mpres = + (* token elements *) + Mi of attr * string + | Mn of attr * string + | Mo of attr * string + | Mtext of attr * string + | Mspace of attr + | Ms of attr * string + | Mgliph of attr * string + (* General Layout Schemata *) + | Mrow of attr * 'a mpres list + | Mfrac of attr * 'a mpres * 'a mpres + | Msqrt of attr * 'a mpres + | Mroot of attr * 'a mpres * 'a mpres + | Mstyle of attr * 'a mpres + | Merror of attr * 'a mpres + | Mpadded of attr * 'a mpres + | Mphantom of attr * 'a mpres + | Mfenced of attr * 'a mpres list + | Menclose of attr * 'a mpres + (* Script and Limit Schemata *) + | Msub of attr * 'a mpres * 'a mpres + | Msup of attr * 'a mpres * 'a mpres + | Msubsup of attr * 'a mpres * 'a mpres *'a mpres + | Munder of attr * 'a mpres * 'a mpres + | Mover of attr * 'a mpres * 'a mpres + | Munderover of attr * 'a mpres * 'a mpres *'a mpres + (* Tables and Matrices *) + | Mtable of attr * 'a row list + (* Enlivening Expressions *) + | Maction of attr * 'a mpres list + (* Embedding *) + | Mobject of attr * 'a + +and 'a row = Mtr of attr * 'a mtd list + +and 'a mtd = Mtd of attr * 'a mpres + + (** XML attribute: namespace, name, value *) +and attr = (string option * string * string) list + +;; + +val get_attr: 'a mpres -> attr +val set_attr: attr -> 'a mpres -> 'a mpres + +val smallskip : 'a mpres +val indented : 'a mpres -> 'a mpres +val standard_tbl_attr : attr +val two_rows_table : attr -> 'a mpres -> 'a mpres -> 'a mpres +val two_rows_table_with_brackets : + attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres +val two_rows_table_without_brackets : + attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres +val row_with_brackets : + attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres +val row_without_brackets : + attr -> 'a mpres -> 'a mpres -> 'a mpres -> 'a mpres +val print_mpres : ('a -> Xml.token Stream.t) -> 'a mpres -> Xml.token Stream.t +val document_of_mpres : 'a mpres -> Xml.token Stream.t + diff --git a/helm/software/components/content_pres/renderingAttrs.ml b/helm/software/components/content_pres/renderingAttrs.ml new file mode 100644 index 000000000..256238d3d --- /dev/null +++ b/helm/software/components/content_pres/renderingAttrs.ml @@ -0,0 +1,54 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +type xml_attribute = string option * string * string +type markup = [ `MathML | `BoxML ] + +let color1 = "blue" +(* let color2 = "red" *) +let color2 = "blue" + +let keyword_attributes = function + | `MathML -> [ None, "mathcolor", color1 ] + | `BoxML -> [ None, "color", color1 ] + +let builtin_symbol_attributes = function + | `MathML -> [ None, "mathcolor", color1 ] + | `BoxML -> [ None, "color", color1 ] + +let object_keyword_attributes = function + | `MathML -> [ None, "mathcolor", color2 ] + | `BoxML -> [ None, "color", color2 ] + +let symbol_attributes _ = [] +let ident_attributes _ = [] +let number_attributes _ = [] + +let spacing_attributes _ = [ None, "spacing", "0.5em" ] +let indent_attributes _ = [ None, "indent", "0.5em" ] +let small_skip_attributes _ = [ None, "width", "0.5em" ] + diff --git a/helm/software/components/content_pres/renderingAttrs.mli b/helm/software/components/content_pres/renderingAttrs.mli new file mode 100644 index 000000000..64323598b --- /dev/null +++ b/helm/software/components/content_pres/renderingAttrs.mli @@ -0,0 +1,57 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(** XML attributes for MathML/BoxML rendering of terms and objects + * markup defaults to MathML in all functions below *) + +type xml_attribute = string option * string * string +type markup = [ `MathML | `BoxML ] + +(** High-level attributes *) + +val keyword_attributes: (* let, match, in, ... *) + markup -> xml_attribute list + +val builtin_symbol_attributes: (* \\Pi, \\to, ... *) + markup -> xml_attribute list + +val symbol_attributes: (* +, *, ... *) + markup -> xml_attribute list + +val ident_attributes: (* nat, plus, ... *) + markup -> xml_attribute list + +val number_attributes: (* 1, 2, ... *) + markup -> xml_attribute list + +val object_keyword_attributes: (* Body, Definition, ... *) + markup -> xml_attribute list + +(** Low-level attributes *) + +val spacing_attributes: markup -> xml_attribute list +val indent_attributes: markup -> xml_attribute list +val small_skip_attributes: markup -> xml_attribute list + diff --git a/helm/software/components/content_pres/sequent2pres.ml b/helm/software/components/content_pres/sequent2pres.ml new file mode 100644 index 000000000..88c804b7d --- /dev/null +++ b/helm/software/components/content_pres/sequent2pres.ml @@ -0,0 +1,106 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 19/11/2003 *) +(* *) +(***************************************************************************) + +(* $Id$ *) + +let p_mtr a b = Mpresentation.Mtr(a,b) +let p_mtd a b = Mpresentation.Mtd(a,b) +let p_mtable a b = Mpresentation.Mtable(a,b) +let p_mtext a b = Mpresentation.Mtext(a,b) +let p_mi a b = Mpresentation.Mi(a,b) +let p_mo a b = Mpresentation.Mo(a,b) +let p_mrow a b = Mpresentation.Mrow(a,b) +let p_mphantom a b = Mpresentation.Mphantom(a,b) +let b_ink a = Box.Ink a + +module K = Content +module P = Mpresentation + +let sequent2pres term2pres (_,_,context,ty) = + let context2pres context = + let rec aux accum = + function + [] -> accum + | None::tl -> aux accum tl + | (Some (`Declaration d))::tl -> + let + { K.dec_name = dec_name ; + K.dec_id = dec_id ; + K.dec_type = ty } = d in + let r = + Box.b_h [Some "helm", "xref", dec_id] + [ Box.b_object (p_mi [] + (match dec_name with + None -> "_" + | Some n -> n)) ; + Box.b_text [] ":" ; + term2pres ty] in + aux (r::accum) tl + | (Some (`Definition d))::tl -> + let + { K.def_name = def_name ; + K.def_id = def_id ; + K.def_term = bo } = d in + let r = + Box.b_h [Some "helm", "xref", def_id] + [ Box.b_object (p_mi [] + (match def_name with + None -> "_" + | Some n -> n)) ; + Box.b_text [] (Utf8Macro.unicode_of_tex "\\def") ; + term2pres bo] in + aux (r::accum) tl + | _::_ -> assert false in + aux [] context in + let pres_context = (Box.b_v [] (context2pres context)) in + let pres_goal = term2pres ty in + (Box.b_h [] [ + Box.b_space; + (Box.b_v [] + [Box.b_space; + pres_context; + b_ink [None,"width","4cm"; None,"height","2px"]; (* sequent line *) + Box.b_space; + pres_goal])]) + +let sequent2pres ~ids_to_inner_sorts = + sequent2pres + (fun annterm -> + let ast, ids_to_uris = + TermAcicContent.ast_of_acic ids_to_inner_sorts annterm + in + CicNotationPres.box_of_mpres + (CicNotationPres.render ids_to_uris + (TermContentPres.pp_ast ast))) + diff --git a/helm/software/components/content_pres/sequent2pres.mli b/helm/software/components/content_pres/sequent2pres.mli new file mode 100644 index 000000000..615c8e35f --- /dev/null +++ b/helm/software/components/content_pres/sequent2pres.mli @@ -0,0 +1,39 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 19/11/2003 *) +(* *) +(***************************************************************************) + +val sequent2pres : + ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> + Cic.annterm Content.conjecture -> + CicNotationPres.boxml_markup + diff --git a/helm/software/components/content_pres/termContentPres.ml b/helm/software/components/content_pres/termContentPres.ml new file mode 100644 index 000000000..4c8bbc7d4 --- /dev/null +++ b/helm/software/components/content_pres/termContentPres.ml @@ -0,0 +1,649 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt +module Env = CicNotationEnv + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) else () + +type pattern_id = int +type pretty_printer_id = pattern_id + +let resolve_binder = function + | `Lambda -> "\\lambda" + | `Pi -> "\\Pi" + | `Forall -> "\\forall" + | `Exists -> "\\exists" + +let add_level_info prec assoc t = Ast.AttributedTerm (`Level (prec, assoc), t) +let add_pos_info pos t = Ast.AttributedTerm (`ChildPos pos, t) +let left_pos = add_pos_info `Left +let right_pos = add_pos_info `Right +let inner_pos = add_pos_info `Inner + +let rec top_pos t = add_level_info ~-1 Gramext.NonA (inner_pos t) +(* function + | Ast.AttributedTerm (`Level _, t) -> + add_level_info ~-1 Gramext.NonA (inner_pos t) + | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, top_pos t) + | t -> add_level_info ~-1 Gramext.NonA (inner_pos t) *) + +let rec remove_level_info = + function + | Ast.AttributedTerm (`Level _, t) -> remove_level_info t + | Ast.AttributedTerm (a, t) -> Ast.AttributedTerm (a, remove_level_info t) + | t -> t + +let add_xml_attrs attrs t = + if attrs = [] then t else Ast.AttributedTerm (`XmlAttrs attrs, t) + +let add_keyword_attrs = + add_xml_attrs (RenderingAttrs.keyword_attributes `MathML) + +let box kind spacing indent content = + Ast.Layout (Ast.Box ((kind, spacing, indent), content)) + +let hbox = box Ast.H +let vbox = box Ast.V +let hvbox = box Ast.HV +let hovbox = box Ast.HOV +let break = Ast.Layout Ast.Break +let builtin_symbol s = Ast.Literal (`Symbol s) +let keyword k = add_keyword_attrs (Ast.Literal (`Keyword k)) + +let number s = + add_xml_attrs (RenderingAttrs.number_attributes `MathML) + (Ast.Literal (`Number s)) + +let ident i = + add_xml_attrs (RenderingAttrs.ident_attributes `MathML) (Ast.Ident (i, None)) + +let ident_w_href href i = + match href with + | None -> ident i + | Some href -> + let href = UriManager.string_of_uri href in + add_xml_attrs [Some "xlink", "href", href] (ident i) + +let binder_symbol s = + add_xml_attrs (RenderingAttrs.builtin_symbol_attributes `MathML) + (builtin_symbol s) + +let string_of_sort_kind = function + | `Prop -> "Prop" + | `Set -> "Set" + | `CProp -> "CProp" + | `Type _ -> "Type" + +let pp_ast0 t k = + let rec aux = + function + | Ast.Appl ts -> + let rec aux_args pos = + function + | [] -> [] + | [ last ] -> + let last = k last in + if pos = `Left then [ left_pos last ] else [ right_pos last ] + | hd :: tl -> + (add_pos_info pos (k hd)) :: aux_args `Inner tl + in + add_level_info Ast.apply_prec Ast.apply_assoc + (hovbox true true (CicNotationUtil.dress break (aux_args `Left ts))) + | Ast.Binder (binder_kind, (id, ty), body) -> + add_level_info Ast.binder_prec Ast.binder_assoc + (hvbox false true + [ binder_symbol (resolve_binder binder_kind); + k id; builtin_symbol ":"; aux_ty ty; break; + builtin_symbol "."; right_pos (k body) ]) + | Ast.Case (what, indty_opt, outty_opt, patterns) -> + let outty_box = + match outty_opt with + | None -> [] + | Some outty -> + [ keyword "return"; break; remove_level_info (k outty)] + in + let indty_box = + match indty_opt with + | None -> [] + | Some (indty, href) -> [ keyword "in"; break; ident_w_href href indty ] + in + let match_box = + hvbox false false [ + hvbox false true [ + hvbox false true [ keyword "match"; break; top_pos (k what) ]; + break; + hvbox false true indty_box; + break; + hvbox false true outty_box + ]; + break; + keyword "with" + ] + in + let mk_case_pattern (head, href, vars) = + hbox true false (ident_w_href href head :: List.map aux_var vars) + in + let patterns' = + List.map + (fun (lhs, rhs) -> + remove_level_info + (hvbox false true [ + hbox false true [ + mk_case_pattern lhs; builtin_symbol "\\Rightarrow" ]; + break; top_pos (k rhs) ])) + patterns + in + let patterns'' = + let rec aux_patterns = function + | [] -> assert false + | [ last ] -> + [ break; + hbox false false [ + builtin_symbol "|"; + last; builtin_symbol "]" ] ] + | hd :: tl -> + [ break; hbox false false [ builtin_symbol "|"; hd ] ] + @ aux_patterns tl + in + match patterns' with + | [] -> + [ hbox false false [ builtin_symbol "["; builtin_symbol "]" ] ] + | [ one ] -> + [ hbox false false [ + builtin_symbol "["; one; builtin_symbol "]" ] ] + | hd :: tl -> + hbox false false [ builtin_symbol "["; hd ] + :: aux_patterns tl + in + add_level_info Ast.simple_prec Ast.simple_assoc + (hvbox false false [ + hvbox false false ([match_box]); break; + hbox false false [ hvbox false false patterns'' ] ]) + | Ast.Cast (bo, ty) -> + add_level_info Ast.simple_prec Ast.simple_assoc + (hvbox false true [ + builtin_symbol "("; top_pos (k bo); break; builtin_symbol ":"; + top_pos (k ty); builtin_symbol ")"]) + | Ast.LetIn (var, s, t) -> + add_level_info Ast.let_in_prec Ast.let_in_assoc + (hvbox false true [ + hvbox false true [ + keyword "let"; + hvbox false true [ + aux_var var; builtin_symbol "\\def"; break; top_pos (k s) ]; + break; keyword "in" ]; + break; + k t ]) + | Ast.LetRec (rec_kind, funs, where) -> + let rec_op = + match rec_kind with `Inductive -> "rec" | `CoInductive -> "corec" + in + let mk_fun (var, body, _) = aux_var var, k body in + let mk_funs = List.map mk_fun in + let fst_fun, tl_funs = + match mk_funs funs with hd :: tl -> hd, tl | [] -> assert false + in + let fst_row = + let (name, body) = fst_fun in + hvbox false true [ + keyword "let"; keyword rec_op; name; builtin_symbol "\\def"; break; + top_pos body ] + in + let tl_rows = + List.map + (fun (name, body) -> + [ break; + hvbox false true [ + keyword "and"; name; builtin_symbol "\\def"; break; body ] ]) + tl_funs + in + add_level_info Ast.let_in_prec Ast.let_in_assoc + ((hvbox false false + (fst_row :: List.flatten tl_rows + @ [ break; keyword "in"; break; k where ]))) + | Ast.Implicit -> builtin_symbol "?" + | Ast.Meta (n, l) -> + let local_context l = + CicNotationUtil.dress (builtin_symbol ";") + (List.map (function None -> builtin_symbol "_" | Some t -> k t) l) + in + hbox false false + ([ builtin_symbol "?"; number (string_of_int n) ] + @ (if l <> [] then local_context l else [])) + | Ast.Sort sort -> aux_sort sort + | Ast.Num _ + | Ast.Symbol _ + | Ast.Ident (_, None) | Ast.Ident (_, Some []) + | Ast.Uri (_, None) | Ast.Uri (_, Some []) + | Ast.Literal _ + | Ast.UserInput as leaf -> leaf + | t -> CicNotationUtil.visit_ast ~special_k k t + and aux_sort sort_kind = + add_xml_attrs (RenderingAttrs.keyword_attributes `MathML) + (Ast.Ident (string_of_sort_kind sort_kind, None)) + and aux_ty = function + | None -> builtin_symbol "?" + | Some ty -> k ty + and aux_var = function + | name, Some ty -> + hvbox false true [ + builtin_symbol "("; name; builtin_symbol ":"; break; k ty; + builtin_symbol ")" ] + | name, None -> name + and special_k = function + | Ast.AttributedTerm (attrs, t) -> Ast.AttributedTerm (attrs, k t) + | t -> + prerr_endline ("unexpected special: " ^ CicNotationPp.pp_term t); + assert false + in + aux t + + (* persistent state *) + +let level1_patterns21 = Hashtbl.create 211 + +let compiled21 = ref None + +let pattern21_matrix = ref [] + +let get_compiled21 () = + match !compiled21 with + | None -> assert false + | Some f -> Lazy.force f + +let set_compiled21 f = compiled21 := Some f + +let add_idrefs = + List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t)) + +let instantiate21 idrefs env l1 = + let rec subst_singleton pos env = + function + Ast.AttributedTerm (attr, t) -> + Ast.AttributedTerm (attr, subst_singleton pos env t) + | t -> CicNotationUtil.group (subst pos env t) + and subst pos env = function + | Ast.AttributedTerm (attr, t) -> +(* prerr_endline ("loosing attribute " ^ CicNotationPp.pp_attribute attr); *) + subst pos env t + | Ast.Variable var -> + let name, expected_ty = CicNotationEnv.declaration_of_var var in + let ty, value = + try + List.assoc name env + with Not_found -> + prerr_endline ("name " ^ name ^ " not found in environment"); + assert false + in + assert (CicNotationEnv.well_typed ty value); (* INVARIANT *) + (* following assertion should be a conditional that makes this + * instantiation fail *) + assert (CicNotationEnv.well_typed expected_ty value); + [ add_pos_info pos (CicNotationEnv.term_of_value value) ] + | Ast.Magic m -> subst_magic pos env m + | Ast.Literal l as t -> + let t = add_idrefs idrefs t in + (match l with + | `Keyword k -> [ add_keyword_attrs t ] + | _ -> [ t ]) + | Ast.Layout l -> [ Ast.Layout (subst_layout pos env l) ] + | t -> [ CicNotationUtil.visit_ast (subst_singleton pos env) t ] + and subst_magic pos env = function + | Ast.List0 (p, sep_opt) + | Ast.List1 (p, sep_opt) -> + let rec_decls = CicNotationEnv.declarations_of_term p in + let rec_values = + List.map (fun (n, _) -> CicNotationEnv.lookup_list env n) rec_decls + in + let values = CicNotationUtil.ncombine rec_values in + let sep = + match sep_opt with + | None -> [] + | Some l -> [ Ast.Literal l ] + in + let rec instantiate_list acc = function + | [] -> List.rev acc + | value_set :: [] -> + let env = CicNotationEnv.combine rec_decls value_set in + instantiate_list (CicNotationUtil.group (subst pos env p) :: acc) + [] + | value_set :: tl -> + let env = CicNotationEnv.combine rec_decls value_set in + let terms = subst pos env p in + instantiate_list (CicNotationUtil.group (terms @ sep) :: acc) tl + in + instantiate_list [] values + | Ast.Opt p -> + let opt_decls = CicNotationEnv.declarations_of_term p in + let env = + let rec build_env = function + | [] -> [] + | (name, ty) :: tl -> + (* assumption: if one of the value is None then all are *) + (match CicNotationEnv.lookup_opt env name with + | None -> raise Exit + | Some v -> (name, (ty, v)) :: build_env tl) + in + try build_env opt_decls with Exit -> [] + in + begin + match env with + | [] -> [] + | _ -> subst pos env p + end + | _ -> assert false (* impossible *) + and subst_layout pos env = function + | Ast.Box (kind, tl) -> + let tl' = subst_children pos env tl in + Ast.Box (kind, List.concat tl') + | l -> CicNotationUtil.visit_layout (subst_singleton pos env) l + and subst_children pos env = + function + | [] -> [] + | [ child ] -> + let pos' = + match pos with + | `Inner -> `Right + | `Left -> `Left +(* | `None -> assert false *) + | `Right -> `Right + in + [ subst pos' env child ] + | hd :: tl -> + let pos' = + match pos with + | `Inner -> `Inner + | `Left -> `Inner +(* | `None -> assert false *) + | `Right -> `Right + in + (subst pos env hd) :: subst_children pos' env tl + in + subst_singleton `Left env l1 + +let rec pp_ast1 term = + let rec pp_value = function + | CicNotationEnv.NumValue _ as v -> v + | CicNotationEnv.StringValue _ as v -> v +(* | CicNotationEnv.TermValue t when t == term -> CicNotationEnv.TermValue (pp_ast0 t pp_ast1) *) + | CicNotationEnv.TermValue t -> CicNotationEnv.TermValue (pp_ast1 t) + | CicNotationEnv.OptValue None as v -> v + | CicNotationEnv.OptValue (Some v) -> + CicNotationEnv.OptValue (Some (pp_value v)) + | CicNotationEnv.ListValue vl -> + CicNotationEnv.ListValue (List.map pp_value vl) + in + let ast_env_of_env env = + List.map (fun (var, (ty, value)) -> (var, (ty, pp_value value))) env + in +(* prerr_endline ("pattern matching from 2 to 1 on term " ^ CicNotationPp.pp_term term); *) + match term with + | Ast.AttributedTerm (attrs, term') -> + Ast.AttributedTerm (attrs, pp_ast1 term') + | _ -> + (match (get_compiled21 ()) term with + | None -> pp_ast0 term pp_ast1 + | Some (env, ctors, pid) -> + let idrefs = + List.flatten (List.map CicNotationUtil.get_idrefs ctors) + in + let l1 = + try + Hashtbl.find level1_patterns21 pid + with Not_found -> assert false + in + instantiate21 idrefs (ast_env_of_env env) l1) + +let load_patterns21 t = + set_compiled21 (lazy (Content2presMatcher.Matcher21.compiler t)) + +let pp_ast ast = + debug_print (lazy "pp_ast <-"); + let ast' = pp_ast1 ast in + debug_print (lazy ("pp_ast -> " ^ CicNotationPp.pp_term ast')); + ast' + +exception Pretty_printer_not_found + +let fill_pos_info l1_pattern = l1_pattern +(* let rec aux toplevel pos = + function + | Ast.Layout l -> + (match l + + | Ast.Magic m -> + Ast.Box ( + | Ast.Variable _ as t -> add_pos_info pos t + | t -> t + in + aux true l1_pattern *) + +let fresh_id = + let counter = ref ~-1 in + fun () -> + incr counter; + !counter + +let add_pretty_printer ~precedence ~associativity l2 l1 = + let id = fresh_id () in + let l1' = add_level_info precedence associativity (fill_pos_info l1) in + let l2' = CicNotationUtil.strip_attributes l2 in + Hashtbl.add level1_patterns21 id l1'; + pattern21_matrix := (l2', id) :: !pattern21_matrix; + load_patterns21 !pattern21_matrix; + id + +let remove_pretty_printer id = + (try + Hashtbl.remove level1_patterns21 id; + with Not_found -> raise Pretty_printer_not_found); + pattern21_matrix := List.filter (fun (_, id') -> id <> id') !pattern21_matrix; + load_patterns21 !pattern21_matrix + + (* presentation -> content *) + +let unopt_names names env = + let rec aux acc = function + | (name, (ty, v)) :: tl when List.mem name names -> + (match ty, v with + | Env.OptType ty, Env.OptValue (Some v) -> + aux ((name, (ty, v)) :: acc) tl + | _ -> assert false) + | hd :: tl -> aux (hd :: acc) tl + | [] -> acc + in + aux [] env + +let head_names names env = + let rec aux acc = function + | (name, (ty, v)) :: tl when List.mem name names -> + (match ty, v with + | Env.ListType ty, Env.ListValue (v :: _) -> + aux ((name, (ty, v)) :: acc) tl + | _ -> assert false) + | _ :: tl -> aux acc tl + (* base pattern may contain only meta names, thus we trash all others *) + | [] -> acc + in + aux [] env + +let tail_names names env = + let rec aux acc = function + | (name, (ty, v)) :: tl when List.mem name names -> + (match ty, v with + | Env.ListType ty, Env.ListValue (_ :: vtl) -> + aux ((name, (Env.ListType ty, Env.ListValue vtl)) :: acc) tl + | _ -> assert false) + | binding :: tl -> aux (binding :: acc) tl + | [] -> acc + in + aux [] env + +let instantiate_level2 env term = + let fresh_env = ref [] in + let lookup_fresh_name n = + try + List.assoc n !fresh_env + with Not_found -> + let new_name = CicNotationUtil.fresh_name () in + fresh_env := (n, new_name) :: !fresh_env; + new_name + in + let rec aux env term = +(* prerr_endline ("ENV " ^ CicNotationPp.pp_env env); *) + match term with + | Ast.AttributedTerm (_, term) -> aux env term + | Ast.Appl terms -> Ast.Appl (List.map (aux env) terms) + | Ast.Binder (binder, var, body) -> + Ast.Binder (binder, aux_capture_var env var, aux env body) + | Ast.Case (term, indty, outty_opt, patterns) -> + Ast.Case (aux env term, indty, aux_opt env outty_opt, + List.map (aux_branch env) patterns) + | Ast.LetIn (var, t1, t2) -> + Ast.LetIn (aux_capture_var env var, aux env t1, aux env t2) + | Ast.LetRec (kind, definitions, body) -> + Ast.LetRec (kind, List.map (aux_definition env) definitions, + aux env body) + | Ast.Uri (name, None) -> Ast.Uri (name, None) + | Ast.Uri (name, Some substs) -> + Ast.Uri (name, Some (aux_substs env substs)) + | Ast.Ident (name, Some substs) -> + Ast.Ident (name, Some (aux_substs env substs)) + | Ast.Meta (index, substs) -> Ast.Meta (index, aux_meta_substs env substs) + + | Ast.Implicit + | Ast.Ident _ + | Ast.Num _ + | Ast.Sort _ + | Ast.Symbol _ + | Ast.UserInput -> term + + | Ast.Magic magic -> aux_magic env magic + | Ast.Variable var -> aux_variable env var + + | _ -> assert false + and aux_opt env = function + | Some term -> Some (aux env term) + | None -> None + and aux_capture_var env (name, ty_opt) = (aux env name, aux_opt env ty_opt) + and aux_branch env (pattern, term) = + (aux_pattern env pattern, aux env term) + and aux_pattern env (head, hrefs, vars) = + (head, hrefs, List.map (aux_capture_var env) vars) + and aux_definition env (var, term, i) = + (aux_capture_var env var, aux env term, i) + and aux_substs env substs = + List.map (fun (name, term) -> (name, aux env term)) substs + and aux_meta_substs env meta_substs = List.map (aux_opt env) meta_substs + and aux_variable env = function + | Ast.NumVar name -> Ast.Num (Env.lookup_num env name, 0) + | Ast.IdentVar name -> Ast.Ident (Env.lookup_string env name, None) + | Ast.TermVar name -> Env.lookup_term env name + | Ast.FreshVar name -> Ast.Ident (lookup_fresh_name name, None) + | Ast.Ascription (term, name) -> assert false + and aux_magic env = function + | Ast.Default (some_pattern, none_pattern) -> + let some_pattern_names = CicNotationUtil.names_of_term some_pattern in + let none_pattern_names = CicNotationUtil.names_of_term none_pattern in + let opt_names = + List.filter + (fun name -> not (List.mem name none_pattern_names)) + some_pattern_names + in + (match opt_names with + | [] -> assert false (* some pattern must contain at least 1 name *) + | (name :: _) as names -> + (match Env.lookup_value env name with + | Env.OptValue (Some _) -> + (* assumption: if "name" above is bound to Some _, then all + * names returned by "meta_names_of" are bound to Some _ as well + *) + aux (unopt_names names env) some_pattern + | Env.OptValue None -> aux env none_pattern + | _ -> + prerr_endline (sprintf + "lookup of %s in env %s did not return an optional value" + name (CicNotationPp.pp_env env)); + assert false)) + | Ast.Fold (`Left, base_pattern, names, rec_pattern) -> + let acc_name = List.hd names in (* names can't be empty, cfr. parser *) + let meta_names = + List.filter ((<>) acc_name) + (CicNotationUtil.names_of_term rec_pattern) + in + (match meta_names with + | [] -> assert false (* as above *) + | (name :: _) as names -> + let rec instantiate_fold_left acc env' = + match Env.lookup_value env' name with + | Env.ListValue (_ :: _) -> + instantiate_fold_left + (let acc_binding = + acc_name, (Env.TermType, Env.TermValue acc) + in + aux (acc_binding :: head_names names env') rec_pattern) + (tail_names names env') + | Env.ListValue [] -> acc + | _ -> assert false + in + instantiate_fold_left (aux env base_pattern) env) + | Ast.Fold (`Right, base_pattern, names, rec_pattern) -> + let acc_name = List.hd names in (* names can't be empty, cfr. parser *) + let meta_names = + List.filter ((<>) acc_name) + (CicNotationUtil.names_of_term rec_pattern) + in + (match meta_names with + | [] -> assert false (* as above *) + | (name :: _) as names -> + let rec instantiate_fold_right env' = + match Env.lookup_value env' name with + | Env.ListValue (_ :: _) -> + let acc = instantiate_fold_right (tail_names names env') in + let acc_binding = + acc_name, (Env.TermType, Env.TermValue acc) + in + aux (acc_binding :: head_names names env') rec_pattern + | Env.ListValue [] -> aux env base_pattern + | _ -> assert false + in + instantiate_fold_right env) + | Ast.If (_, p_true, p_false) as t -> + aux env (CicNotationUtil.find_branch (Ast.Magic t)) + | Ast.Fail -> assert false + | _ -> assert false + in + aux env term + + (* initialization *) + +let _ = load_patterns21 [] + diff --git a/helm/software/components/content_pres/termContentPres.mli b/helm/software/components/content_pres/termContentPres.mli new file mode 100644 index 000000000..5ff710036 --- /dev/null +++ b/helm/software/components/content_pres/termContentPres.mli @@ -0,0 +1,52 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + + (** {2 Persistant state handling} *) + +type pretty_printer_id + +val add_pretty_printer: + precedence:int -> + associativity:Gramext.g_assoc -> + CicNotationPt.term -> (* level 2 pattern *) + CicNotationPt.term -> (* level 1 pattern *) + pretty_printer_id + +exception Pretty_printer_not_found + + (** @raise Pretty_printer_not_found *) +val remove_pretty_printer: pretty_printer_id -> unit + + (** {2 content -> pres} *) + +val pp_ast: CicNotationPt.term -> CicNotationPt.term + + (** {2 pres -> content} *) + + (** fills a term pattern instantiating variable magics *) +val instantiate_level2: + CicNotationEnv.t -> CicNotationPt.term -> + CicNotationPt.term + diff --git a/helm/software/components/content_pres/test_lexer.ml b/helm/software/components/content_pres/test_lexer.ml new file mode 100644 index 000000000..b032d7f61 --- /dev/null +++ b/helm/software/components/content_pres/test_lexer.ml @@ -0,0 +1,60 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let _ = + let level = ref "2@" in + let ic = ref stdin in + let arg_spec = [ "-level", Arg.Set_string level, "set the notation level" ] in + let usage = "test_lexer [ -level level ] [ file ]" in + let open_file fname = + if !ic <> stdin then close_in !ic; + ic := open_in fname + in + Arg.parse arg_spec open_file usage; + let lexer = + match !level with + "1" -> CicNotationLexer.level1_pattern_lexer + | "2@" -> CicNotationLexer.level2_ast_lexer + | "2$" -> CicNotationLexer.level2_meta_lexer + | l -> + prerr_endline (Printf.sprintf "Unsupported level %s" l); + exit 2 + in + let token_stream = + fst (lexer.Token.tok_func (Obj.magic (Ulexing.from_utf8_channel !ic))) + in + Printf.printf "Lexing notation level %s\n" !level; flush stdout; + let rec dump () = + let (a,b) = Stream.next token_stream in + if a = "EOI" then raise Stream.Failure; + print_endline (Printf.sprintf "%s '%s'" a b); + dump () + in + try + dump () + with Stream.Failure -> () + diff --git a/helm/software/components/extlib/.depend b/helm/software/components/extlib/.depend new file mode 100644 index 000000000..e2c9fc2b8 --- /dev/null +++ b/helm/software/components/extlib/.depend @@ -0,0 +1,12 @@ +componentsConf.cmo: componentsConf.cmi +componentsConf.cmx: componentsConf.cmi +hExtlib.cmo: componentsConf.cmi hExtlib.cmi +hExtlib.cmx: componentsConf.cmx hExtlib.cmi +hMarshal.cmo: hExtlib.cmi hMarshal.cmi +hMarshal.cmx: hExtlib.cmx hMarshal.cmi +patternMatcher.cmo: patternMatcher.cmi +patternMatcher.cmx: patternMatcher.cmi +hLog.cmo: hLog.cmi +hLog.cmx: hLog.cmi +trie.cmo: trie.cmi +trie.cmx: trie.cmi diff --git a/helm/software/components/extlib/Makefile b/helm/software/components/extlib/Makefile new file mode 100644 index 000000000..4e5c9b5a9 --- /dev/null +++ b/helm/software/components/extlib/Makefile @@ -0,0 +1,18 @@ +PACKAGE = extlib +PREDICATES = + +INTERFACE_FILES = \ + componentsConf.mli \ + hExtlib.mli \ + hMarshal.mli \ + patternMatcher.mli \ + hLog.mli \ + trie.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/extlib/componentsConf.ml.in b/helm/software/components/extlib/componentsConf.ml.in new file mode 100644 index 000000000..528e90a1c --- /dev/null +++ b/helm/software/components/extlib/componentsConf.ml.in @@ -0,0 +1,28 @@ +(* Copyright (C) 2006, 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://helm.cs.unibo.it/ + *) + +let debug = @DEBUG@ +let profiling = debug + diff --git a/helm/software/components/extlib/componentsConf.mli b/helm/software/components/extlib/componentsConf.mli new file mode 100644 index 000000000..79462bbf4 --- /dev/null +++ b/helm/software/components/extlib/componentsConf.mli @@ -0,0 +1,28 @@ +(* Copyright (C) 2006, 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://helm.cs.unibo.it/ + *) + +val debug: bool +val profiling: bool + diff --git a/helm/software/components/extlib/hExtlib.ml b/helm/software/components/extlib/hExtlib.ml new file mode 100644 index 000000000..5f96e0f84 --- /dev/null +++ b/helm/software/components/extlib/hExtlib.ml @@ -0,0 +1,344 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +(** PROFILING *) + +let profiling_enabled = ComponentsConf.profiling + +let profiling_printings = ref (fun () -> true) +let set_profiling_printings f = profiling_printings := f + +type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b } +let profile ?(enable = true) = + if profiling_enabled && enable then + function s -> + let total = ref 0.0 in + let profile f x = + let before = Unix.gettimeofday () in + try + let res = f x in + let after = Unix.gettimeofday () in + total := !total +. (after -. before); + res + with + exc -> + let after = Unix.gettimeofday () in + total := !total +. (after -. before); + raise exc + in + at_exit + (fun () -> + if !profiling_printings () then + prerr_endline + ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total)); + { profile = profile } + else + function _ -> { profile = fun f x -> f x } + +(** {2 Optional values} *) + +let map_option f = function None -> None | Some v -> Some (f v) +let iter_option f = function None -> () | Some v -> f v +let unopt = function None -> failwith "unopt: None" | Some v -> v + +(** {2 String processing} *) + +let split ?(sep = ' ') s = + let pieces = ref [] in + let rec aux idx = + match (try Some (String.index_from s idx sep) with Not_found -> None) with + | Some pos -> + pieces := String.sub s idx (pos - idx) :: !pieces; + aux (pos + 1) + | None -> pieces := String.sub s idx (String.length s - idx) :: !pieces + in + aux 0; + List.rev !pieces + +let trim_blanks s = + let rec find_left idx = + match s.[idx] with + | ' ' | '\t' | '\r' | '\n' -> find_left (idx + 1) + | _ -> idx + in + let rec find_right idx = + match s.[idx] with + | ' ' | '\t' | '\r' | '\n' -> find_right (idx - 1) + | _ -> idx + in + let s_len = String.length s in + let left, right = find_left 0, find_right (s_len - 1) in + String.sub s left (right - left + 1) + +(** {2 Char processing} *) + +let is_alpha c = + let code = Char.code c in + (code >= 65 && code <= 90) || (code >= 97 && code <= 122) + +let is_digit c = + let code = Char.code c in + code >= 48 && code <= 57 + +let is_blank c = + let code = Char.code c in + code = 9 || code = 10 || code = 13 || code = 32 + +let is_alphanum c = is_alpha c || is_digit c + +(** {2 List processing} *) + +let rec list_uniq ?(eq=(=)) = function + | [] -> [] + | h::[] -> [h] + | h1::h2::tl when eq h1 h2 -> list_uniq ~eq (h2 :: tl) + | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq ~eq tl + +let rec filter_map f = + function + | [] -> [] + | hd :: tl -> + (match f hd with + | None -> filter_map f tl + | Some v -> v :: filter_map f tl) + +let list_concat ?(sep = []) = + let rec aux acc = + function + | [] -> [] + | [ last ] -> List.flatten (List.rev (last :: acc)) + | hd :: tl -> aux ([sep; hd] @ acc) tl + in + aux [] + +let rec list_findopt f l = + let rec aux = function + | [] -> None + | x::tl -> + (match f x with + | None -> aux tl + | Some _ as rc -> rc) + in + aux l + +(** {2 File predicates} *) + +let is_dir fname = + try + (Unix.stat fname).Unix.st_kind = Unix.S_DIR + with Unix.Unix_error _ -> false + +let is_regular fname = + try + (Unix.stat fname).Unix.st_kind = Unix.S_REG + with Unix.Unix_error _ -> false + +let mkdir path = + let components = split ~sep:'/' path in + let rec aux where = function + | [] -> () + | piece::tl -> + let path = + if where = "" then piece else where ^ "/" ^ piece in + (try + Unix.mkdir path 0o755 + with + | Unix.Unix_error (Unix.EEXIST,_,_) -> () + | Unix.Unix_error (e,_,_) -> + raise + (Failure + ("Unix.mkdir " ^ path ^ " 0o755 :" ^ (Unix.error_message e)))); + aux path tl + in + let where = if path.[0] = '/' then "/" else "" in + aux where components + +(** {2 Filesystem} *) + +let input_file fname = + let size = (Unix.stat fname).Unix.st_size in + let buf = Buffer.create size in + let ic = open_in fname in + Buffer.add_channel buf ic size; + close_in ic; + Buffer.contents buf + +let input_all ic = + let size = 10240 in + let buf = Buffer.create size in + let s = String.create size in + (try + while true do + let bytes = input ic s 0 size in + if bytes = 0 then raise End_of_file + else Buffer.add_substring buf s 0 bytes + done + with End_of_file -> ()); + Buffer.contents buf + +let output_file ~filename ~text = + let oc = open_out filename in + output_string oc text; + close_out oc + +let blank_split s = + let len = String.length s in + let buf = Buffer.create 0 in + let rec aux acc i = + if i >= len + then begin + if Buffer.length buf > 0 + then List.rev (Buffer.contents buf :: acc) + else List.rev acc + end else begin + if is_blank s.[i] then + if Buffer.length buf > 0 then begin + let s = Buffer.contents buf in + Buffer.clear buf; + aux (s :: acc) (i + 1) + end else + aux acc (i + 1) + else begin + Buffer.add_char buf s.[i]; + aux acc (i + 1) + end + end + in + aux [] 0 + + (* Rules: * "~name" -> home dir of "name" + * "~" -> value of $HOME if defined, home dir of the current user otherwise *) +let tilde_expand s = + let get_home login = (Unix.getpwnam login).Unix.pw_dir in + let expand_one s = + let len = String.length s in + if len > 0 && s.[0] = '~' then begin + let login_len = ref 1 in + while !login_len < len && is_alphanum (s.[!login_len]) do + incr login_len + done; + let login = String.sub s 1 (!login_len - 1) in + try + let home = + if login = "" then + try Sys.getenv "HOME" with Not_found -> get_home (Unix.getlogin ()) + else + get_home login + in + home ^ String.sub s !login_len (len - !login_len) + with Not_found | Invalid_argument _ -> s + end else + s + in + String.concat " " (List.map expand_one (blank_split s)) + +let find ?(test = fun _ -> true) path = + let rec aux acc todo = + match todo with + | [] -> acc + | path :: tl -> + try + let handle = Unix.opendir path in + let dirs = ref [] in + let matching_files = ref [] in + (try + while true do + match Unix.readdir handle with + | "." | ".." -> () + | entry -> + let qentry = path ^ "/" ^ entry in + (try + if is_dir qentry then + dirs := qentry :: !dirs + else if test qentry then + matching_files := qentry :: !matching_files; + with Unix.Unix_error _ -> ()) + done + with End_of_file -> Unix.closedir handle); + aux (!matching_files @ acc) (!dirs @ tl) + with Unix.Unix_error _ -> aux acc tl + in + aux [] [path] + +let safe_remove fname = if Sys.file_exists fname then Sys.remove fname + +let is_dir_empty d = + let od = Unix.opendir d in + let rec aux () = + let name = Unix.readdir od in + if name <> "." && name <> ".." then false else aux () in + let res = try aux () with End_of_file -> true in + Unix.closedir od; + res + +let safe_rmdir d = try Unix.rmdir d with Unix.Unix_error _ -> () + +let rec rmdir_descend d = + if is_dir_empty d then + begin + safe_rmdir d; + rmdir_descend (Filename.dirname d) + end + + +(** {2 Exception handling} *) + +let finally at_end f arg = + let res = + try f arg + with exn -> at_end (); raise exn + in + at_end (); + res + +(** {2 Localized exceptions } *) + +exception Localized of Token.flocation * exn + +let loc_of_floc = function + | { Lexing.pos_cnum = loc_begin }, { Lexing.pos_cnum = loc_end } -> + (loc_begin, loc_end) + +let floc_of_loc (loc_begin, loc_end) = + let floc_begin = + { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1; + Lexing.pos_cnum = loc_begin } + in + let floc_end = { floc_begin with Lexing.pos_cnum = loc_end } in + (floc_begin, floc_end) + +let dummy_floc = floc_of_loc (-1, -1) + +let raise_localized_exception ~offset floc exn = + let (x, y) = loc_of_floc floc in + let x = offset + x in + let y = offset + y in + let flocb,floce = floc in + let floc = + { flocb with Lexing.pos_cnum = x }, { floce with Lexing.pos_cnum = y } + in + raise (Localized (floc, exn)) diff --git a/helm/software/components/extlib/hExtlib.mli b/helm/software/components/extlib/hExtlib.mli new file mode 100644 index 000000000..aed9b2406 --- /dev/null +++ b/helm/software/components/extlib/hExtlib.mli @@ -0,0 +1,95 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(** {2 Optional values} *) + +val map_option: ('a -> 'b) -> 'a option -> 'b option +val iter_option: ('a -> unit) -> 'a option -> unit +val unopt: 'a option -> 'a (** @raise Failure *) + +(** {2 Filesystem} *) + +val is_dir: string -> bool (** @return true if file is a directory *) +val is_regular: string -> bool (** @return true if file is a regular file *) +val mkdir: string -> unit (** create dir and parents. @raise Failure *) +val tilde_expand: string -> string (** bash-like (head) tilde expansion *) +val safe_remove: string -> unit (** removes a file if it exists *) +val safe_rmdir: string -> unit (** removes a dir if it exists and is empty *) +val is_dir_empty: string -> bool (** checks if the dir is empty *) +val rmdir_descend: string -> unit (** rmdir -p *) + + + (** find all _files_ matching test under a filesystem root *) +val find: ?test:(string -> bool) -> string -> string list + +(** {2 File I/O} *) + +val input_file: string -> string (** read all the contents of file to string *) +val input_all: in_channel -> string (** read all the contents of a channel *) +val output_file: filename:string -> text:string -> unit (** other way round *) + +(** {2 Exception handling} *) + +val finally: (unit -> unit) -> ('a -> 'b) -> 'a -> 'b + +(** {2 Char processing} *) + +val is_alpha: char -> bool +val is_blank: char -> bool +val is_digit: char -> bool +val is_alphanum: char -> bool (** is_alpha || is_digit *) + +(** {2 String processing} *) + +val split: ?sep:char -> string -> string list (** @param sep defaults to ' ' *) +val trim_blanks: string -> string (** strip heading and trailing blanks *) + +(** {2 List processing} *) + +val list_uniq: + ?eq:('a->'a->bool) -> 'a list -> 'a list (** uniq unix filter on lists *) +val filter_map: ('a -> 'b option) -> 'a list -> 'b list (** filter + map *) +val list_concat: ?sep:'a list -> 'a list list -> 'a list (**String.concat-like*) +val list_findopt: ('a -> 'b option) -> 'a list -> 'b option + +(** {2 Debugging & Profiling} *) + +type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b } + + (** @return a profiling function; [s] is used for labelling the total time at + * the end of the execution *) +val profile : ?enable:bool -> string -> profiler +val set_profiling_printings : (unit -> bool) -> unit + +(** {2 Localized exceptions } *) + +exception Localized of Token.flocation * exn + +val loc_of_floc: Token.flocation -> int * int +val floc_of_loc: int * int -> Token.flocation + +val dummy_floc: Lexing.position * Lexing.position + +val raise_localized_exception: offset:int -> Token.flocation -> exn -> 'a diff --git a/helm/software/components/extlib/hLog.ml b/helm/software/components/extlib/hLog.ml new file mode 100644 index 000000000..4ad2b5ba4 --- /dev/null +++ b/helm/software/components/extlib/hLog.ml @@ -0,0 +1,64 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +type log_tag = [ `Debug | `Error | `Message | `Warning ] +type log_callback = log_tag -> string -> unit + +(* +colors=(black red green yellow blue magenta cyan gray white) +ccodes=(30 31 32 33 34 35 36 37 39) +*) + +let blue = "" +let yellow = "" +let green = "" +let red = "" +let black = "" + +let default_callback tag s = + let prefix,ch = + match tag with + | `Message -> green ^ "Info: ", stdout + | `Warning -> yellow ^ "Warn: ", stderr + | `Error -> red ^ "Error: ", stderr + | `Debug -> blue ^ "Debug: ", stderr + in + output_string ch (prefix ^ black ^ s ^ "\n"); + flush ch + +let callback = ref default_callback + +let set_log_callback f = callback := f +let get_log_callback () = !callback + +let message s = !callback `Message s +let warn s = !callback `Warning s +let error s = !callback `Error s +let debug s = !callback `Debug s + diff --git a/helm/software/components/extlib/hLog.mli b/helm/software/components/extlib/hLog.mli new file mode 100644 index 000000000..6847ce32d --- /dev/null +++ b/helm/software/components/extlib/hLog.mli @@ -0,0 +1,36 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +type log_tag = [ `Debug | `Error | `Message | `Warning ] +type log_callback = log_tag -> string -> unit + +val set_log_callback: log_callback -> unit +val get_log_callback: unit -> log_callback + +val message : string -> unit +val warn : string -> unit +val error : string -> unit +val debug : string -> unit + diff --git a/helm/software/components/extlib/hMarshal.ml b/helm/software/components/extlib/hMarshal.ml new file mode 100644 index 000000000..c57886819 --- /dev/null +++ b/helm/software/components/extlib/hMarshal.ml @@ -0,0 +1,72 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception Corrupt_file of string +exception Format_mismatch of string +exception Version_mismatch of string + +let ensure_path_exists fname = HExtlib.mkdir (Filename.dirname fname) +let marshal_flags = [] + +let save ~fmt ~version ~fname data = + ensure_path_exists fname; + let oc = open_out fname in + let marshalled = Marshal.to_string data marshal_flags in + output_binary_int oc (Hashtbl.hash fmt); (* field 1 *) + output_binary_int oc version; (* field 2 *) + output_string oc fmt; (* field 3 *) + output_string oc (string_of_int version); (* field 4 *) + output_binary_int oc (Hashtbl.hash marshalled); (* field 5 *) + output_string oc marshalled; (* field 6 *) + close_out oc + +let expect ic fname s = + let len = String.length s in + let buf = String.create len in + really_input ic buf 0 len; + if buf <> s then raise (Corrupt_file fname) + +let load ~fmt ~version ~fname = + let ic = open_in fname in + HExtlib.finally + (fun () -> close_in ic) + (fun () -> + try + let fmt' = input_binary_int ic in (* field 1 *) + if fmt' <> Hashtbl.hash fmt then raise (Format_mismatch fname); + let version' = input_binary_int ic in (* field 2 *) + if version' <> version then raise (Version_mismatch fname); + expect ic fname fmt; (* field 3 *) + expect ic fname (string_of_int version); (* field 4 *) + let checksum' = input_binary_int ic in (* field 5 *) + let marshalled' = HExtlib.input_all ic in (* field 6 *) + if checksum' <> Hashtbl.hash marshalled' then + raise (Corrupt_file fname); + Marshal.from_string marshalled' 0 + with End_of_file -> raise (Corrupt_file fname)) + () + diff --git a/helm/software/components/extlib/hMarshal.mli b/helm/software/components/extlib/hMarshal.mli new file mode 100644 index 000000000..90ce20def --- /dev/null +++ b/helm/software/components/extlib/hMarshal.mli @@ -0,0 +1,59 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(** {2 Marshalling with version/consistency checks} *) + +(** {3 File formats} + * + * Files saved/loaded by this module share a common format: + * + * | n | Field name | Field type | Description | + * +---+-------------+------------+---------------------------------------+ + * | 1 | format | integer | hash value of the 'fmt' parameter | + * | 2 | version | integer | 'version' parameter | + * | 3 | format dsc | string | extended 'fmt' parameter | + * | 4 | version dsc | string | extended 'version' parameter | + * | 5 | checksum | integer | hash value of the _field_ below | + * | 6 | data | raw | ocaml marshalling of 'data' parameter | + * + *) + +exception Corrupt_file of string (** checksum mismatch, or file too short *) +exception Format_mismatch of string +exception Version_mismatch of string + + (** Marhsal some data according to the file format above. + * @param fmt format name + * @param version version number + * @param fname file name to which marshal data + * @param data data to be marshalled on disk *) +val save: fmt:string -> version:int -> fname:string -> 'a -> unit + + (** parameters as above + * @raise Corrupt_file + * @raise Format_mismatch + * @raise Version_mismatch *) +val load: fmt:string -> version:int -> fname:string -> 'a + diff --git a/helm/software/components/extlib/patternMatcher.ml b/helm/software/components/extlib/patternMatcher.ml new file mode 100644 index 000000000..c1b436a97 --- /dev/null +++ b/helm/software/components/extlib/patternMatcher.ml @@ -0,0 +1,191 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +type pattern_kind = Variable | Constructor +type tag_t = int + +type pattern_id = int + +module OrderedInt = +struct + type t = int + let compare (x1:t) (x2:t) = Pervasives.compare x2 x1 (* reverse order *) +end + +module IntSet = Set.Make (OrderedInt) + +let int_set_of_int_list l = + List.fold_left (fun acc i -> IntSet.add i acc) IntSet.empty l + +module type PATTERN = +sig + type pattern_t + type term_t + val classify : pattern_t -> pattern_kind + val tag_of_pattern : pattern_t -> tag_t * pattern_t list + val tag_of_term : term_t -> tag_t * term_t list + val string_of_term: term_t -> string + val string_of_pattern: pattern_t -> string +end + +module Matcher (P: PATTERN) = +struct + type row_t = P.pattern_t list * P.pattern_t list * pattern_id + type t = row_t list + + let compatible p1 p2 = P.classify p1 = P.classify p2 + + let matched = List.map (fun (matched, _, pid) -> matched, pid) + + let partition t pidl = + let partitions = Hashtbl.create 11 in + let add pid row = Hashtbl.add partitions pid row in + (try + List.iter2 add pidl t + with Invalid_argument _ -> assert false); + let pidset = int_set_of_int_list pidl in + IntSet.fold + (fun pid acc -> + match Hashtbl.find_all partitions pid with + | [] -> acc + | patterns -> (pid, List.rev patterns) :: acc) + pidset [] + + let are_empty t = + match t with + | (_, [], _) :: _ -> true + (* if first row has an empty list of patterns, then others have as well *) + | _ -> false + + (* return 2 lists of rows, first one containing homogeneous rows according + * to "compatible" below *) + let horizontal_split t = + let ap, first_row, t', first_row_class = + match t with + | [] -> assert false + | (_, [], _) :: _ -> + assert false (* are_empty should have been invoked in advance *) + | ((_, hd :: _ , _) as row) :: tl -> hd, row, tl, P.classify hd + in + let rec aux prev_t = function + | [] -> List.rev prev_t, [] + | (_, [], _) :: _ -> assert false + | ((_, hd :: _, _) as row) :: tl when compatible ap hd -> + aux (row :: prev_t) tl + | t -> List.rev prev_t, t + in + let rows1, rows2 = aux [first_row] t' in + first_row_class, rows1, rows2 + + (* return 2 lists, first one representing first column, second one + * representing a new pattern matrix where matched patterns have been moved + * to decl *) + let vertical_split t = + List.map + (function + | decls, hd :: tl, pid -> hd :: decls, tl, pid + | _ -> assert false) + t + + let variable_closure ksucc = + (fun matched_terms constructors terms -> +(* prerr_endline "variable_closure"; *) + match terms with + | hd :: tl -> ksucc (hd :: matched_terms) constructors tl + | _ -> assert false) + + let success_closure ksucc = + (fun matched_terms constructors terms -> +(* prerr_endline "success_closure"; *) + ksucc matched_terms constructors) + + let constructor_closure ksuccs = + (fun matched_terms constructors terms -> +(* prerr_endline "constructor_closure"; *) + match terms with + | t :: tl -> + (try + let tag, subterms = P.tag_of_term t in + let constructors' = + if subterms = [] then t :: constructors else constructors + in + let k' = List.assoc tag ksuccs in + k' matched_terms constructors' (subterms @ tl) + with Not_found -> None) + | [] -> assert false) + + let backtrack_closure ksucc kfail = + (fun matched_terms constructors terms -> +(* prerr_endline "backtrack_closure"; *) + match ksucc matched_terms constructors terms with + | Some x -> Some x + | None -> kfail matched_terms constructors terms) + + let compiler rows match_cb fail_k = + let rec aux t = + if t = [] then + (fun _ _ _ -> fail_k ()) + else if are_empty t then + success_closure (match_cb (matched t)) + else + match horizontal_split t with + | _, [], _ -> assert false + | Variable, t', [] -> variable_closure (aux (vertical_split t')) + | Constructor, t', [] -> + let tagl = + List.map + (function + | _, p :: _, _ -> fst (P.tag_of_pattern p) + | _ -> assert false) + t' + in + let clusters = partition t' tagl in + let ksuccs = + List.map + (fun (tag, cluster) -> + let cluster' = + List.map (* add args as patterns heads *) + (function + | matched_p, p :: tl, pid -> + let _, subpatterns = P.tag_of_pattern p in + matched_p, subpatterns @ tl, pid + | _ -> assert false) + cluster + in + tag, aux cluster') + clusters + in + constructor_closure ksuccs + | _, t', t'' -> backtrack_closure (aux t') (aux t'') + in + let t = List.map (fun (p, pid) -> [], [p], pid) rows in + let matcher = aux t in + (fun term -> matcher [] [] [term]) +end + diff --git a/helm/software/components/extlib/patternMatcher.mli b/helm/software/components/extlib/patternMatcher.mli new file mode 100644 index 000000000..2201ddf7f --- /dev/null +++ b/helm/software/components/extlib/patternMatcher.mli @@ -0,0 +1,62 @@ + +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +type pattern_kind = Variable | Constructor +type tag_t = int + +module type PATTERN = +sig + type pattern_t + type term_t + + val classify : pattern_t -> pattern_kind + val tag_of_pattern : pattern_t -> tag_t * pattern_t list + val tag_of_term : term_t -> tag_t * term_t list + + (** {3 Debugging} *) + val string_of_term: term_t -> string + val string_of_pattern: pattern_t -> string +end + +module Matcher (P: PATTERN) : +sig + (** @param patterns pattern matrix (pairs ) + * @param success_cb callback invoked in case of matching. + * Its argument are the list of pattern who matches the input term, the list + * of terms bound in them, the list of terms which matched constructors. + * Its return value is Some _ if the matching is valid, None otherwise; the + * latter kind of return value will trigger backtracking in the pattern + * matching algorithm + * @param failure_cb callback invoked in case of matching failure + * @param term term on which pattern match on *) + val compiler: + (P.pattern_t * int) list -> + ((P.pattern_t list * int) list -> P.term_t list -> P.term_t list -> + 'a option) -> (* terms *) (* constructors *) + (unit -> 'a option) -> + (P.term_t -> 'a option) +end + diff --git a/helm/software/components/extlib/trie.ml b/helm/software/components/extlib/trie.ml new file mode 100644 index 000000000..f60b2d45c --- /dev/null +++ b/helm/software/components/extlib/trie.ml @@ -0,0 +1,153 @@ +(* + * Trie: maps over lists. + * Copyright (C) 2000 Jean-Christophe FILLIATRE + * + * This software is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License version 2, as published by the Free Software Foundation. + * + * This software 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 Library General Public License version 2 for more details + * (enclosed in the file LGPL). + *) + +(* $Id$ *) + +(*s A trie is a tree-like structure to implement dictionaries over + keys which have list-like structures. The idea is that each node + branches on an element of the list and stores the value associated + to the path from the root, if any. Therefore, a trie can be + defined as soon as a map over the elements of the list is + given. *) + + +module Make (M : Map.S) = struct + +(*s Then a trie is just a tree-like structure, where a possible + information is stored at the node (['a option]) and where the sons + are given by a map from type [key] to sub-tries, so of type + ['a t M.t]. The empty trie is just the empty map. *) + + type key = M.key list + + type 'a t = Node of 'a option * 'a t M.t + + let empty = Node (None, M.empty) + +(*s To find a mapping in a trie is easy: when all the elements of the + key have been read, we just inspect the optional info at the + current node; otherwise, we descend in the appropriate sub-trie + using [M.find]. *) + + let rec find l t = match (l,t) with + | [], Node (None,_) -> raise Not_found + | [], Node (Some v,_) -> v + | x::r, Node (_,m) -> find r (M.find x m) + + let rec mem l t = match (l,t) with + | [], Node (None,_) -> false + | [], Node (Some _,_) -> true + | x::r, Node (_,m) -> try mem r (M.find x m) with Not_found -> false + +(*s Insertion is more subtle. When the final node is reached, we just + put the information ([Some v]). Otherwise, we have to insert the + binding in the appropriate sub-trie [t']. But it may not exists, + and in that case [t'] is bound to an empty trie. Then we get a new + sub-trie [t''] by a recursive insertion and we modify the + branching, so that it now points to [t''], with [M.add]. *) + + let add l v t = + let rec ins = function + | [], Node (_,m) -> Node (Some v,m) + | x::r, Node (v,m) -> + let t' = try M.find x m with Not_found -> empty in + let t'' = ins (r,t') in + Node (v, M.add x t'' m) + in + ins (l,t) + +(*s When removing a binding, we take care of not leaving bindings to empty + sub-tries in the nodes. Therefore, we test wether the result [t'] of + the recursive call is the empty trie [empty]: if so, we just remove + the branching with [M.remove]; otherwise, we modify it with [M.add]. *) + + let rec remove l t = match (l,t) with + | [], Node (_,m) -> Node (None,m) + | x::r, Node (v,m) -> + try + let t' = remove r (M.find x m) in + Node (v, if t' = empty then M.remove x m else M.add x t' m) + with Not_found -> + t + +(*s The iterators [map], [mapi], [iter] and [fold] are implemented in + a straigthforward way using the corresponding iterators [M.map], + [M.mapi], [M.iter] and [M.fold]. For the last three of them, + we have to remember the path from the root, as an extra argument + [revp]. Since elements are pushed in reverse order in [revp], + we have to reverse it with [List.rev] when the actual binding + has to be passed to function [f]. *) + + let rec map f = function + | Node (None,m) -> Node (None, M.map (map f) m) + | Node (Some v,m) -> Node (Some (f v), M.map (map f) m) + + let mapi f t = + let rec maprec revp = function + | Node (None,m) -> + Node (None, M.mapi (fun x -> maprec (x::revp)) m) + | Node (Some v,m) -> + Node (Some (f (List.rev revp) v), M.mapi (fun x -> maprec (x::revp)) m) + in + maprec [] t + + let iter f t = + let rec traverse revp = function + | Node (None,m) -> + M.iter (fun x -> traverse (x::revp)) m + | Node (Some v,m) -> + f (List.rev revp) v; M.iter (fun x t -> traverse (x::revp) t) m + in + traverse [] t + + let rec fold f t acc = + let rec traverse revp t acc = match t with + | Node (None,m) -> + M.fold (fun x -> traverse (x::revp)) m acc + | Node (Some v,m) -> + f (List.rev revp) v (M.fold (fun x -> traverse (x::revp)) m acc) + in + traverse [] t acc + + let compare cmp a b = + let rec comp a b = match a,b with + | Node (Some _, _), Node (None, _) -> 1 + | Node (None, _), Node (Some _, _) -> -1 + | Node (None, m1), Node (None, m2) -> + M.compare comp m1 m2 + | Node (Some a, m1), Node (Some b, m2) -> + let c = cmp a b in + if c <> 0 then c else M.compare comp m1 m2 + in + comp a b + + let equal eq a b = + let rec comp a b = match a,b with + | Node (None, m1), Node (None, m2) -> + M.equal comp m1 m2 + | Node (Some a, m1), Node (Some b, m2) -> + eq a b && M.equal comp m1 m2 + | _ -> + false + in + comp a b + + (* The base case is rather stupid, but constructable *) + let is_empty = function + | Node (None, m1) -> M.is_empty m1 + | _ -> false + +end diff --git a/helm/software/components/extlib/trie.mli b/helm/software/components/extlib/trie.mli new file mode 100644 index 000000000..b95157fd0 --- /dev/null +++ b/helm/software/components/extlib/trie.mli @@ -0,0 +1,43 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +module Make : + functor (M : Map.S) -> + sig + type key = M.key list + type 'a t = Node of 'a option * 'a t M.t + val empty : 'a t + val find : M.key list -> 'a t -> 'a + val mem : M.key list -> 'a t -> bool + val add : M.key list -> 'a -> 'a t -> 'a t + val remove : M.key list -> 'a t -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (M.key list -> 'a -> 'b) -> 'a t -> 'b t + val iter : (M.key list -> 'a -> 'b) -> 'a t -> unit + val fold : (M.key list -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val is_empty : 'a t -> bool + end diff --git a/helm/software/components/getter/.depend b/helm/software/components/getter/.depend new file mode 100644 index 000000000..20f69cf0c --- /dev/null +++ b/helm/software/components/getter/.depend @@ -0,0 +1,31 @@ +http_getter_env.cmi: http_getter_types.cmo +http_getter_common.cmi: http_getter_types.cmo +http_getter.cmi: http_getter_types.cmo +http_getter_wget.cmo: http_getter_types.cmo http_getter_wget.cmi +http_getter_wget.cmx: http_getter_types.cmx http_getter_wget.cmi +http_getter_logger.cmo: http_getter_logger.cmi +http_getter_logger.cmx: http_getter_logger.cmi +http_getter_misc.cmo: http_getter_logger.cmi http_getter_misc.cmi +http_getter_misc.cmx: http_getter_logger.cmx http_getter_misc.cmi +http_getter_const.cmo: http_getter_const.cmi +http_getter_const.cmx: http_getter_const.cmi +http_getter_env.cmo: http_getter_types.cmo http_getter_misc.cmi \ + http_getter_logger.cmi http_getter_const.cmi http_getter_env.cmi +http_getter_env.cmx: http_getter_types.cmx http_getter_misc.cmx \ + http_getter_logger.cmx http_getter_const.cmx http_getter_env.cmi +http_getter_storage.cmo: http_getter_wget.cmi http_getter_types.cmo \ + http_getter_misc.cmi http_getter_env.cmi http_getter_storage.cmi +http_getter_storage.cmx: http_getter_wget.cmx http_getter_types.cmx \ + http_getter_misc.cmx http_getter_env.cmx http_getter_storage.cmi +http_getter_common.cmo: http_getter_types.cmo http_getter_misc.cmi \ + http_getter_logger.cmi http_getter_env.cmi http_getter_common.cmi +http_getter_common.cmx: http_getter_types.cmx http_getter_misc.cmx \ + http_getter_logger.cmx http_getter_env.cmx http_getter_common.cmi +http_getter.cmo: http_getter_wget.cmi http_getter_types.cmo \ + http_getter_storage.cmi http_getter_misc.cmi http_getter_logger.cmi \ + http_getter_env.cmi http_getter_const.cmi http_getter_common.cmi \ + http_getter.cmi +http_getter.cmx: http_getter_wget.cmx http_getter_types.cmx \ + http_getter_storage.cmx http_getter_misc.cmx http_getter_logger.cmx \ + http_getter_env.cmx http_getter_const.cmx http_getter_common.cmx \ + http_getter.cmi diff --git a/helm/software/components/getter/.ocamlinit b/helm/software/components/getter/.ocamlinit new file mode 100644 index 000000000..6512190cd --- /dev/null +++ b/helm/software/components/getter/.ocamlinit @@ -0,0 +1,3 @@ +#use "topfind";; +#require "helm-getter";; +Helm_registry.load_from "sample.conf.xml";; diff --git a/helm/software/components/getter/Makefile b/helm/software/components/getter/Makefile new file mode 100644 index 000000000..0f2132eec --- /dev/null +++ b/helm/software/components/getter/Makefile @@ -0,0 +1,21 @@ + +PACKAGE = getter + +INTERFACE_FILES = \ + http_getter_wget.mli \ + http_getter_logger.mli \ + http_getter_misc.mli \ + http_getter_const.mli \ + http_getter_env.mli \ + http_getter_storage.mli \ + http_getter_common.mli \ + http_getter.mli \ + $(NULL) + +IMPLEMENTATION_FILES = \ + http_getter_types.ml \ + $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common + diff --git a/helm/software/components/getter/http_getter.ml b/helm/software/components/getter/http_getter.ml new file mode 100644 index 000000000..1b47a6c38 --- /dev/null +++ b/helm/software/components/getter/http_getter.ml @@ -0,0 +1,363 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open Http_getter_common +open Http_getter_misc +open Http_getter_types + +exception Not_implemented of string +exception UnexpectedGetterOutput + +type resolve_result = + | Unknown + | Exception of exn + | Resolved of string + +type logger_callback = HelmLogger.html_tag -> unit + +let stdout_logger tag = print_string (HelmLogger.string_of_html_tag tag) + +let not_implemented s = raise (Not_implemented ("Http_getter." ^ s)) + +let index_line_sep_RE = Pcre.regexp "[ \t]+" +let index_sep_RE = Pcre.regexp "\r\n|\r|\n" +let trailing_types_RE = Pcre.regexp "\\.types$" +let heading_cic_RE = Pcre.regexp "^cic:" +let heading_theory_RE = Pcre.regexp "^theory:" +let heading_nuprl_RE = Pcre.regexp "^nuprl:" +let types_RE = Pcre.regexp "\\.types$" +let types_ann_RE = Pcre.regexp "\\.types\\.ann$" +let body_RE = Pcre.regexp "\\.body$" +let body_ann_RE = Pcre.regexp "\\.body\\.ann$" +let proof_tree_RE = Pcre.regexp "\\.proof_tree$" +let proof_tree_ann_RE = Pcre.regexp "\\.proof_tree\\.ann$" +let theory_RE = Pcre.regexp "\\.theory$" +let basepart_RE = Pcre.regexp + "^([^.]*\\.[^.]*)((\\.body)|(\\.proof_tree)|(\\.types))?(\\.ann)?$" +let slash_RE = Pcre.regexp "/" +let pipe_RE = Pcre.regexp "\\|" +let til_slash_RE = Pcre.regexp "^.*/" +let no_slashes_RE = Pcre.regexp "^[^/]*$" +let fix_regexp_RE = Pcre.regexp ("^" ^ (Pcre.quote "(cic|theory)")) +let showable_file_RE = + Pcre.regexp "(\\.con|\\.ind|\\.var|\\.body|\\.types|\\.proof_tree)$" + +let xml_suffix = ".xml" +let theory_suffix = ".theory" + + (* global maps, shared by all threads *) + +let ends_with_slash s = + try + s.[String.length s - 1] = '/' + with Invalid_argument _ -> false + + (* should we use a remote getter or not *) +let remote () = + try + Helm_registry.get "getter.mode" = "remote" + with Helm_registry.Key_not_found _ -> false + +let getter_url () = Helm_registry.get "getter.url" + +(* Remote interface: getter methods implemented using a remote getter *) + + (* *) +let getxml_remote uri = not_implemented "getxml_remote" +let getxslt_remote uri = not_implemented "getxslt_remote" +let getdtd_remote uri = not_implemented "getdtd_remote" +let clean_cache_remote () = not_implemented "clean_cache_remote" +let list_servers_remote () = not_implemented "list_servers_remote" +let add_server_remote ~logger ~position name = + not_implemented "add_server_remote" +let remove_server_remote ~logger position = + not_implemented "remove_server_remote" +let getalluris_remote () = not_implemented "getalluris_remote" +let ls_remote lsuri = not_implemented "ls_remote" +let exists_remote uri = not_implemented "exists_remote" + (* *) + +let resolve_remote uri = + (* deliver resolve request to http_getter *) + let doc = + Http_getter_wget.get (sprintf "%sresolve?uri=%s" (getter_url ()) uri) + in + let res = ref Unknown in + let start_element tag attrs = + match tag with + | "url" -> + (try + res := Resolved (List.assoc "value" attrs) + with Not_found -> ()) + | "unresolvable" -> res := Exception (Unresolvable_URI uri) + | "not_found" -> res := Exception (Key_not_found uri) + | _ -> () + in + let callbacks = { + XmlPushParser.default_callbacks with + XmlPushParser.start_element = Some start_element + } in + let xml_parser = XmlPushParser.create_parser callbacks in + XmlPushParser.parse xml_parser (`String doc); + XmlPushParser.final xml_parser; + match !res with + | Unknown -> raise UnexpectedGetterOutput + | Exception e -> raise e + | Resolved url -> url + +let deref_index_theory uri = + if Http_getter_storage.exists (uri ^ xml_suffix) then uri + else if is_theory_uri uri && Filename.basename uri = "index.theory" then + strip_trailing_slash (Filename.dirname uri) ^ theory_suffix + else + uri + +(* API *) + +let help () = Http_getter_const.usage_string (Http_getter_env.env_to_string ()) + +let exists uri = +(* prerr_endline ("Http_getter.exists " ^ uri); *) + if remote () then + exists_remote uri + else + let uri = deref_index_theory uri in + Http_getter_storage.exists (uri ^ xml_suffix) + +let resolve uri = + if remote () then + resolve_remote uri + else + let uri = deref_index_theory uri in + try + Http_getter_storage.resolve (uri ^ xml_suffix) + with Http_getter_storage.Resource_not_found _ -> raise (Key_not_found uri) + +let getxml uri = + if remote () then getxml_remote uri + else begin + let uri' = deref_index_theory uri in + (try + Http_getter_storage.filename (uri' ^ xml_suffix) + with Http_getter_storage.Resource_not_found _ -> raise (Key_not_found uri)) + end + +let getxslt uri = + if remote () then getxslt_remote uri + else Http_getter_storage.filename ~find:true ("xslt:/" ^ uri) + +let getdtd uri = + if remote () then + getdtd_remote uri + else begin + let fname = Http_getter_env.get_dtd_dir () ^ "/" ^ uri in + if not (Sys.file_exists fname) then raise (Dtd_not_found uri); + fname + end + +let clean_cache () = + if remote () then + clean_cache_remote () + else + Http_getter_storage.clean_cache () + +let (++) (oldann, oldtypes, oldbody, oldtree) + (newann, newtypes, newbody, newtree) = + ((if newann > oldann then newann else oldann), + (if newtypes > oldtypes then newtypes else oldtypes), + (if newbody > oldbody then newbody else oldbody), + (if newtree > oldtree then newtree else oldtree)) + +let store_obj tbl o = +(* prerr_endline ("Http_getter.store_obj " ^ o); *) + if Pcre.pmatch ~rex:showable_file_RE o then begin + let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in + let no_flags = false, No, No, No in + let oldflags = + try + Hashtbl.find tbl basepart + with Not_found -> (* no ann, no types, no body, no proof tree *) + no_flags + in + let newflags = + match o with + | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No, No) + | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No, No) + | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes, No) + | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann, No) + | s when Pcre.pmatch ~rex:proof_tree_RE s -> (false, No, No, Yes) + | s when Pcre.pmatch ~rex:proof_tree_ann_RE s -> (true, No, No, Ann) + | s -> no_flags + in + Hashtbl.replace tbl basepart (oldflags ++ newflags) + end + +let store_dir set_ref d = + set_ref := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !set_ref + +let collect_ls_items dirs_set objs_tbl = + let items = ref [] in + StringSet.iter (fun dir -> items := Ls_section dir :: !items) dirs_set; + Http_getter_misc.hashtbl_sorted_iter + (fun uri (annflag, typesflag, bodyflag, treeflag) -> + items := + Ls_object { + uri = uri; ann = annflag; + types = typesflag; body = bodyflag; proof_tree = treeflag + } :: !items) + objs_tbl; + List.rev !items + +let contains_object = (<>) [] + + (** non regexp-aware version of ls *) +let rec dumb_ls uri_prefix = +(* prerr_endline ("Http_getter.dumb_ls " ^ uri_prefix); *) + if is_cic_obj_uri uri_prefix then begin + let dirs = ref StringSet.empty in + let objs = Hashtbl.create 17 in + List.iter + (fun fname -> + if ends_with_slash fname then + store_dir dirs fname + else + try + store_obj objs (strip_suffix ~suffix:xml_suffix fname) + with Invalid_argument _ -> ()) + (Http_getter_storage.ls uri_prefix); + collect_ls_items !dirs objs + end else if is_theory_uri uri_prefix then begin + let items = ref [] in + let add_theory fname = + items := + Ls_object { + uri = fname; ann = false; types = No; body = No; proof_tree = No } + :: !items + in + let cic_uri_prefix = + Pcre.replace_first ~rex:heading_theory_RE ~templ:"cic:" uri_prefix + in + List.iter + (fun fname -> + if ends_with_slash fname then + items := Ls_section (strip_trailing_slash fname) :: !items + else + try + let fname = strip_suffix ~suffix:xml_suffix fname in + let theory_name = strip_suffix ~suffix:theory_suffix fname in + let sub_theory = normalize_dir cic_uri_prefix ^ theory_name ^ "/" in + if is_empty_theory sub_theory then add_theory fname + with Invalid_argument _ -> ()) + (Http_getter_storage.ls uri_prefix); + (try + if contains_object (dumb_ls cic_uri_prefix) + && exists (strip_trailing_slash uri_prefix ^ theory_suffix) + then + add_theory "index.theory"; + with Unresolvable_URI _ -> ()); + !items + end else + raise (Invalid_URI uri_prefix) + +and is_empty_theory uri_prefix = +(* prerr_endline ("is_empty_theory " ^ uri_prefix); *) + not (contains_object (dumb_ls uri_prefix)) + + (* handle simple regular expressions of the form "...(..|..|..)..." on cic + * uris, not meant to be a real implementation of regexp. The only we use is + * "(cic|theory):/..." *) +let explode_ls_regexp regexp = + try + let len = String.length regexp in + let lparen_idx = String.index regexp '(' in + let rparen_idx = String.index_from regexp lparen_idx ')' in + let choices_str = (* substring between parens, parens excluded *) + String.sub regexp (lparen_idx + 1) (rparen_idx - lparen_idx - 1) + in + let choices = Pcre.split ~rex:pipe_RE choices_str in + let prefix = String.sub regexp 0 lparen_idx in + let suffix = String.sub regexp (rparen_idx + 1) (len - (rparen_idx + 1)) in + List.map (fun choice -> prefix ^ choice ^ suffix) choices + with Not_found -> [regexp] + +let merge_results results = + let rec aux objects_acc dirs_acc = function + | [] -> dirs_acc @ objects_acc + | Ls_object _ as obj :: tl -> aux (obj :: objects_acc) dirs_acc tl + | Ls_section _ as dir :: tl -> + if List.mem dir dirs_acc then (* filters out dir duplicates *) + aux objects_acc dirs_acc tl + else + aux objects_acc (dir :: dirs_acc) tl + in + aux [] [] (List.concat results) + +let ls regexp = + if remote () then + ls_remote regexp + else + let prefixes = explode_ls_regexp regexp in + merge_results (List.map dumb_ls prefixes) + +let getalluris () = + let rec aux acc = function + | [] -> acc + | dir :: todo -> + let acc', todo' = + List.fold_left + (fun (acc, subdirs) result -> + match result with + | Ls_object obj -> (dir ^ obj.uri) :: acc, subdirs + | Ls_section sect -> acc, (dir ^ sect ^ "/") :: subdirs) + (acc, todo) + (dumb_ls dir) + in + aux acc' todo' + in + aux [] ["cic:/"] (* trailing slash required *) + +(* Shorthands from now on *) + +let getxml' uri = getxml (UriManager.string_of_uri uri) +let resolve' uri = resolve (UriManager.string_of_uri uri) +let exists' uri = exists (UriManager.string_of_uri uri) + +let tilde_expand_key k = + try + Helm_registry.set k (HExtlib.tilde_expand (Helm_registry.get k)) + with Helm_registry.Key_not_found _ -> () + +let init () = + List.iter tilde_expand_key ["getter.cache_dir"; "getter.dtd_dir"]; + Http_getter_logger.set_log_level + (Helm_registry.get_opt_default Helm_registry.int ~default:1 + "getter.log_level"); + Http_getter_logger.set_log_file + (Helm_registry.get_opt Helm_registry.string "getter.log_file") + diff --git a/helm/software/components/getter/http_getter.mli b/helm/software/components/getter/http_getter.mli new file mode 100644 index 000000000..4bbc447bd --- /dev/null +++ b/helm/software/components/getter/http_getter.mli @@ -0,0 +1,66 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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 Http_getter_types + + (** {2 Loggers} *) + +type logger_callback = HelmLogger.html_tag -> unit + +val stdout_logger: logger_callback + + (** {2 Getter Web Service interface as API *) + +val help: unit -> string + + (** @raise Http_getter_types.Unresolvable_URI _ + * @raise Http_getter_types.Key_not_found _ *) +val resolve: string -> string (* uri -> url *) + +val exists: string -> bool + +val getxml : string -> string +val getxslt : string -> string +val getdtd : string -> string +val clean_cache: unit -> unit +val getalluris: unit -> string list + + (** @param baseuri uri to be listed, simple form or regular expressions (a + * single choice among parens) are permitted *) +val ls: string -> ls_item list + + (** {2 UriManager shorthands} *) + +val getxml' : UriManager.uri -> string +val resolve' : UriManager.uri -> string +val exists' : UriManager.uri -> bool + + (** {2 Misc} *) + +val init: unit -> unit + diff --git a/helm/software/components/getter/http_getter_common.ml b/helm/software/components/getter/http_getter_common.ml new file mode 100644 index 000000000..ddce33f5d --- /dev/null +++ b/helm/software/components/getter/http_getter_common.ml @@ -0,0 +1,167 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Http_getter_types;; +open Printf;; + +let string_of_ls_flag = function No -> "NO" | Yes -> "YES" | Ann -> "ANN" +let string_of_encoding = function + | `Normal -> "Normal" + | `Gzipped -> "GZipped" + +let is_cic_obj_uri uri = Pcre.pmatch ~pat:"^cic:" uri +let is_theory_uri uri = Pcre.pmatch ~pat:"^theory:" uri +let is_cic_uri uri = is_cic_obj_uri uri || is_theory_uri uri +let is_nuprl_uri uri = Pcre.pmatch ~pat:"^nuprl:" uri +let is_rdf_uri uri = Pcre.pmatch ~pat:"^helm:rdf(.*):(.*)//(.*)" uri +let is_xsl_uri uri = Pcre.pmatch ~pat:"^\\w+\\.xsl" uri + +let rec uri_of_string = function + | uri when is_rdf_uri uri -> + (match Pcre.split ~pat:"//" uri with + | [ prefix; uri ] -> + let rest = + match uri_of_string uri with + | Cic_uri xmluri -> xmluri + | _ -> raise (Invalid_URI uri) + in + Rdf_uri (prefix, rest) + | _ -> raise (Invalid_URI uri)) + | uri when is_cic_obj_uri uri -> Cic_uri (Cic (Pcre.replace ~pat:"^cic:" uri)) + | uri when is_nuprl_uri uri -> Nuprl_uri (Pcre.replace ~pat:"^nuprl:" uri) + | uri when is_theory_uri uri -> + Cic_uri (Theory (Pcre.replace ~pat:"^theory:" uri)) + | uri -> raise (Invalid_URI uri) + +let patch_xsl ?(via_http = true) () = + fun line -> + let mk_patch_fun tag line = + Pcre.replace + ~pat:(sprintf "%s\\s+href=\"" tag) + ~templ:(sprintf "%s href=\"%s/getxslt?uri=" + tag (Lazy.force Http_getter_env.my_own_url)) + line + in + let (patch_import, patch_include) = + (mk_patch_fun "xsl:import", mk_patch_fun "xsl:include") + in + patch_include (patch_import line) + +let patch_system kind ?(via_http = true) () = + let rex = + Pcre.regexp (sprintf "%s (.*) SYSTEM\\s+\"((%s)/)?" kind + (String.concat "|" (Lazy.force Http_getter_env.dtd_base_urls))) + in + let templ = + if via_http then + sprintf "%s $1 SYSTEM \"%s/getdtd?uri=" kind + (Lazy.force Http_getter_env.my_own_url) + else + sprintf "%s $1 SYSTEM \"file://%s/" kind (Http_getter_env.get_dtd_dir ()) + in + fun line -> Pcre.replace ~rex ~templ line + +let patch_entity = patch_system "ENTITY" +let patch_doctype = patch_system "DOCTYPE" + +let patch_xmlbase = + let rex = Pcre.regexp "^(\\s*<\\w[^ ]*)(\\s|>)" in + fun xmlbases baseurl baseuri s -> + let s' = + Pcre.replace ~rex + ~templ:(sprintf "$1 xml:base=\"%s\" helm:base=\"%s\"$2" baseurl baseuri) + s + in + if s <> s' then xmlbases := None; + s' + +let patch_dtd = patch_entity +let patch_xml ?via_http ?xmlbases () = + let xmlbases = ref xmlbases in + fun line -> + match !xmlbases with + | None -> patch_doctype ?via_http () (patch_entity ?via_http () line) + | Some (xmlbaseuri, xmlbaseurl) -> + patch_xmlbase xmlbases xmlbaseurl xmlbaseuri + (patch_doctype ?via_http () (patch_entity ?via_http () line)) + +let return_file + ~fname ?contype ?contenc ?patch_fun ?(gunzip = false) ?(via_http = true) + ~enc outchan += + if via_http then begin + let headers = + match (contype, contenc) with + | (Some t, Some e) -> ["Content-Encoding", e; "Content-Type", t] + | (Some t, None) -> ["Content-Type" , t] + | (None, Some e) -> ["Content-Encoding", e] + | (None, None) -> [] + in + Http_daemon.send_basic_headers ~code:(`Code 200) outchan; + Http_daemon.send_headers headers outchan; + Http_daemon.send_CRLF outchan + end; + match gunzip, patch_fun with + | true, Some patch_fun -> + Http_getter_logger.log ~level:2 + "Patch required, uncompress/compress cycle needed :-("; + (* gunzip needed, uncompress file, apply patch_fun to it, compress the + * result and sent it to client *) + let (tmp1, tmp2) = + (Http_getter_misc.tempfile (), Http_getter_misc.tempfile ()) + in + (try + Http_getter_misc.gunzip ~keep:true ~output:tmp1 fname; (* gunzip tmp1 *) + let new_file = open_out tmp2 in + Http_getter_misc.iter_file (* tmp2 = patch(tmp1) *) + (fun line -> + output_string new_file (patch_fun line ^ "\n"); + flush outchan) + tmp1; + close_out new_file; + Http_getter_misc.gzip ~output:tmp1 tmp2;(* tmp1 = gzip(tmp2); rm tmp2 *) + Http_getter_misc.iter_file (* send tmp1 to client as is*) + (fun line -> output_string outchan (line ^ "\n"); flush outchan) + tmp1; + Sys.remove tmp1 (* rm tmp1 *) + with e -> + Sys.remove tmp1; + raise e) + | false, Some patch_fun -> + (match enc with + | `Normal -> + Http_getter_misc.iter_file + (fun line -> output_string outchan (patch_fun (line ^ "\n"))) + fname + | `Gzipped -> assert false) + (* dangerous case, if this happens it needs to be investigated *) + | _, None -> Http_getter_misc.iter_file_data (output_string outchan) fname +;; + diff --git a/helm/software/components/getter/http_getter_common.mli b/helm/software/components/getter/http_getter_common.mli new file mode 100644 index 000000000..d1bc66f76 --- /dev/null +++ b/helm/software/components/getter/http_getter_common.mli @@ -0,0 +1,70 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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 Http_getter_types;; + +val string_of_ls_flag: ls_flag -> string +val string_of_encoding: encoding -> string + +val is_cic_uri: string -> bool +val is_cic_obj_uri: string -> bool +val is_theory_uri: string -> bool +val is_nuprl_uri: string -> bool +val is_rdf_uri: string -> bool +val is_xsl_uri: string -> bool + +val uri_of_string: string -> uri + + (** @param xmlbases (xml base URI * xml base URL) *) +val patch_xml : + ?via_http:bool -> ?xmlbases:(string * string) -> unit -> (string -> string) +val patch_dtd : ?via_http:bool -> unit -> (string -> string) + (* TODO via_http not yet supported for patch_xsl *) +val patch_xsl : ?via_http:bool -> unit -> (string -> string) + + (** + @param fname name of the file to be sent + @param contype Content-Type header value + @param contenc Content-Enconding header value + @param patch_fun function used to patch file contents + @param gunzip is meaningful only if a patch function is provided. If gunzip + is true and patch_fun is given (i.e. is not None), then patch_fun is applied + to the uncompressed version of the file. The file is then compressed again and + send to client + @param via_http (default: true) if true http specific communications are used + (e.g. headers, crlf before body) and sent via outchan, otherwise they're not. + Set it to false when saving to a local file + @param outchan output channel over which sent file fname *) +val return_file: + fname:string -> + ?contype:string -> ?contenc:string -> + ?patch_fun:(string -> string) -> ?gunzip:bool -> ?via_http:bool -> + enc:encoding -> + out_channel -> + unit + diff --git a/helm/software/components/getter/http_getter_const.ml b/helm/software/components/getter/http_getter_const.ml new file mode 100644 index 000000000..8103efcfa --- /dev/null +++ b/helm/software/components/getter/http_getter_const.ml @@ -0,0 +1,102 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Printf;; + +let version = "0.4.0" +let conffile = "http_getter.conf.xml" + +let xhtml_ns = "http://www.w3.org/1999/xhtml" +let helm_ns = "http://www.cs.unibo.it/helm" + + (* TODO provide a better usage string *) +let usage_string configuration = + sprintf +" + + + HTTP Getter's help message + + +

    HTTP Getter, version %s

    +

    Usage information

    +

    + Usage: http://hostname:getterport/command +

    +

    + Available commands: +

    +

    + help
    + display this help message +

    +

    + getxml?uri=URI[&format=(normal|gz)][&patch_dtd=(yes|no)]
    +

    +

    + resolve?uri=URI
    +

    +

    + getdtd?uri=URI[&patch_dtd=(yes|no)]
    +

    +

    + getxslt?uri=URI[&patch_dtd=(yes|no)]
    +

    +

    + update
    +

    +

    + clean_cache
    +

    +

    + ls?baseuri=regexp&format=(txt|xml)
    +

    +

    + getalluris?format=(txt|xml)
    +

    +

    + getempty
    +

    +

    Current configuration

    + 
    %s
    + + +" + xhtml_ns helm_ns + version configuration + +let empty_xml = +" + +]> + +" + diff --git a/helm/software/components/getter/http_getter_const.mli b/helm/software/components/getter/http_getter_const.mli new file mode 100644 index 000000000..d532313f0 --- /dev/null +++ b/helm/software/components/getter/http_getter_const.mli @@ -0,0 +1,39 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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 version: string +val conffile: string +val empty_xml: string + +val helm_ns: string (** helm namespace *) +val xhtml_ns: string (** xhtml namespace *) + + (** @return an HTML usage string including configuration information passed as + input parameter *) +val usage_string: string -> string + diff --git a/helm/software/components/getter/http_getter_env.ml b/helm/software/components/getter/http_getter_env.ml new file mode 100644 index 000000000..79b0ab42e --- /dev/null +++ b/helm/software/components/getter/http_getter_env.ml @@ -0,0 +1,123 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Printf + +open Http_getter_types +open Http_getter_misc + +let version = Http_getter_const.version + +let prefix_RE = Pcre.regexp "^\\s*([^\\s]+)\\s+([^\\s]+)\\s*(.*)$" + +let cache_dir = lazy (normalize_dir (Helm_registry.get "getter.cache_dir")) +let dtd_dir = lazy ( + match Helm_registry.get_opt Helm_registry.get_string "getter.dtd_dir" with + | None -> None + | Some dir -> Some (normalize_dir dir)) +let dtd_base_urls = lazy ( + let rex = Pcre.regexp "/*$" in + let raw_urls = + match + Helm_registry.get_list Helm_registry.string "getter.dtd_base_urls" + with + | [] -> ["http://helm.cs.unibo.it/dtd"; "http://mowgli.cs.unibo.it/dtd"] + | urls -> urls + in + List.map (Pcre.replace ~rex) raw_urls) +let port = lazy ( + Helm_registry.get_opt_default Helm_registry.int ~default:58081 "getter.port") + +let parse_prefix_attrs s = + List.fold_right + (fun s acc -> + match s with + | "ro" -> `Read_only :: acc + | "legacy" -> `Legacy :: acc + | s -> + Http_getter_logger.log ("ignoring unknown attribute: " ^ s); + acc) + (Pcre.split s) [] + +let prefixes = lazy ( + let prefixes = Helm_registry.get_list Helm_registry.string "getter.prefix" in + List.fold_left + (fun acc prefix -> + let subs = Pcre.extract ~rex:prefix_RE prefix in + try + (subs.(1), (subs.(2), parse_prefix_attrs subs.(3))) :: acc + with Invalid_argument _ -> + Http_getter_logger.log ("skipping invalid prefix: " ^ prefix); + acc) + [] prefixes) + +let host = lazy (Http_getter_misc.backtick "hostname -f") + +let my_own_url = + lazy + (let (host, port) = (Lazy.force host, Lazy.force port) in + sprintf "http://%s%s" (* without trailing '/' *) + host (if port = 80 then "" else (sprintf ":%d" port))) + +let env_to_string () = + let pp_attr = function `Read_only -> "ro" | `Legacy -> "legacy" in + let pp_prefix (uri_prefix, (url_prefix, attrs)) = + sprintf " %s -> %s [%s]" uri_prefix url_prefix + (String.concat "," (List.map pp_attr attrs)) in + let pp_prefixes prefixes = + match prefixes with + | [] -> "" + | l -> "\n" ^ String.concat "\n" (List.map pp_prefix l) + in + sprintf +"HTTP Getter %s + +prefixes:%s +dtd_dir:\t%s +host:\t\t%s +port:\t\t%d +my_own_url:\t%s +dtd_base_urls:\t%s +log_file:\t%s +log_level:\t%d +" + version + (pp_prefixes (Lazy.force prefixes)) + (match Lazy.force dtd_dir with Some dir -> dir | None -> "NONE") + (Lazy.force host) (Lazy.force port) + (Lazy.force my_own_url) (String.concat " " (Lazy.force dtd_base_urls)) + (match Http_getter_logger.get_log_file () with None -> "None" | Some f -> f) + (Http_getter_logger.get_log_level ()) + +let get_dtd_dir () = + match Lazy.force dtd_dir with + | None -> raise (Internal_error "dtd_dir is not available") + | Some dtd_dir -> dtd_dir + diff --git a/helm/software/components/getter/http_getter_env.mli b/helm/software/components/getter/http_getter_env.mli new file mode 100644 index 000000000..d1ab73db8 --- /dev/null +++ b/helm/software/components/getter/http_getter_env.mli @@ -0,0 +1,54 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +open Http_getter_types + + (** {2 general information} *) + +val version : string (* getter version *) + + (** {2 environment gathered data} *) + (** all *_dir values are returned with trailing "/" *) + +val cache_dir : string lazy_t (* cache root *) +val dtd_dir : string option lazy_t (* DTDs' root directory *) +val port : int lazy_t (* port on which getter listens *) +val dtd_base_urls : string list lazy_t (* base URLs for document patching *) +val prefixes : (string * (string * prefix_attr list)) list lazy_t + (* prefix map uri -> url + attrs *) + + (* {2 derived data} *) + +val host : string lazy_t (* host on which getter listens *) +val my_own_url : string lazy_t (* URL at which contact getter *) + + (* {2 misc} *) + +val env_to_string : unit -> string (* dump a textual representation of the + current http_getter settings on an output + channel *) + +val get_dtd_dir : unit -> string + diff --git a/helm/software/components/getter/http_getter_logger.ml b/helm/software/components/getter/http_getter_logger.ml new file mode 100644 index 000000000..1d774c102 --- /dev/null +++ b/helm/software/components/getter/http_getter_logger.ml @@ -0,0 +1,63 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +let log_level = ref 1 +let get_log_level () = !log_level +let set_log_level l = log_level := l + +(* invariant: if logfile is set, then logchan is set too *) +let logfile = ref None +let logchan = ref None + +let set_log_file f = + (match !logchan with None -> () | Some oc -> close_out oc); + match f with + | Some f -> + logfile := Some f; + logchan := Some (open_out f) + | None -> + logfile := None; + logchan := None + +let get_log_file () = !logfile + +let close_log_file () = set_log_file None + +let log ?(level = 1) s = + if level <= !log_level then + let msg = "[HTTP-Getter] " ^ s in + match (!logfile, !logchan) with + | None, _ -> prerr_endline msg + | Some fname, Some oc -> + output_string oc msg; + output_string oc "\n"; + flush oc + | Some _, None -> assert false + diff --git a/helm/software/components/getter/http_getter_logger.mli b/helm/software/components/getter/http_getter_logger.mli new file mode 100644 index 000000000..d39fe739d --- /dev/null +++ b/helm/software/components/getter/http_getter_logger.mli @@ -0,0 +1,49 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(** {2 Debugger and logger} *) + + (** log level + * 0 -> logging disabled + * 1 -> standard logging + * >=2 -> verbose logging + * default is 1 *) +val get_log_level: unit -> int +val set_log_level: int -> unit + + (** log a message through the logger with a given log level + * level defaults to 1, higher level denotes more verbose messages which are + * ignored with the default log_level *) +val log: ?level: int -> string -> unit + + (** if set to Some fname, fname will be used as a logfile, otherwise stderr + * will be used *) +val get_log_file: unit -> string option +val set_log_file: string option -> unit +val close_log_file: unit -> unit + diff --git a/helm/software/components/getter/http_getter_misc.ml b/helm/software/components/getter/http_getter_misc.ml new file mode 100644 index 000000000..45403effa --- /dev/null +++ b/helm/software/components/getter/http_getter_misc.ml @@ -0,0 +1,315 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Printf + +let file_scheme_prefix = "file://" + +let trailing_dot_gz_RE = Pcre.regexp "\\.gz$" (* for g{,un}zip *) +let url_RE = Pcre.regexp "^([\\w.-]+)(:(\\d+))?(/.*)?$" +let http_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "^http://" +let file_scheme_RE = Pcre.regexp ~flags:[`CASELESS] ("^" ^ file_scheme_prefix) +let dir_sep_RE = Pcre.regexp "/" +let heading_slash_RE = Pcre.regexp "^/" + +let local_url = + let rex = Pcre.regexp ("^(" ^ file_scheme_prefix ^ ")(.*)(.gz)$") in + fun s -> + try + Some ((Pcre.extract ~rex s).(2)) + with Not_found -> None + +let bufsiz = 16384 (* for file system I/O *) +let tcp_bufsiz = 4096 (* for TCP I/O *) + +let fold_file f init fname = + let ic = open_in fname in + let rec aux acc = + let line = try Some (input_line ic) with End_of_file -> None in + match line with + | None -> acc + | Some line -> aux (f line acc) + in + let res = try aux init with e -> close_in ic; raise e in + close_in ic; + res + +let iter_file f = fold_file (fun line _ -> f line) () + +let iter_buf_size = 10240 + +let iter_file_data f fname = + let ic = open_in fname in + let buf = String.create iter_buf_size in + try + while true do + let bytes = input ic buf 0 iter_buf_size in + if bytes = 0 then raise End_of_file; + f (String.sub buf 0 bytes) + done + with End_of_file -> close_in ic + +let hashtbl_sorted_fold f tbl init = + let sorted_keys = + List.sort compare (Hashtbl.fold (fun key _ keys -> key::keys) tbl []) + in + List.fold_left (fun acc k -> f k (Hashtbl.find tbl k) acc) init sorted_keys + +let hashtbl_sorted_iter f tbl = + let sorted_keys = + List.sort compare (Hashtbl.fold (fun key _ keys -> key::keys) tbl []) + in + List.iter (fun k -> f k (Hashtbl.find tbl k)) sorted_keys + +let cp src dst = + try + let ic = open_in src in + try + let oc = open_out dst in + let buf = String.create bufsiz in + (try + while true do + let bytes = input ic buf 0 bufsiz in + if bytes = 0 then raise End_of_file else output oc buf 0 bytes + done + with + End_of_file -> () + ); + close_in ic; close_out oc + with + Sys_error s -> + Http_getter_logger.log s; + close_in ic + | e -> + Http_getter_logger.log (Printexc.to_string e); + close_in ic; + raise e + with + Sys_error s -> + Http_getter_logger.log s + | e -> + Http_getter_logger.log (Printexc.to_string e); + raise e + +let wget ?output url = + Http_getter_logger.log + (sprintf "wgetting %s (output: %s)" url + (match output with None -> "default" | Some f -> f)); + match url with + | url when Pcre.pmatch ~rex:file_scheme_RE url -> (* file:// *) + (let src_fname = Pcre.replace ~rex:file_scheme_RE url in + match output with + | Some dst_fname -> cp src_fname dst_fname + | None -> + let dst_fname = Filename.basename src_fname in + if src_fname <> dst_fname then + cp src_fname dst_fname + else (* src and dst are the same: do nothing *) + ()) + | url when Pcre.pmatch ~rex:http_scheme_RE url -> (* http:// *) + (let oc = + open_out (match output with Some f -> f | None -> Filename.basename url) + in + Http_user_agent.get_iter (fun data -> output_string oc data) url; + close_out oc) + | scheme -> (* unsupported scheme *) + failwith ("Http_getter_misc.wget: unsupported scheme: " ^ scheme) + +let gzip ?(keep = false) ?output fname = + let output = match output with None -> fname ^ ".gz" | Some fname -> fname in + Http_getter_logger.log ~level:3 + (sprintf "gzipping %s (keep: %b, output: %s)" fname keep output); + let (ic, oc) = (open_in fname, Gzip.open_out output) in + let buf = String.create bufsiz in + (try + while true do + let bytes = input ic buf 0 bufsiz in + if bytes = 0 then raise End_of_file else Gzip.output oc buf 0 bytes + done + with End_of_file -> ()); + close_in ic; Gzip.close_out oc; + if not keep then Sys.remove fname +;; + +let gunzip ?(keep = false) ?output fname = + (* assumption: given file name ends with ".gz" or output is set *) + let output = + match output with + | None -> + if (Pcre.pmatch ~rex:trailing_dot_gz_RE fname) then + Pcre.replace ~rex:trailing_dot_gz_RE fname + else + failwith + "Http_getter_misc.gunzip: unable to determine output file name" + | Some fname -> fname + in + Http_getter_logger.log ~level:3 + (sprintf "gunzipping %s (keep: %b, output: %s)" fname keep output); + (* Open the zipped file manually since Gzip.open_in may + * leak the descriptor if it raises an exception *) + let zic = open_in fname in + begin + try + let ic = Gzip.open_in_chan zic in + let oc = open_out output in + let buf = String.create bufsiz in + (try + while true do + let bytes = Gzip.input ic buf 0 bufsiz in + if bytes = 0 then raise End_of_file else Pervasives.output oc buf 0 bytes + done + with End_of_file -> ()); + close_out oc; + Gzip.close_in ic + with + e -> close_in zic ; raise e + end ; + if not keep then Sys.remove fname +;; + +let tempfile () = Filename.temp_file "http_getter_" "" + +exception Mkdir_failure of string * string;; (* dirname, failure reason *) +let dir_perm = 0o755 + +let mkdir ?(parents = false) dirname = + let mkdirhier () = + let (pieces, hd) = + let split = Pcre.split ~rex:dir_sep_RE dirname in + if Pcre.pmatch ~rex:heading_slash_RE dirname then + (List.tl split, "/") + else + (split, "") + in + ignore + (List.fold_left + (fun pre dir -> + let next_dir = + sprintf "%s%s%s" pre (match pre with "/" | "" -> "" | _ -> "/") dir + in + (try + (match (Unix.stat next_dir).Unix.st_kind with + | Unix.S_DIR -> () (* dir component already exists, go on! *) + | _ -> (* dir component already exists but isn't a dir, abort! *) + raise + (Mkdir_failure (dirname, + sprintf "'%s' already exists but is not a dir" next_dir))) + with Unix.Unix_error (Unix.ENOENT, "stat", _) -> + (* dir component doesn't exists, create it and go on! *) + Unix.mkdir next_dir dir_perm); + next_dir) + hd pieces) + in + if parents then mkdirhier () else Unix.mkdir dirname dir_perm + +let string_of_proc_status = function + | Unix.WEXITED code -> sprintf "[Exited: %d]" code + | Unix.WSIGNALED sg -> sprintf "[Killed: %d]" sg + | Unix.WSTOPPED sg -> sprintf "[Stopped: %d]" sg + +let http_get url = + if Pcre.pmatch ~rex:file_scheme_RE url then begin + (* file:// URL. Read data from file system *) + let fname = Pcre.replace ~rex:file_scheme_RE url in + try + let size = (Unix.stat fname).Unix.st_size in + let buf = String.create size in + let ic = open_in fname in + really_input ic buf 0 size ; + close_in ic; + Some buf + with Unix.Unix_error (Unix.ENOENT, "stat", _) -> None + end else (* other URL, pass it to Http_user_agent *) + try + Some (Http_user_agent.get url) + with e -> + Http_getter_logger.log (sprintf + "Warning: Http_user_agent failed on url %s with exception: %s" + url (Printexc.to_string e)); + None + +let is_blank_line = + let blank_line_RE = Pcre.regexp "(^#)|(^\\s*$)" in + fun line -> + Pcre.pmatch ~rex:blank_line_RE line + +let normalize_dir s = (* append "/" if missing *) + let len = String.length s in + try + if s.[len - 1] = '/' then s + else s ^ "/" + with Invalid_argument _ -> (* string is empty *) "/" + +let strip_trailing_slash s = + try + let len = String.length s in + if s.[len - 1] = '/' then String.sub s 0 (len - 1) + else s + with Invalid_argument _ -> s + +let strip_suffix ~suffix s = + try + let s_len = String.length s in + let suffix_len = String.length suffix in + let suffix_sub = String.sub s (s_len - suffix_len) suffix_len in + if suffix_sub <> suffix then raise (Invalid_argument ""); + String.sub s 0 (s_len - suffix_len) + with Invalid_argument _ -> + raise (Invalid_argument "Http_getter_misc.strip_suffix") + +let rec list_uniq = function + | [] -> [] + | h::[] -> [h] + | h1::h2::tl when h1 = h2 -> list_uniq (h2 :: tl) + | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq tl + +let extension s = + try + let idx = String.rindex s '.' in + String.sub s idx (String.length s - idx) + with Not_found -> "" + +let temp_file_of_uri uri = + let flat_string s s' c = + let cs = String.copy s in + for i = 0 to (String.length s) - 1 do + if String.contains s' s.[i] then cs.[i] <- c + done; + cs + in + let user = try Unix.getlogin () with _ -> "" in + Filename.open_temp_file (user ^ flat_string uri ".-=:;!?/&" '_') "" + +let backtick cmd = + let ic = Unix.open_process_in cmd in + let res = input_line ic in + ignore (Unix.close_process_in ic); + res + diff --git a/helm/software/components/getter/http_getter_misc.mli b/helm/software/components/getter/http_getter_misc.mli new file mode 100644 index 000000000..e9b013ebd --- /dev/null +++ b/helm/software/components/getter/http_getter_misc.mli @@ -0,0 +1,102 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + + (** 'mkdir' failed, arguments are: name of the directory to be created and + failure reason *) +exception Mkdir_failure of string * string + + (** @return Some localpart for URI belonging to the "file://" scheme, None for + * other URIs + * removes trailing ".gz", if any + * e.g.: local_url "file:///etc/passwd.gz" = Some "/etc/passwd" + * local_url "http://...." = None *) +val local_url: string -> string option + + (** "fold_left" like function on file lines, trailing newline is not passed to + the given function *) +val fold_file : (string -> 'a -> 'a) -> 'a -> string -> 'a + + (* "iter" like function on file lines, trailing newline is not passed to the + given function *) +val iter_file : (string -> unit) -> string -> unit + + (* "iter" like function on file data chunks of fixed size *) +val iter_file_data: (string -> unit) -> string -> unit + + (** like Hashtbl.fold but keys are processed ordered *) +val hashtbl_sorted_fold : + ('a -> 'b -> 'c -> 'c) -> ('a, 'b) Hashtbl.t -> 'c -> 'c + (** like Hashtbl.iter but keys are processed ordered *) +val hashtbl_sorted_iter : ('a -> 'b -> unit) -> ('a, 'b) Hashtbl.t -> unit + +val list_uniq: 'a list -> 'a list (* uniq unix filter on lists *) + + (** cp frontend *) +val cp: string -> string -> unit + (** wget frontend, if output is given it is the destination file, otherwise + standard wget rules are used. Additionally this function support also the + "file://" scheme for file system addressing *) +val wget: ?output: string -> string -> unit + (** gzip frontend. If keep = true original file will be kept, default is + false. output is the file on which gzipped data will be saved, default is + given file with an added ".gz" suffix *) +val gzip: ?keep: bool -> ?output: string -> string -> unit + (** gunzip frontend. If keep = true original file will be kept, default is + false. output is the file on which gunzipped data will be saved, default is + given file name without trailing ".gz" *) +val gunzip: ?keep: bool -> ?output: string -> string -> unit + (** tempfile frontend, return the name of created file. A special purpose + suffix is used (actually "_http_getter" *) +val tempfile: unit -> string + (** mkdir frontend, if parents = true also parent directories will be created. + If the given directory already exists doesn't act. + parents defaults to false *) +val mkdir: ?parents:bool -> string -> unit + + (** pretty printer for Unix.process_status values *) +val string_of_proc_status : Unix.process_status -> string + + (** raw URL downloader, return Some the contents of downloaded resource or + None if an error occured while downloading. This function support also + "file://" scheme for filesystem resources *) +val http_get: string -> string option + + (** true on blanks-only and #-commented lines, false otherwise *) +val is_blank_line: string -> bool + +val normalize_dir: string -> string (** add trailing "/" if missing *) +val strip_trailing_slash: string -> string +val strip_suffix: suffix:string -> string -> string + +val extension: string -> string (** @return string part after rightmost "." *) + +val temp_file_of_uri: string -> string * out_channel + + (** execute a command and return first line of what it prints on stdout *) +val backtick: string -> string + diff --git a/helm/software/components/getter/http_getter_storage.ml b/helm/software/components/getter/http_getter_storage.ml new file mode 100644 index 000000000..fc6f415ac --- /dev/null +++ b/helm/software/components/getter/http_getter_storage.ml @@ -0,0 +1,275 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open Http_getter_misc +open Http_getter_types + +exception Not_found' +exception Resource_not_found of string * string (** method, uri *) + +let index_fname = "INDEX" + +let trailing_slash_RE = Pcre.regexp "/$" +let relative_RE_raw = "(^[^/]+(/[^/]+)*/?$)" +let relative_RE = Pcre.regexp relative_RE_raw +let file_scheme_RE_raw = "(^file://)" +let extended_file_scheme_RE = Pcre.regexp "(^file:/+)" +let file_scheme_RE = Pcre.regexp (relative_RE_raw ^ "|" ^ file_scheme_RE_raw) +let http_scheme_RE = Pcre.regexp "^http://" +let newline_RE = Pcre.regexp "\\n" +let cic_scheme_sep_RE = Pcre.regexp ":/" +let gz_suffix = ".gz" +let gz_suffix_len = String.length gz_suffix + +let path_of_file_url url = + assert (Pcre.pmatch ~rex:file_scheme_RE url); + if Pcre.pmatch ~rex:relative_RE url then + url + else (* absolute path, add heading "/" if missing *) + "/" ^ (Pcre.replace ~rex:extended_file_scheme_RE url) + + (** associative list regular expressions -> url prefixes + * sorted with longest prefixes first *) +let prefix_map = lazy ( + let map_w_length = + List.map + (fun (uri_prefix, (url_prefix, attrs)) -> + let uri_prefix = normalize_dir uri_prefix in + let url_prefix = normalize_dir url_prefix in + let regexp = Pcre.regexp ("^(" ^ Pcre.quote uri_prefix ^ ")") in + (regexp, String.length uri_prefix, uri_prefix, url_prefix, attrs)) + (Lazy.force Http_getter_env.prefixes) + in + let decreasing_length (_, len1, _, _, _) (_, len2, _, _, _) = + compare len2 len1 in + List.map + (fun (regexp, len, uri_prefix, url_prefix, attrs) -> + (regexp, strip_trailing_slash uri_prefix, url_prefix, attrs)) + (List.fast_sort decreasing_length map_w_length)) + +let lookup uri = + let matches = + List.filter (fun (rex, _, _, _) -> Pcre.pmatch ~rex uri) + (Lazy.force prefix_map) in + if matches = [] then raise (Unresolvable_URI uri); + matches + +let resolve_prefix uri = + match lookup uri with + | (rex, _, url_prefix, _) :: _ -> + Pcre.replace_first ~rex ~templ:url_prefix uri + | [] -> assert false + +let resolve_prefixes uri = + let matches = lookup uri in + List.map + (fun (rex, _, url_prefix, _) -> + Pcre.replace_first ~rex ~templ:url_prefix uri) + matches + +let get_attrs uri = + match lookup uri with + | (_, _, _, attrs) :: _ -> attrs + | [] -> assert false + +let is_legacy uri = List.exists ((=) `Legacy) (get_attrs uri) + +let is_read_only uri = + is_legacy uri || List.exists ((=) `Read_only) (get_attrs uri) + +let exists_http _ url = + Http_getter_wget.exists (url ^ gz_suffix) || Http_getter_wget.exists url + +let exists_file _ fname = + Sys.file_exists (fname ^ gz_suffix) || Sys.file_exists fname + +let resolve_http _ url = + try + List.find Http_getter_wget.exists [ url ^ gz_suffix; url ] + with Not_found -> raise Not_found' + +let resolve_file _ fname = + try + List.find Sys.file_exists [ fname ^ gz_suffix; fname ] + with Not_found -> raise Not_found' + +let strip_gz_suffix fname = + if extension fname = gz_suffix then + String.sub fname 0 (String.length fname - gz_suffix_len) + else + fname + +let remove_duplicates l = + Http_getter_misc.list_uniq (List.fast_sort Pervasives.compare l) + +let ls_file_single _ path_prefix = + let is_dir fname = (Unix.stat fname).Unix.st_kind = Unix.S_DIR in + let is_useless dir = try dir.[0] = '.' with _ -> false in + let entries = ref [] in + try + let dir_handle = Unix.opendir path_prefix in + (try + while true do + let entry = Unix.readdir dir_handle in + if is_useless entry then + () + else if is_dir (path_prefix ^ "/" ^ entry) then + entries := normalize_dir entry :: !entries + else + entries := strip_gz_suffix entry :: !entries + done + with End_of_file -> Unix.closedir dir_handle); + remove_duplicates !entries + with Unix.Unix_error (_, "opendir", _) -> [] + +let ls_http_single _ url_prefix = + try + let index = Http_getter_wget.get (normalize_dir url_prefix ^ index_fname) in + Pcre.split ~rex:newline_RE index + with Http_client_error _ -> raise Not_found' + +let get_file _ path = + if Sys.file_exists (path ^ gz_suffix) then + path ^ gz_suffix + else if Sys.file_exists path then + path + else + raise Not_found' + +let get_http uri url = + let scheme, path = + match Pcre.split ~rex:cic_scheme_sep_RE uri with + | [scheme; path] -> scheme, path + | _ -> assert false + in + let cache_name = + sprintf "%s%s/%s" (Lazy.force Http_getter_env.cache_dir) scheme path + in + if Sys.file_exists (cache_name ^ gz_suffix) then + cache_name ^ gz_suffix + else if Sys.file_exists cache_name then + cache_name + else begin (* fill cache *) + Http_getter_misc.mkdir ~parents:true (Filename.dirname cache_name); + (try + Http_getter_wget.get_and_save (url ^ gz_suffix) (cache_name ^ gz_suffix); + cache_name ^ gz_suffix + with Http_client_error _ -> + (try + Http_getter_wget.get_and_save url cache_name; + cache_name + with Http_client_error _ -> + raise Not_found')) + end + +let remove_file _ path = + if Sys.file_exists (path ^ gz_suffix) then Sys.remove (path ^ gz_suffix); + if Sys.file_exists path then Sys.remove path + +let remove_http _ _ = + prerr_endline "Http_getter_storage.remove: not implemented for HTTP scheme"; + assert false + +type 'a storage_method = { + name: string; + file: string -> string -> 'a; (* unresolved uri, resolved uri *) + http: string -> string -> 'a; (* unresolved uri, resolved uri *) +} + +let normalize_root uri = (* add trailing slash to roots *) + try + if uri.[String.length uri - 1] = ':' then uri ^ "/" + else uri + with Invalid_argument _ -> uri + +let invoke_method storage_method uri url = + try + if Pcre.pmatch ~rex:file_scheme_RE url then + storage_method.file uri (path_of_file_url url) + else if Pcre.pmatch ~rex:http_scheme_RE url then + storage_method.http uri url + else + raise (Unsupported_scheme url) + with Not_found' -> raise (Resource_not_found (storage_method.name, uri)) + +let dispatch_single storage_method uri = + assert (extension uri <> gz_suffix); + let uri = normalize_root uri in + let url = resolve_prefix uri in + invoke_method storage_method uri url + +let dispatch_multi storage_method uri = + let urls = resolve_prefixes uri in + let rec aux = function + | [] -> raise (Resource_not_found (storage_method.name, uri)) + | url :: tl -> + (try + invoke_method storage_method uri url + with Resource_not_found _ -> aux tl) + in + aux urls + +let exists = + dispatch_single { name = "exists"; file = exists_file; http = exists_http } + +let resolve = + dispatch_single { name = "resolve"; file = resolve_file; http = resolve_http } + +let ls_single = + dispatch_single { name = "ls"; file = ls_file_single; http = ls_http_single } + +let remove = + dispatch_single { name = "remove"; file = remove_file; http = remove_http } + +let filename ?(find = false) = + if find then + dispatch_multi { name = "filename"; file = get_file; http = get_http } + else + dispatch_single { name = "filename"; file = get_file; http = get_http } + + (* ls_single performs ls only below a single prefix, but prefixes which have + * common prefix (sorry) with a given one may need to be considered as well + * for example: when doing "ls cic:/" we would like to see the "cic:/matita" + * directory *) +let ls uri_prefix = +(* prerr_endline ("Http_getter_storage.ls " ^ uri_prefix); *) + let direct_results = ls_single uri_prefix in + List.fold_left + (fun results (_, uri_prefix', _, _) -> + if Filename.dirname uri_prefix' = strip_trailing_slash uri_prefix then + (Filename.basename uri_prefix' ^ "/") :: results + else + results) + direct_results + (Lazy.force prefix_map) + +let clean_cache () = + ignore (Sys.command + (sprintf "rm -rf %s/" (Lazy.force Http_getter_env.cache_dir))) + diff --git a/helm/software/components/getter/http_getter_storage.mli b/helm/software/components/getter/http_getter_storage.mli new file mode 100644 index 000000000..24fc329c9 --- /dev/null +++ b/helm/software/components/getter/http_getter_storage.mli @@ -0,0 +1,71 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** Transparent handling of local/remote getter resources. + * Configuration of this module are prefix mappings (see + * Http_getter_env.prefixes). All functions of this module take as input an URI, + * resolve it using mappings and act on the resulting resource which can be + * local (file:/// scheme or relative path) or remote via HTTP (http:// scheme). + * + * Each resource could be either compressed (trailing ".gz") or non-compressed. + * All functions of this module will first loook for the compressed resource + * (i.e. the asked one ^ ".gz"), falling back to the non-compressed one. + * + * All filenames returned by functions of this module exists on the filesystem + * after function's return. + * + * Almost all functions may raise Resource_not_found, the following invariant + * holds: that exception is raised iff exists return false on a given resource + * *) + +exception Resource_not_found of string * string (** method, uri *) + + (** @return a list of string where dir are returned with a trailing "/" *) +val ls: string -> string list + + + (** @return the filename of the resource corresponding to a given uri. Handle + * download and caching for remote resources. + * @param find if set to true all matching prefixes will be searched for the + * asked resource, if not only the best matching prefix will be used. Note + * that the search is performed only if the asked resource is not found in + * cache (i.e. to perform the find again you need to clean the cache). + * Defaults to false *) +val filename: ?find:bool -> string -> string + + (** only works for local resources + * if both compressed and non-compressed versions of a resource exist, both of + * them are removed *) +val remove: string -> unit + +val exists: string -> bool +val resolve: string -> string + +(* val get_attrs: string -> Http_getter_types.prefix_attr list *) +val is_read_only: string -> bool +val is_legacy: string -> bool + +val clean_cache: unit -> unit + diff --git a/helm/software/components/getter/http_getter_types.ml b/helm/software/components/getter/http_getter_types.ml new file mode 100644 index 000000000..fb0c30e83 --- /dev/null +++ b/helm/software/components/getter/http_getter_types.ml @@ -0,0 +1,72 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +exception Bad_request of string +exception Unresolvable_URI of string +exception Invalid_URI of string +exception Invalid_URL of string +exception Invalid_RDF_class of string +exception Internal_error of string +exception Cache_failure of string +exception Dtd_not_found of string (* dtd's url *) +exception Key_already_in of string;; +exception Key_not_found of string;; +exception Http_client_error of string * string (* url, error message *) +exception Unsupported_scheme of string (** unsupported url scheme *) + +type encoding = [ `Normal | `Gzipped ] +type answer_format = [ `Text | `Xml ] +type ls_flag = No | Yes | Ann +type ls_object = + { + uri: string; + ann: bool; + types: ls_flag; + body: ls_flag; + proof_tree: ls_flag; + } +type ls_item = + | Ls_section of string + | Ls_object of ls_object + +type xml_uri = + | Cic of string + | Theory of string +type rdf_uri = string * xml_uri +type nuprl_uri = string +type uri = + | Cic_uri of xml_uri + | Nuprl_uri of nuprl_uri + | Rdf_uri of rdf_uri + +module StringSet = Set.Make (String) + +type prefix_attr = [ `Read_only | `Legacy ] + diff --git a/helm/software/components/getter/http_getter_wget.ml b/helm/software/components/getter/http_getter_wget.ml new file mode 100644 index 000000000..2052e7bd5 --- /dev/null +++ b/helm/software/components/getter/http_getter_wget.ml @@ -0,0 +1,70 @@ +(* Copyright (C) 2000-2005, 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/. + *) + +(* $Id$ *) + +open Http_getter_types + +let send cmd = + try + ignore (Http_user_agent.get cmd) + with exn -> raise (Http_client_error (cmd, Printexc.to_string exn)) + +let get url = + try + Http_user_agent.get url + with exn -> raise (Http_client_error (Printexc.to_string exn, url)) + +let get_and_save url dest_filename = + let out_channel = open_out dest_filename in + (try + Http_user_agent.get_iter (output_string out_channel) url; + with exn -> + close_out out_channel; + Sys.remove dest_filename; + raise (Http_client_error (Printexc.to_string exn, url))); + close_out out_channel + +let get_and_save_to_tmp url = + let flat_string s s' c = + let cs = String.copy s in + for i = 0 to (String.length s) - 1 do + if String.contains s' s.[i] then cs.[i] <- c + done; + cs + in + let user = try Unix.getlogin () with _ -> "" in + let tmp_file = + Filename.temp_file (user ^ flat_string url ".-=:;!?/&" '_') "" + in + get_and_save url tmp_file; + tmp_file + +let exists url = + try + ignore (Http_user_agent.head url); + true + with Http_user_agent.Http_error _ -> false + diff --git a/helm/software/components/getter/http_getter_wget.mli b/helm/software/components/getter/http_getter_wget.mli new file mode 100644 index 000000000..5d28df185 --- /dev/null +++ b/helm/software/components/getter/http_getter_wget.mli @@ -0,0 +1,35 @@ +(* Copyright (C) 2000-2005, 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/. + *) + + (** try to guess if an HTTP resource exists using HEAD request + * @return true if HEAD response code = 200 *) +val exists: string -> bool + +val get: string -> string +val get_and_save: string -> string -> unit +val get_and_save_to_tmp: string -> string + +val send: string -> unit + diff --git a/helm/software/components/getter/mkindexes.pl b/helm/software/components/getter/mkindexes.pl new file mode 100755 index 000000000..3107846aa --- /dev/null +++ b/helm/software/components/getter/mkindexes.pl @@ -0,0 +1,40 @@ +#!/usr/bin/perl -w +# To be invoked in a directory where a tree of XML files of the HELM library is +# rooted. This script will then creates INDEX files in all directories of the +# tree. +use strict; +my $index_fname = "INDEX"; +sub getcwd() { + my $pwd = `pwd`; + chomp $pwd; + return $pwd; +} +sub add_trailing_slash($) { + my ($dir) = @_; + return $dir if ($dir =~ /\/$/); + return "$dir/"; +} +sub indexable($) { + my ($fname) = @_; + return 1 if ($fname =~ /\.(ind|types|body|var|theory).xml/); + return 0; +} +my @todo = (getcwd()); +while (my $dir = shift @todo) { + print "$dir\n"; + chdir $dir or die "Can't chdir to $dir\n"; + open LS, 'ls | sed \'s/\\.gz//\' | sort | uniq |'; + open INDEX, "> $index_fname" + or die "Can't open $index_fname in " . getcwd() . "\n"; + while (my $entry = ) { + chomp $entry; + if (-d $entry) { + print INDEX add_trailing_slash($entry) . "\n"; + push @todo, getcwd() . "/$entry"; + } else { + print INDEX "$entry\n" if indexable($entry); + } + } + close INDEX; + close LS; +} diff --git a/helm/software/components/getter/sample.conf.xml b/helm/software/components/getter/sample.conf.xml new file mode 100644 index 000000000..54cdc2557 --- /dev/null +++ b/helm/software/components/getter/sample.conf.xml @@ -0,0 +1,50 @@ + +
    + /tmp/helm/cache + /projects/helm/xml/dtd + 58081 + 180 + http_getter.log + + theory:/ file:///projects/helm/library/theories/ + + + xslt:/ file:///projects/helm/xml/stylesheets_ccorn/ + + + xslt:/ file:///projects/helm/xml/stylesheets_hanane/ + + + xslt:/ file:///projects/helm/xml/on-line/xslt/ + + + xslt:/ file:///projects/helm/nuprl/NuPRL/nuprl_stylesheets/ + + + nuprl:/ http://www.cs.uwyo.edu/~nuprl/helm-library/ + + + xslt:/ file:///projects/helm/xml/stylesheets/ + + + xslt:/ file:///projects/helm/xml/stylesheets/generated/ + + + theory:/residual_theory_in_lambda_calculus/ + http://helm.cs.unibo.it/~sacerdot/huet_lambda_calculus_mowgli/residual_theory_in_lambda_calculus/ + + + theory:/IDA/ + http://mowgli.cs.unibo.it/~sacerdot/ida/IDA/ + + + cic:/ file:///projects/helm/library/coq_contribs/ + legacy + + + cic:/matita/ + file:///projects/helm/library/matita/ + ro + +
    +     diff --git a/helm/software/components/getter/test.ml b/helm/software/components/getter/test.ml new file mode 100644 index 000000000..6fa236fd0 --- /dev/null +++ b/helm/software/components/getter/test.ml @@ -0,0 +1,12 @@ +(* $Id$ *) + +let _ = Helm_registry.load_from "foo.conf.xml" +let fname = Http_getter.getxml ~format:`Normal ~patch_dtd:true Sys.argv.(1) in +let ic = open_in fname in +(try + while true do + let line = input_line ic in + print_endline line + done +with End_of_file -> ()) + diff --git a/helm/software/components/grafite/.depend b/helm/software/components/grafite/.depend new file mode 100644 index 000000000..dc225e221 --- /dev/null +++ b/helm/software/components/grafite/.depend @@ -0,0 +1,6 @@ +grafiteAstPp.cmi: grafiteAst.cmo +grafiteMarshal.cmi: grafiteAst.cmo +grafiteAstPp.cmo: grafiteAst.cmo grafiteAstPp.cmi +grafiteAstPp.cmx: grafiteAst.cmx grafiteAstPp.cmi +grafiteMarshal.cmo: grafiteAstPp.cmi grafiteAst.cmo grafiteMarshal.cmi +grafiteMarshal.cmx: grafiteAstPp.cmx grafiteAst.cmx grafiteMarshal.cmi diff --git a/helm/software/components/grafite/Makefile b/helm/software/components/grafite/Makefile new file mode 100644 index 000000000..6eb3e7a78 --- /dev/null +++ b/helm/software/components/grafite/Makefile @@ -0,0 +1,14 @@ +PACKAGE = grafite +PREDICATES = + +INTERFACE_FILES = \ + grafiteAstPp.mli \ + grafiteMarshal.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + grafiteAst.ml \ + $(INTERFACE_FILES:%.mli=%.ml) + + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/grafite/grafiteAst.ml b/helm/software/components/grafite/grafiteAst.ml new file mode 100644 index 000000000..6c51fc80a --- /dev/null +++ b/helm/software/components/grafite/grafiteAst.ml @@ -0,0 +1,168 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +type direction = [ `LeftToRight | `RightToLeft ] + +type loc = Token.flocation + +type ('term, 'lazy_term, 'ident) pattern = + 'lazy_term option * ('ident * 'term) list * 'term option + +type ('term, 'ident) type_spec = + | Ident of 'ident + | Type of UriManager.uri * int + +type 'lazy_term reduction = + [ `Demodulate + | `Normalize + | `Reduce + | `Simpl + | `Unfold of 'lazy_term option + | `Whd ] + +type ('term, 'lazy_term, 'reduction, 'ident) tactic = + | Absurd of loc * 'term + | Apply of loc * 'term + | Assumption of loc + | Auto of loc * int option * int option * string option * string option + (* depth, width, paramodulation, full *) (* ALB *) + | Change of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term + | Clear of loc * 'ident + | ClearBody of loc * 'ident + | Compare of loc * 'term + | Constructor of loc * int + | Contradiction of loc + | Cut of loc * 'ident option * 'term + | DecideEquality of loc + | Decompose of loc * ('term, 'ident) type_spec list * 'ident * 'ident list + | Discriminate of loc * 'term + | Elim of loc * 'term * 'term option * int option * 'ident list + | ElimType of loc * 'term * 'term option * int option * 'ident list + | Exact of loc * 'term + | Exists of loc + | Fail of loc + | Fold of loc * 'reduction * 'lazy_term * ('term, 'lazy_term, 'ident) pattern + | Fourier of loc + | FwdSimpl of loc * string * 'ident list + | Generalize of loc * ('term, 'lazy_term, 'ident) pattern * 'ident option + | Goal of loc * int (* change current goal, argument is goal number 1-based *) + | IdTac of loc + | Injection of loc * 'term + | Intros of loc * int option * 'ident list + | Inversion of loc * 'term + | LApply of loc * int option * 'term list * 'term * 'ident option + | Left of loc + | LetIn of loc * 'term * 'ident + | Reduce of loc * 'reduction * ('term, 'lazy_term, 'ident) pattern + | Reflexivity of loc + | Replace of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term + | Rewrite of loc * direction * 'term * + ('term, 'lazy_term, 'ident) pattern + | Right of loc + | Ring of loc + | Split of loc + | Symmetry of loc + | Transitivity of loc * 'term + +type search_kind = [ `Locate | `Hint | `Match | `Elim ] + +type print_kind = [ `Env | `Coer ] + +type 'term macro = + (* Whelp's stuff *) + | WHint of loc * 'term + | WMatch of loc * 'term + | WInstance of loc * 'term + | WLocate of loc * string + | WElim of loc * 'term + (* real macros *) +(* | Abort of loc *) + | Print of loc * string + | Check of loc * 'term + | Hint of loc + | Quit of loc +(* | Redo of loc * int option + | Undo of loc * int option *) +(* | Print of loc * print_kind *) + | Search_pat of loc * search_kind * string (* searches with string pattern *) + | Search_term of loc * search_kind * 'term (* searches with term pattern *) + +(** To be increased each time the command type below changes, used for "safe" + * marshalling *) +let magic = 5 + +type 'obj command = + | Default of loc * string * UriManager.uri list + | Include of loc * string + | Set of loc * string * string + | Drop of loc + | Qed of loc + | Coercion of loc * UriManager.uri * bool (* add composites *) + | Obj of loc * 'obj + +type ('term, 'lazy_term, 'reduction, 'ident) tactical = + | Tactic of loc * ('term, 'lazy_term, 'reduction, 'ident) tactic + | Do of loc * int * ('term, 'lazy_term, 'reduction, 'ident) tactical + | Repeat of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical + | Seq of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list + (* sequential composition *) + | Then of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical * + ('term, 'lazy_term, 'reduction, 'ident) tactical list + | First of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list + (* try a sequence of loc * tactical until one succeeds, fail otherwise *) + | Try of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical + (* try a tactical and mask failures *) + | Solve of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list + + | Dot of loc + | Semicolon of loc + | Branch of loc + | Shift of loc + | Pos of loc * int + | Merge of loc + | Focus of loc * int list + | Unfocus of loc + | Skip of loc + +let is_punctuation = + function + | Dot _ | Semicolon _ | Branch _ | Shift _ | Merge _ | Pos _ -> true + | _ -> false + +type ('term, 'lazy_term, 'reduction, 'obj, 'ident) code = + | Command of loc * 'obj command + | Macro of loc * 'term macro + | Tactical of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical + * ('term, 'lazy_term, 'reduction, 'ident) tactical option(* punctuation *) + +type ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment = + | Note of loc * string + | Code of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code + +type ('term, 'lazy_term, 'reduction, 'obj, 'ident) statement = + | Executable of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code + | Comment of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment diff --git a/helm/software/components/grafite/grafiteAstPp.ml b/helm/software/components/grafite/grafiteAstPp.ml new file mode 100644 index 000000000..8bd5c96f1 --- /dev/null +++ b/helm/software/components/grafite/grafiteAstPp.ml @@ -0,0 +1,254 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open GrafiteAst + +let tactical_terminator = "" +let tactic_terminator = tactical_terminator +let command_terminator = tactical_terminator + +let pp_idents idents = "[" ^ String.concat "; " idents ^ "]" + +let pp_reduction_kind ~term_pp = function + | `Demodulate -> "demodulate" + | `Normalize -> "normalize" + | `Reduce -> "reduce" + | `Simpl -> "simplify" + | `Unfold (Some t) -> "unfold " ^ term_pp t + | `Unfold None -> "unfold" + | `Whd -> "whd" + +let pp_tactic_pattern ~term_pp ~lazy_term_pp (what, hyp, goal) = + let what_text = + match what with + | None -> "" + | Some t -> sprintf "in match (%s) " (lazy_term_pp t) in + let hyp_text = + String.concat " " + (List.map (fun (name, p) -> sprintf "%s:(%s)" name (term_pp p)) hyp) in + let goal_text = + match goal with + | None -> "" + | Some t -> sprintf "\\vdash (%s)" (term_pp t) in + sprintf "%sin %s%s" what_text hyp_text goal_text + +let pp_intros_specs = function + | None, [] -> "" + | Some num, [] -> Printf.sprintf " names %i" num + | None, idents -> Printf.sprintf " names %s" (pp_idents idents) + | Some num, idents -> Printf.sprintf " names %i %s" num (pp_idents idents) + +let terms_pp ~term_pp terms = String.concat ", " (List.map term_pp terms) + +let rec pp_tactic ~term_pp ~lazy_term_pp = + let pp_reduction_kind = pp_reduction_kind ~term_pp in + let pp_tactic_pattern = pp_tactic_pattern ~lazy_term_pp ~term_pp in + function + | Absurd (_, term) -> "absurd" ^ term_pp term + | Apply (_, term) -> "apply " ^ term_pp term + | Auto _ -> "auto" + | Assumption _ -> "assumption" + | Change (_, where, with_what) -> + sprintf "change %s with %s" (pp_tactic_pattern where) (lazy_term_pp with_what) + | Clear (_,id) -> sprintf "clear %s" id + | ClearBody (_,id) -> sprintf "clearbody %s" id + | Compare (_,term) -> "compare " ^ term_pp term + | Constructor (_,n) -> "constructor " ^ string_of_int n + | Contradiction _ -> "contradiction" + | Cut (_, ident, term) -> + "cut " ^ term_pp term ^ + (match ident with None -> "" | Some id -> " as " ^ id) + | DecideEquality _ -> "decide equality" + | Decompose (_, [], what, names) -> + sprintf "decompose %s%s" what (pp_intros_specs (None, names)) + | Decompose (_, types, what, names) -> + let to_ident = function + | Ident id -> id + | Type _ -> assert false + in + let types = List.rev_map to_ident types in + sprintf "decompose %s %s%s" (pp_idents types) what (pp_intros_specs (None, names)) + | Discriminate (_, term) -> "discriminate " ^ term_pp term + | Elim (_, term, using, num, idents) -> + sprintf "elim " ^ term_pp term ^ + (match using with None -> "" | Some term -> " using " ^ term_pp term) + ^ pp_intros_specs (num, idents) + | ElimType (_, term, using, num, idents) -> + sprintf "elim type " ^ term_pp term ^ + (match using with None -> "" | Some term -> " using " ^ term_pp term) + ^ pp_intros_specs (num, idents) + | Exact (_, term) -> "exact " ^ term_pp term + | Exists _ -> "exists" + | Fold (_, kind, term, pattern) -> + sprintf "fold %s %s %s" (pp_reduction_kind kind) + (lazy_term_pp term) (pp_tactic_pattern pattern) + | FwdSimpl (_, hyp, idents) -> + sprintf "fwd %s%s" hyp + (match idents with [] -> "" | idents -> " " ^ pp_idents idents) + | Generalize (_, pattern, ident) -> + sprintf "generalize %s%s" (pp_tactic_pattern pattern) + (match ident with None -> "" | Some id -> " as " ^ id) + | Goal (_, n) -> "goal " ^ string_of_int n + | Fail _ -> "fail" + | Fourier _ -> "fourier" + | IdTac _ -> "id" + | Injection (_, term) -> "injection " ^ term_pp term + | Intros (_, None, []) -> "intro" + | Inversion (_, term) -> "inversion " ^ term_pp term + | Intros (_, num, idents) -> + sprintf "intros%s%s" + (match num with None -> "" | Some num -> " " ^ string_of_int num) + (match idents with [] -> "" | idents -> " " ^ pp_idents idents) + | LApply (_, level_opt, terms, term, ident_opt) -> + sprintf "lapply %s%s%s%s" + (match level_opt with None -> "" | Some i -> " depth = " ^ string_of_int i ^ " ") + (term_pp term) + (match terms with [] -> "" | _ -> " to " ^ terms_pp ~term_pp terms) + (match ident_opt with None -> "" | Some ident -> " using " ^ ident) + | Left _ -> "left" + | LetIn (_, term, ident) -> sprintf "let %s in %s" (term_pp term) ident + | Reduce (_, kind, pat) -> + sprintf "%s %s" (pp_reduction_kind kind) (pp_tactic_pattern pat) + | Reflexivity _ -> "reflexivity" + | Replace (_, pattern, t) -> + sprintf "replace %s with %s" (pp_tactic_pattern pattern) (lazy_term_pp t) + | Rewrite (_, pos, t, pattern) -> + sprintf "rewrite %s %s %s" + (if pos = `LeftToRight then ">" else "<") + (term_pp t) + (pp_tactic_pattern pattern) + | Right _ -> "right" + | Ring _ -> "ring" + | Split _ -> "split" + | Symmetry _ -> "symmetry" + | Transitivity (_, term) -> "transitivity " ^ term_pp term + +let pp_search_kind = function + | `Locate -> "locate" + | `Hint -> "hint" + | `Match -> "match" + | `Elim -> "elim" + | `Instance -> "instance" + +let pp_macro ~term_pp = function + (* Whelp *) + | WInstance (_, term) -> "whelp instance " ^ term_pp term + | WHint (_, t) -> "whelp hint " ^ term_pp t + | WLocate (_, s) -> "whelp locate " ^ s + | WElim (_, t) -> "whelp elim " ^ term_pp t + | WMatch (_, term) -> "whelp match " ^ term_pp term + (* real macros *) + | Check (_, term) -> sprintf "Check %s" (term_pp term) + | Hint _ -> "hint" + | Search_pat (_, kind, pat) -> + sprintf "search %s \"%s\"" (pp_search_kind kind) pat + | Search_term (_, kind, term) -> + sprintf "search %s %s" (pp_search_kind kind) (term_pp term) + | Print (_, name) -> sprintf "Print \"%s\"" name + | Quit _ -> "Quit" + +let pp_associativity = function + | Gramext.LeftA -> "left associative" + | Gramext.RightA -> "right associative" + | Gramext.NonA -> "non associative" + +let pp_precedence i = sprintf "with precedence %d" i + +let pp_dir_opt = function + | None -> "" + | Some `LeftToRight -> "> " + | Some `RightToLeft -> "< " + +let pp_default what uris = + sprintf "default \"%s\" %s" what + (String.concat " " (List.map UriManager.string_of_uri uris)) + +let pp_coercion uri do_composites = + sprintf "coercion %s (* %s *)" (UriManager.string_of_uri uri) + (if do_composites then "compounds" else "no compounds") + +let pp_command ~obj_pp = function + | Include (_,path) -> "include " ^ path + | Qed _ -> "qed" + | Drop _ -> "drop" + | Set (_, name, value) -> sprintf "set \"%s\" \"%s\"" name value + | Coercion (_, uri, do_composites) -> pp_coercion uri do_composites + | Obj (_,obj) -> obj_pp obj + | Default (_,what,uris) -> + pp_default what uris + +let rec pp_tactical ~term_pp ~lazy_term_pp = + let pp_tactic = pp_tactic ~lazy_term_pp ~term_pp in + let pp_tacticals = pp_tacticals ~lazy_term_pp ~term_pp in + function + | Tactic (_, tac) -> pp_tactic tac + | Do (_, count, tac) -> + sprintf "do %d %s" count (pp_tactical ~term_pp ~lazy_term_pp tac) + | Repeat (_, tac) -> "repeat " ^ pp_tactical ~term_pp ~lazy_term_pp tac + | Seq (_, tacs) -> pp_tacticals ~sep:"; " tacs + | Then (_, tac, tacs) -> + sprintf "%s; [%s]" (pp_tactical ~term_pp ~lazy_term_pp tac) + (pp_tacticals ~sep:" | " tacs) + | First (_, tacs) -> sprintf "tries [%s]" (pp_tacticals ~sep:" | " tacs) + | Try (_, tac) -> "try " ^ pp_tactical ~term_pp ~lazy_term_pp tac + | Solve (_, tac) -> sprintf "solve [%s]" (pp_tacticals ~sep:" | " tac) + + | Dot _ -> "." + | Semicolon _ -> ";" + | Branch _ -> "[" + | Shift _ -> "|" + | Pos (_, i) -> sprintf "%d:" i + | Merge _ -> "]" + | Focus (_, goals) -> + sprintf "focus %s" (String.concat " " (List.map string_of_int goals)) + | Unfocus _ -> "unfocus" + | Skip _ -> "skip" + +and pp_tacticals ~term_pp ~lazy_term_pp ~sep tacs = + String.concat sep (List.map (pp_tactical~lazy_term_pp ~term_pp) tacs) + +let pp_executable ~term_pp ~lazy_term_pp ~obj_pp = + function + | Macro (_, macro) -> pp_macro ~term_pp macro + | Tactical (_, tac, Some punct) -> + pp_tactical ~lazy_term_pp ~term_pp tac + ^ pp_tactical ~lazy_term_pp ~term_pp punct + | Tactical (_, tac, None) -> pp_tactical ~lazy_term_pp ~term_pp tac + | Command (_, cmd) -> pp_command ~obj_pp cmd + +let pp_comment ~term_pp ~lazy_term_pp ~obj_pp = + function + | Note (_,str) -> sprintf "(* %s *)" str + | Code (_,code) -> + sprintf "(** %s. **)" (pp_executable ~term_pp ~lazy_term_pp ~obj_pp code) + +let pp_statement ~term_pp ~lazy_term_pp ~obj_pp = + function + | Executable (_, ex) -> pp_executable ~lazy_term_pp ~term_pp ~obj_pp ex + | Comment (_, c) -> pp_comment ~term_pp ~lazy_term_pp ~obj_pp c diff --git a/helm/software/components/grafite/grafiteAstPp.mli b/helm/software/components/grafite/grafiteAstPp.mli new file mode 100644 index 000000000..f9b3b37cc --- /dev/null +++ b/helm/software/components/grafite/grafiteAstPp.mli @@ -0,0 +1,76 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +val pp_tactic: + term_pp:('term -> string) -> + lazy_term_pp:('lazy_term -> string) -> + ('term, 'lazy_term, 'term GrafiteAst.reduction, string) + GrafiteAst.tactic -> + string + +val pp_tactic_pattern: + term_pp:('term -> string) -> + lazy_term_pp:('lazy_term -> string) -> + ('term, 'lazy_term, string) GrafiteAst.pattern -> + string + +val pp_reduction_kind: + term_pp:('a -> string) -> + 'a GrafiteAst.reduction -> + string + +val pp_command: obj_pp:('obj -> string) -> 'obj GrafiteAst.command -> string +val pp_macro: term_pp:('term -> string) -> 'term GrafiteAst.macro -> string +val pp_comment: + term_pp:('term -> string) -> + lazy_term_pp:('lazy_term -> string) -> + obj_pp:('obj -> string) -> + ('term, 'lazy_term, 'term GrafiteAst.reduction, 'obj, string) + GrafiteAst.comment -> + string + +val pp_executable: + term_pp:('term -> string) -> + lazy_term_pp:('lazy_term -> string) -> + obj_pp:('obj -> string) -> + ('term, 'lazy_term, 'term GrafiteAst.reduction, 'obj, string) + GrafiteAst.code -> + string + +val pp_statement: + term_pp:('term -> string) -> + lazy_term_pp:('lazy_term -> string) -> + obj_pp:('obj -> string) -> + ('term, 'lazy_term, 'term GrafiteAst.reduction, 'obj, string) + GrafiteAst.statement -> + string + +val pp_tactical: + term_pp:('term -> string) -> + lazy_term_pp:('lazy_term -> string) -> + ('term, 'lazy_term, 'term GrafiteAst.reduction, string) + GrafiteAst.tactical -> + string + diff --git a/helm/software/components/grafite/grafiteMarshal.ml b/helm/software/components/grafite/grafiteMarshal.ml new file mode 100644 index 000000000..e786d5001 --- /dev/null +++ b/helm/software/components/grafite/grafiteMarshal.ml @@ -0,0 +1,60 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +type ast_command = Cic.obj GrafiteAst.command +type moo = ast_command list + +let format_name = "grafite" + +let save_moo_to_file ~fname moo = + HMarshal.save ~fmt:format_name ~version:GrafiteAst.magic ~fname moo + +let load_moo_from_file ~fname = + let raw = HMarshal.load ~fmt:format_name ~version:GrafiteAst.magic ~fname in + (raw: moo) + +let rehash_cmd_uris = + let rehash_uri uri = + UriManager.uri_of_string (UriManager.string_of_uri uri) in + function + | GrafiteAst.Default (loc, name, uris) -> + let uris = List.map rehash_uri uris in + GrafiteAst.Default (loc, name, uris) + | GrafiteAst.Coercion (loc, uri, close) -> + GrafiteAst.Coercion (loc, rehash_uri uri, close) + | cmd -> + prerr_endline "Found a command not expected in a .moo:"; + let obj_pp _ = assert false in + prerr_endline (GrafiteAstPp.pp_command ~obj_pp cmd); + assert false + +let save_moo ~fname moo = save_moo_to_file ~fname (List.rev moo) + +let load_moo ~fname = + let moo = load_moo_from_file ~fname in + List.map rehash_cmd_uris moo + diff --git a/helm/software/components/grafite/grafiteMarshal.mli b/helm/software/components/grafite/grafiteMarshal.mli new file mode 100644 index 000000000..e60ad39d8 --- /dev/null +++ b/helm/software/components/grafite/grafiteMarshal.mli @@ -0,0 +1,33 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +type ast_command = Cic.obj GrafiteAst.command +type moo = ast_command list + +val save_moo: fname:string -> moo -> unit + + (** @raise Corrupt_moo *) +val load_moo: fname:string -> moo + diff --git a/helm/software/components/grafite_engine/.depend b/helm/software/components/grafite_engine/.depend new file mode 100644 index 000000000..d0e9a3a86 --- /dev/null +++ b/helm/software/components/grafite_engine/.depend @@ -0,0 +1,12 @@ +grafiteSync.cmi: grafiteTypes.cmi +grafiteEngine.cmi: grafiteTypes.cmi +grafiteTypes.cmo: grafiteTypes.cmi +grafiteTypes.cmx: grafiteTypes.cmi +grafiteSync.cmo: grafiteTypes.cmi grafiteSync.cmi +grafiteSync.cmx: grafiteTypes.cmx grafiteSync.cmi +grafiteMisc.cmo: grafiteMisc.cmi +grafiteMisc.cmx: grafiteMisc.cmi +grafiteEngine.cmo: grafiteTypes.cmi grafiteSync.cmi grafiteMisc.cmi \ + grafiteEngine.cmi +grafiteEngine.cmx: grafiteTypes.cmx grafiteSync.cmx grafiteMisc.cmx \ + grafiteEngine.cmi diff --git a/helm/software/components/grafite_engine/Makefile b/helm/software/components/grafite_engine/Makefile new file mode 100644 index 000000000..d810e1be2 --- /dev/null +++ b/helm/software/components/grafite_engine/Makefile @@ -0,0 +1,13 @@ +PACKAGE = grafite_engine +PREDICATES = + +INTERFACE_FILES = \ + grafiteTypes.mli \ + grafiteSync.mli \ + grafiteMisc.mli \ + grafiteEngine.mli \ + $(NULL) +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/grafite_engine/grafiteEngine.ml b/helm/software/components/grafite_engine/grafiteEngine.ml new file mode 100644 index 000000000..65dd17b6a --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteEngine.ml @@ -0,0 +1,714 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +exception Drop +exception IncludedFileNotCompiled of string (* file name *) +exception Macro of + GrafiteAst.loc * + (Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) +exception ReadOnlyUri of string + +type options = { + do_heavy_checks: bool ; + clean_baseuri: bool +} + +(** create a ProofEngineTypes.mk_fresh_name_type function which uses given + * names as long as they are available, then it fallbacks to name generation + * using FreshNamesGenerator module *) +let namer_of names = + let len = List.length names in + let count = ref 0 in + fun metasenv context name ~typ -> + if !count < len then begin + let name = Cic.Name (List.nth names !count) in + incr count; + name + end else + FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ + +let tactic_of_ast ast = + let module PET = ProofEngineTypes in + match ast with + | GrafiteAst.Absurd (_, term) -> Tactics.absurd term + | GrafiteAst.Apply (_, term) -> Tactics.apply term + | GrafiteAst.Assumption _ -> Tactics.assumption + | GrafiteAst.Auto (_,depth,width,paramodulation,full) -> + AutoTactic.auto_tac ?depth ?width ?paramodulation ?full + ~dbd:(LibraryDb.instance ()) () + | GrafiteAst.Change (_, pattern, with_what) -> + Tactics.change ~pattern with_what + | GrafiteAst.Clear (_,id) -> Tactics.clear id + | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id + | GrafiteAst.Contradiction _ -> Tactics.contradiction + | GrafiteAst.Compare (_, term) -> Tactics.compare term + | GrafiteAst.Constructor (_, n) -> Tactics.constructor n + | GrafiteAst.Cut (_, ident, term) -> + let names = match ident with None -> [] | Some id -> [id] in + Tactics.cut ~mk_fresh_name_callback:(namer_of names) term + | GrafiteAst.DecideEquality _ -> Tactics.decide_equality + | GrafiteAst.Decompose (_, types, what, names) -> + let to_type = function + | GrafiteAst.Type (uri, typeno) -> uri, typeno + | GrafiteAst.Ident _ -> assert false + in + let user_types = List.rev_map to_type types in + let dbd = LibraryDb.instance () in + let mk_fresh_name_callback = namer_of names in + Tactics.decompose ~mk_fresh_name_callback ~dbd ~user_types what + | GrafiteAst.Discriminate (_,term) -> Tactics.discriminate term + | GrafiteAst.Elim (_, what, using, depth, names) -> + Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names) + what + | GrafiteAst.ElimType (_, what, using, depth, names) -> + Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names) + what + | GrafiteAst.Exact (_, term) -> Tactics.exact term + | GrafiteAst.Exists _ -> Tactics.exists + | GrafiteAst.Fail _ -> Tactics.fail + | GrafiteAst.Fold (_, reduction_kind, term, pattern) -> + let reduction = + match reduction_kind with + | `Demodulate -> + GrafiteTypes.command_error "demodulation can't be folded" + | `Normalize -> + PET.const_lazy_reduction + (CicReduction.normalize ~delta:false ~subst:[]) + | `Reduce -> PET.const_lazy_reduction ProofEngineReduction.reduce + | `Simpl -> PET.const_lazy_reduction ProofEngineReduction.simpl + | `Unfold None -> + PET.const_lazy_reduction (ProofEngineReduction.unfold ?what:None) + | `Unfold (Some lazy_term) -> + (fun context metasenv ugraph -> + let what, metasenv, ugraph = lazy_term context metasenv ugraph in + ProofEngineReduction.unfold ~what, metasenv, ugraph) + | `Whd -> + PET.const_lazy_reduction (CicReduction.whd ~delta:false ~subst:[]) + in + Tactics.fold ~reduction ~term ~pattern + | GrafiteAst.Fourier _ -> Tactics.fourier + | GrafiteAst.FwdSimpl (_, hyp, names) -> + Tactics.fwd_simpl ~mk_fresh_name_callback:(namer_of names) + ~dbd:(LibraryDb.instance ()) hyp + | GrafiteAst.Generalize (_,pattern,ident) -> + let names = match ident with None -> [] | Some id -> [id] in + Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern + | GrafiteAst.Goal (_, n) -> Tactics.set_goal n + | GrafiteAst.IdTac _ -> Tactics.id + | GrafiteAst.Injection (_,term) -> Tactics.injection term + | GrafiteAst.Intros (_, None, names) -> + PrimitiveTactics.intros_tac ~mk_fresh_name_callback:(namer_of names) () + | GrafiteAst.Intros (_, Some num, names) -> + PrimitiveTactics.intros_tac ~howmany:num + ~mk_fresh_name_callback:(namer_of names) () + | GrafiteAst.Inversion (_, term) -> + Tactics.inversion term + | GrafiteAst.LApply (_, how_many, to_what, what, ident) -> + let names = match ident with None -> [] | Some id -> [id] in + Tactics.lapply ~mk_fresh_name_callback:(namer_of names) ?how_many + ~to_what what + | GrafiteAst.Left _ -> Tactics.left + | GrafiteAst.LetIn (loc,term,name) -> + Tactics.letin term ~mk_fresh_name_callback:(namer_of [name]) + | GrafiteAst.Reduce (_, reduction_kind, pattern) -> + (match reduction_kind with + | `Demodulate -> Tactics.demodulate ~dbd:(LibraryDb.instance ()) ~pattern + | `Normalize -> Tactics.normalize ~pattern + | `Reduce -> Tactics.reduce ~pattern + | `Simpl -> Tactics.simpl ~pattern + | `Unfold what -> Tactics.unfold ~pattern what + | `Whd -> Tactics.whd ~pattern) + | GrafiteAst.Reflexivity _ -> Tactics.reflexivity + | GrafiteAst.Replace (_, pattern, with_what) -> + Tactics.replace ~pattern ~with_what + | GrafiteAst.Rewrite (_, direction, t, pattern) -> + EqualityTactics.rewrite_tac ~direction ~pattern t + | GrafiteAst.Right _ -> Tactics.right + | GrafiteAst.Ring _ -> Tactics.ring + | GrafiteAst.Split _ -> Tactics.split + | GrafiteAst.Symmetry _ -> Tactics.symmetry + | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term + +(* maybe we only need special cases for apply and goal *) +let classify_tactic tactic = + match tactic with + (* tactics that can't close the goal (return a goal we want to "select") *) + | GrafiteAst.Rewrite _ + | GrafiteAst.Split _ + | GrafiteAst.Replace _ + | GrafiteAst.Reduce _ + | GrafiteAst.Injection _ + | GrafiteAst.IdTac _ + | GrafiteAst.Generalize _ + | GrafiteAst.Elim _ + | GrafiteAst.Cut _ + | GrafiteAst.Decompose _ -> true, true + (* tactics we don't want to reorder goals. I think only Goal needs this. *) + | GrafiteAst.Goal _ -> false, true + (* tactics like apply *) + | _ -> true, false + +let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal= + let module PEH = ProofEngineHelpers in +(* let print_m name metasenv = + prerr_endline (">>>>> " ^ name); + prerr_endline (CicMetaSubst.ppmetasenv [] metasenv) + in *) + (* phase one calculates: + * new_goals_from_refine: goals added by refine + * head_goal: the first goal opened by ythe tactic + * other_goals: other goals opened by the tactic + *) + let new_goals_from_refine = PEH.compare_metasenvs start refine in + let new_goals_from_tactic = PEH.compare_metasenvs refine tactic in + let head_goal, other_goals, goals = + match goals with + | [] -> None,[],goals + | hd::tl -> + (* assert (List.mem hd new_goals_from_tactic); + * invalidato dalla goal_tac + * *) + Some hd, List.filter ((<>) hd) new_goals_from_tactic, List.filter ((<>) + hd) goals + in + let produced_goals = + match head_goal with + | None -> new_goals_from_refine @ other_goals + | Some x -> x :: new_goals_from_refine @ other_goals + in + (* extract the metas generated by refine and tactic *) + let metas_for_tactic_head = + match head_goal with + | None -> [] + | Some head_goal -> List.filter (fun (n,_,_) -> n = head_goal) tactic in + let metas_for_tactic_goals = + List.map + (fun x -> List.find (fun (metano,_,_) -> metano = x) tactic) + goals + in + let metas_for_refine_goals = + List.filter (fun (n,_,_) -> List.mem n new_goals_from_refine) tactic in + let produced_metas, goals = + let produced_metas = + if always_opens_a_goal then + metas_for_tactic_head @ metas_for_refine_goals @ + metas_for_tactic_goals + else begin +(* print_m "metas_for_refine_goals" metas_for_refine_goals; + print_m "metas_for_tactic_head" metas_for_tactic_head; + print_m "metas_for_tactic_goals" metas_for_tactic_goals; *) + metas_for_refine_goals @ metas_for_tactic_head @ + metas_for_tactic_goals + end + in + let goals = List.map (fun (metano, _, _) -> metano) produced_metas in + produced_metas, goals + in + (* residual metas, preserving the original order *) + let before, after = + let rec split e = + function + | [] -> [],[] + | (metano, _, _) :: tl when metano = e -> + [], List.map (fun (x,_,_) -> x) tl + | (metano, _, _) :: tl -> let b, a = split e tl in metano :: b, a + in + let find n metasenv = + try + Some (List.find (fun (metano, _, _) -> metano = n) metasenv) + with Not_found -> None + in + let extract l = + List.fold_right + (fun n acc -> + match find n tactic with + | Some x -> x::acc + | None -> acc + ) l [] in + let before_l, after_l = split current_goal start in + let before_l = + List.filter (fun x -> not (List.mem x produced_goals)) before_l in + let after_l = + List.filter (fun x -> not (List.mem x produced_goals)) after_l in + let before = extract before_l in + let after = extract after_l in + before, after + in +(* |+ DEBUG CODE +| + print_m "BEGIN" start; + prerr_endline ("goal was: " ^ string_of_int current_goal); + prerr_endline ("and metas from refine are:"); + List.iter + (fun t -> prerr_string (" " ^ string_of_int t)) + new_goals_from_refine; + prerr_endline ""; + print_m "before" before; + print_m "metas_for_tactic_head" metas_for_tactic_head; + print_m "metas_for_refine_goals" metas_for_refine_goals; + print_m "metas_for_tactic_goals" metas_for_tactic_goals; + print_m "produced_metas" produced_metas; + print_m "after" after; +|+ FINE DEBUG CODE +| *) + before @ produced_metas @ after, goals + +let apply_tactic ~disambiguate_tactic tactic (status, goal) = +(* prerr_endline "apply_tactic"; *) +(* prerr_endline (Continuationals.Stack.pp (GrafiteTypes.get_stack status)); *) + let starting_metasenv = GrafiteTypes.get_proof_metasenv status in + let before = List.map (fun g, _, _ -> g) starting_metasenv in +(* prerr_endline "disambiguate"; *) + let status, tactic = disambiguate_tactic status goal tactic in + let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in + let proof = GrafiteTypes.get_current_proof status in + let proof_status = proof, goal in + let needs_reordering, always_opens_a_goal = classify_tactic tactic in + let tactic = tactic_of_ast tactic in + (* apply tactic will change the lexicon_status ... *) +(* prerr_endline "apply_tactic bassa"; *) + let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in + let after = ProofEngineTypes.goals_of_proof proof in + let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in +(* prerr_endline("before: " ^ String.concat ", " (List.map string_of_int before)); +prerr_endline("after: " ^ String.concat ", " (List.map string_of_int after)); +prerr_endline("opened: " ^ String.concat ", " (List.map string_of_int opened)); *) +(* prerr_endline("opened_goals: " ^ String.concat ", " (List.map string_of_int opened_goals)); +prerr_endline("closed_goals: " ^ String.concat ", " (List.map string_of_int closed_goals)); *) + let proof, opened_goals = + if needs_reordering then begin + let uri, metasenv_after_tactic, t, ty = proof in +(* prerr_endline ("goal prima del riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof))); *) + let reordered_metasenv, opened_goals = + reorder_metasenv + starting_metasenv + metasenv_after_refinement metasenv_after_tactic + opened goal always_opens_a_goal + in + let proof' = uri, reordered_metasenv, t, ty in +(* prerr_endline ("goal dopo il riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof'))); *) + proof', opened_goals + end + else + proof, opened_goals + in + let incomplete_proof = + match status.GrafiteTypes.proof_status with + | GrafiteTypes.Incomplete_proof p -> p + | _ -> assert false + in + { status with GrafiteTypes.proof_status = + GrafiteTypes.Incomplete_proof + { incomplete_proof with GrafiteTypes.proof = proof } }, + opened_goals, closed_goals + +type eval_ast = + {ea_go: + 'term 'lazy_term 'reduction 'obj 'ident. + disambiguate_tactic: + (GrafiteTypes.status -> + ProofEngineTypes.goal -> + ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic -> + GrafiteTypes.status * + (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> + + disambiguate_command: + (GrafiteTypes.status -> + 'obj GrafiteAst.command -> + GrafiteTypes.status * Cic.obj GrafiteAst.command) -> + + disambiguate_macro: + (GrafiteTypes.status -> + 'term GrafiteAst.macro -> + Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -> + + ?do_heavy_checks:bool -> + ?clean_baseuri:bool -> + GrafiteTypes.status -> + ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement -> + GrafiteTypes.status * UriManager.uri list + } + +type 'a eval_command = + {ec_go: 'term 'obj. + disambiguate_command: + (GrafiteTypes.status -> + 'obj GrafiteAst.command -> + GrafiteTypes.status * Cic.obj GrafiteAst.command) -> + options -> GrafiteTypes.status -> 'obj GrafiteAst.command -> + GrafiteTypes.status * UriManager.uri list + } + +type 'a eval_executable = + {ee_go: 'term 'lazy_term 'reduction 'obj 'ident. + disambiguate_tactic: + (GrafiteTypes.status -> + ProofEngineTypes.goal -> + ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic -> + GrafiteTypes.status * + (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> + + disambiguate_command: + (GrafiteTypes.status -> + 'obj GrafiteAst.command -> + GrafiteTypes.status * Cic.obj GrafiteAst.command) -> + + disambiguate_macro: + (GrafiteTypes.status -> + 'term GrafiteAst.macro -> + Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -> + + options -> + GrafiteTypes.status -> + ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.code -> + GrafiteTypes.status * UriManager.uri list + } + +type 'a eval_from_moo = + { efm_go: GrafiteTypes.status -> string -> GrafiteTypes.status } + +let coercion_moo_statement_of uri = + GrafiteAst.Coercion (HExtlib.dummy_floc, uri, false) + +let eval_coercion status ~add_composites uri = + let basedir = Helm_registry.get "matita.basedir" in + let status,compounds = + prerr_endline "evaluating a coercion command"; + GrafiteSync.add_coercion ~basedir ~add_composites status uri in + let moo_content = coercion_moo_statement_of uri in + let status = GrafiteTypes.add_moo_content [moo_content] status in + {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof}, + compounds + +let eval_tactical ~disambiguate_tactic status tac = + let apply_tactic = apply_tactic ~disambiguate_tactic in + let module MatitaStatus = + struct + type input_status = GrafiteTypes.status * ProofEngineTypes.goal + + type output_status = + GrafiteTypes.status * ProofEngineTypes.goal list * ProofEngineTypes.goal list + + type tactic = input_status -> output_status + + let id_tactic = apply_tactic (GrafiteAst.IdTac HExtlib.dummy_floc) + let mk_tactic tac = tac + let apply_tactic tac = tac + let goals (_, opened, closed) = opened, closed + let set_goals (opened, closed) (status, _, _) = (status, opened, closed) + let get_stack (status, _) = GrafiteTypes.get_stack status + + let set_stack stack (status, opened, closed) = + GrafiteTypes.set_stack stack status, opened, closed + + let inject (status, _) = (status, [], []) + let focus goal (status, _, _) = (status, goal) + end + in + let module MatitaTacticals = Tacticals.Make (MatitaStatus) in + let rec tactical_of_ast l tac = + match tac with + | GrafiteAst.Tactic (loc, tactic) -> + MatitaTacticals.tactic (MatitaStatus.mk_tactic (apply_tactic tactic)) + | GrafiteAst.Seq (loc, tacticals) -> (* tac1; tac2; ... *) + assert (l > 0); + MatitaTacticals.seq ~tactics:(List.map (tactical_of_ast (l+1)) tacticals) + | GrafiteAst.Do (loc, n, tactical) -> + MatitaTacticals.do_tactic ~n ~tactic:(tactical_of_ast (l+1) tactical) + | GrafiteAst.Repeat (loc, tactical) -> + MatitaTacticals.repeat_tactic ~tactic:(tactical_of_ast (l+1) tactical) + | GrafiteAst.Then (loc, tactical, tacticals) -> (* tac; [ tac1 | ... ] *) + assert (l > 0); + MatitaTacticals.thens ~start:(tactical_of_ast (l+1) tactical) + ~continuations:(List.map (tactical_of_ast (l+1)) tacticals) + | GrafiteAst.First (loc, tacticals) -> + MatitaTacticals.first + ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals) + | GrafiteAst.Try (loc, tactical) -> + MatitaTacticals.try_tactic ~tactic:(tactical_of_ast (l+1) tactical) + | GrafiteAst.Solve (loc, tacticals) -> + MatitaTacticals.solve_tactics + ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals) + + | GrafiteAst.Skip loc -> MatitaTacticals.skip + | GrafiteAst.Dot loc -> MatitaTacticals.dot + | GrafiteAst.Semicolon loc -> MatitaTacticals.semicolon + | GrafiteAst.Branch loc -> MatitaTacticals.branch + | GrafiteAst.Shift loc -> MatitaTacticals.shift + | GrafiteAst.Pos (loc, i) -> MatitaTacticals.pos i + | GrafiteAst.Merge loc -> MatitaTacticals.merge + | GrafiteAst.Focus (loc, goals) -> MatitaTacticals.focus goals + | GrafiteAst.Unfocus loc -> MatitaTacticals.unfocus + in + let status, _, _ = tactical_of_ast 0 tac (status, ~-1) in + let status = (* is proof completed? *) + match status.GrafiteTypes.proof_status with + | GrafiteTypes.Incomplete_proof + { GrafiteTypes.stack = stack; proof = proof } + when Continuationals.Stack.is_empty stack -> + { status with GrafiteTypes.proof_status = GrafiteTypes.Proof proof } + | _ -> status + in + status + +let eval_comment status c = status + +(* since the record syntax allows to declare coercions, we have to put this + * information inside the moo *) +let add_coercions_of_record_to_moo obj lemmas status = + let attributes = CicUtil.attributes_of_obj obj in + let is_record = function `Class (`Record att) -> Some att | _-> None in + match HExtlib.list_findopt is_record attributes with + | None -> status,[] + | Some fields -> + let is_a_coercion uri = + try + let obj,_ = + CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri in + let attrs = CicUtil.attributes_of_obj obj in + List.mem (`Class `Projection) attrs + with Not_found -> assert false + in + (* looking at the fields we can know the 'wanted' coercions, but not the + * actually generated ones. So, only the intersection between the wanted + * and the actual should be in the moo as coercion, while everithing in + * lemmas should go as aliases *) + let wanted_coercions = + HExtlib.filter_map + (function + | (name,true) -> + Some + (UriManager.uri_of_string + (GrafiteTypes.qualify status name ^ ".con")) + | _ -> None) + fields + in + prerr_endline "wanted coercions:"; + List.iter + (fun u -> prerr_endline (UriManager.string_of_uri u)) + wanted_coercions; + let coercions, moo_content = + List.split + (HExtlib.filter_map + (fun uri -> + let is_a_wanted_coercion = + List.exists (UriManager.eq uri) wanted_coercions in + if is_a_coercion uri && is_a_wanted_coercion then + Some (uri, coercion_moo_statement_of uri) + else + None) + lemmas) + in + prerr_endline "actual coercions:"; + List.iter + (fun u -> prerr_endline (UriManager.string_of_uri u)) + coercions; + let status = GrafiteTypes.add_moo_content moo_content status in + {status with + GrafiteTypes.coercions = coercions @ status.GrafiteTypes.coercions}, + lemmas + +let add_obj uri obj status = + let basedir = Helm_registry.get "matita.basedir" in + let status,lemmas = GrafiteSync.add_obj ~basedir uri obj status in + status, lemmas + +let rec eval_command = {ec_go = fun ~disambiguate_command opts status cmd -> + let status,cmd = disambiguate_command status cmd in + let basedir = Helm_registry.get "matita.basedir" in + let status,uris = + match cmd with + | GrafiteAst.Default (loc, what, uris) as cmd -> + LibraryObjects.set_default what uris; + GrafiteTypes.add_moo_content [cmd] status,[] + | GrafiteAst.Include (loc, baseuri) -> + let moopath = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in + if not (Sys.file_exists moopath) then + raise (IncludedFileNotCompiled moopath); + let status = eval_from_moo.efm_go status moopath in + status,[] + | GrafiteAst.Set (loc, name, value) -> + if name = "baseuri" then begin + let value = + let v = Http_getter_misc.strip_trailing_slash value in + try + ignore (String.index v ' '); + GrafiteTypes.command_error "baseuri can't contain spaces" + with Not_found -> v + in + if Http_getter_storage.is_read_only value then begin + HLog.error (sprintf "uri %s belongs to a read-only repository" value); + raise (ReadOnlyUri value) + end; + if not (GrafiteMisc.is_empty value) && opts.clean_baseuri then begin + HLog.message ("baseuri " ^ value ^ " is not empty"); + HLog.message ("cleaning baseuri " ^ value); + LibraryClean.clean_baseuris ~basedir [value]; + end; + end; + GrafiteTypes.set_option status name value,[] + | GrafiteAst.Drop loc -> raise Drop + | GrafiteAst.Qed loc -> + let uri, metasenv, bo, ty = + match status.GrafiteTypes.proof_status with + | GrafiteTypes.Proof (Some uri, metasenv, body, ty) -> + uri, metasenv, body, ty + | GrafiteTypes.Proof (None, metasenv, body, ty) -> + raise (GrafiteTypes.Command_error + ("Someone allows to start a theorem without giving the "^ + "name/uri. This should be fixed!")) + | _-> + raise + (GrafiteTypes.Command_error "You can't Qed an incomplete theorem") + in + if metasenv <> [] then + raise + (GrafiteTypes.Command_error + "Proof not completed! metasenv is not empty!"); + let name = UriManager.name_of_uri uri in + let obj = Cic.Constant (name,Some bo,ty,[],[]) in + let status, lemmas = add_obj uri obj status in + {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof}, + uri::lemmas + | GrafiteAst.Coercion (loc, uri, add_composites) -> + eval_coercion status ~add_composites uri + | GrafiteAst.Obj (loc,obj) -> + let ext,name = + match obj with + Cic.Constant (name,_,_,_,_) + | Cic.CurrentProof (name,_,_,_,_,_) -> ".con",name + | Cic.InductiveDefinition (types,_,_,_) -> + ".ind", + (match types with (name,_,_,_)::_ -> name | _ -> assert false) + | _ -> assert false in + let uri = + UriManager.uri_of_string (GrafiteTypes.qualify status name ^ ext) + in + let metasenv = GrafiteTypes.get_proof_metasenv status in + match obj with + | Cic.CurrentProof (_,metasenv',bo,ty,_,_) -> + let name = UriManager.name_of_uri uri in + if not(CicPp.check name ty) then + HLog.error ("Bad name: " ^ name); + if opts.do_heavy_checks then + begin + let dbd = LibraryDb.instance () in + let similar = Whelp.match_term ~dbd ty in + let similar_len = List.length similar in + if similar_len> 30 then + (HLog.message + ("Duplicate check will compare your theorem with " ^ + string_of_int similar_len ^ + " theorems, this may take a while.")); + let convertible = + List.filter ( + fun u -> + let t = CicUtil.term_of_uri u in + let ty',g = + CicTypeChecker.type_of_aux' + metasenv' [] t CicUniv.empty_ugraph + in + fst(CicReduction.are_convertible [] ty' ty g)) + similar + in + (match convertible with + | [] -> () + | x::_ -> + HLog.warn + ("Theorem already proved: " ^ UriManager.string_of_uri x ^ + "\nPlease use a variant.")); + end; + assert (metasenv = metasenv'); + let initial_proof = (Some uri, metasenv, bo, ty) in + let initial_stack = Continuationals.Stack.of_metasenv metasenv in + { status with GrafiteTypes.proof_status = + GrafiteTypes.Incomplete_proof + { GrafiteTypes.proof = initial_proof; stack = initial_stack } }, + [] + | _ -> + if metasenv <> [] then + raise (GrafiteTypes.Command_error ( + "metasenv not empty while giving a definition with body: " ^ + CicMetaSubst.ppmetasenv [] metasenv)); + let status, lemmas = add_obj uri obj status in + let status,new_lemmas = + add_coercions_of_record_to_moo obj lemmas status + in + {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof}, + uri::new_lemmas@lemmas + in + match status.GrafiteTypes.proof_status with + GrafiteTypes.Intermediate _ -> + {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},uris + | _ -> status,uris + +} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro opts status ex -> + match ex with + | GrafiteAst.Tactical (_, tac, None) -> + eval_tactical ~disambiguate_tactic status tac,[] + | GrafiteAst.Tactical (_, tac, Some punct) -> + let status = eval_tactical ~disambiguate_tactic status tac in + eval_tactical ~disambiguate_tactic status punct,[] + | GrafiteAst.Command (_, cmd) -> + eval_command.ec_go ~disambiguate_command opts status cmd + | GrafiteAst.Macro (loc, macro) -> + raise (Macro (loc,disambiguate_macro status macro)) + +} and eval_from_moo = {efm_go = fun status fname -> + let ast_of_cmd cmd = + GrafiteAst.Executable (HExtlib.dummy_floc, + GrafiteAst.Command (HExtlib.dummy_floc, + cmd)) + in + let moo = GrafiteMarshal.load_moo fname in + List.fold_left + (fun status ast -> + let ast = ast_of_cmd ast in + let status,lemmas = + eval_ast.ea_go + ~disambiguate_tactic:(fun status _ tactic -> status,tactic) + ~disambiguate_command:(fun status cmd -> status,cmd) + ~disambiguate_macro:(fun _ _ -> assert false) + status ast + in + assert (lemmas=[]); + status) + status moo +} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro ?(do_heavy_checks=false) ?(clean_baseuri=true) status st +-> + let opts = { + do_heavy_checks = do_heavy_checks ; + clean_baseuri = clean_baseuri } + in + match st with + | GrafiteAst.Executable (_,ex) -> + eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command + ~disambiguate_macro opts status ex + | GrafiteAst.Comment (_,c) -> eval_comment status c,[] +} + +let eval_ast = eval_ast.ea_go diff --git a/helm/software/components/grafite_engine/grafiteEngine.mli b/helm/software/components/grafite_engine/grafiteEngine.mli new file mode 100644 index 000000000..ee5f3a157 --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteEngine.mli @@ -0,0 +1,55 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +exception Drop +exception IncludedFileNotCompiled of string +exception Macro of + GrafiteAst.loc * + (Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) + +val eval_ast : + disambiguate_tactic: + (GrafiteTypes.status -> + ProofEngineTypes.goal -> + ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic -> + GrafiteTypes.status * + (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> + + disambiguate_command: + (GrafiteTypes.status -> + 'obj GrafiteAst.command -> + GrafiteTypes.status * Cic.obj GrafiteAst.command) -> + + disambiguate_macro: + (GrafiteTypes.status -> + 'term GrafiteAst.macro -> + Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) -> + + ?do_heavy_checks:bool -> + ?clean_baseuri:bool -> + GrafiteTypes.status -> + ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement -> + (* the new status and generated objects, if any *) + GrafiteTypes.status * UriManager.uri list diff --git a/helm/software/components/grafite_engine/grafiteMisc.ml b/helm/software/components/grafite_engine/grafiteMisc.ml new file mode 100644 index 000000000..5b86293db --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteMisc.ml @@ -0,0 +1,33 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let is_empty buri = + List.for_all + (function + Http_getter_types.Ls_section _ -> true + | Http_getter_types.Ls_object _ -> false) + (Http_getter.ls (Http_getter_misc.strip_trailing_slash buri ^ "/")) diff --git a/helm/software/components/grafite_engine/grafiteMisc.mli b/helm/software/components/grafite_engine/grafiteMisc.mli new file mode 100644 index 000000000..833bb6360 --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteMisc.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + + (** check whether no objects are defined below a given baseuri *) +val is_empty: string -> bool diff --git a/helm/software/components/grafite_engine/grafiteSync.ml b/helm/software/components/grafite_engine/grafiteSync.ml new file mode 100644 index 000000000..37a3132e7 --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteSync.ml @@ -0,0 +1,74 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let add_obj ~basedir uri obj status = + let lemmas = LibrarySync.add_obj uri obj basedir in + {status with GrafiteTypes.objects = uri::status.GrafiteTypes.objects}, + lemmas + +let add_coercion ~basedir ~add_composites status uri = + let compounds = LibrarySync.add_coercion ~add_composites ~basedir uri in + {status with GrafiteTypes.coercions = uri :: status.GrafiteTypes.coercions}, + compounds + +module OrderedUri = +struct + type t = UriManager.uri * string + let compare (u1, _) (u2, _) = UriManager.compare u1 u2 +end + +module UriSet = Set.Make (OrderedUri) + + (** @return l2 \ l1 *) +let uri_list_diff l2 l1 = + let module S = UriManager.UriSet in + let s1 = List.fold_left (fun set uri -> S.add uri set) S.empty l1 in + let s2 = List.fold_left (fun set uri -> S.add uri set) S.empty l2 in + let diff = S.diff s2 s1 in + S.fold (fun uri uris -> uri :: uris) diff [] + +let time_travel ~present ~past = + let objs_to_remove = + uri_list_diff present.GrafiteTypes.objects past.GrafiteTypes.objects in + let coercions_to_remove = + uri_list_diff present.GrafiteTypes.coercions past.GrafiteTypes.coercions + in + List.iter (fun uri -> LibrarySync.remove_coercion uri) coercions_to_remove; + List.iter LibrarySync.remove_obj objs_to_remove + +let init () = + LibrarySync.remove_all_coercions (); + LibraryObjects.reset_defaults (); + { + GrafiteTypes.moo_content_rev = []; + proof_status = GrafiteTypes.No_proof; + options = GrafiteTypes.no_options; + objects = []; + coercions = []; + } diff --git a/helm/software/components/grafite_engine/grafiteSync.mli b/helm/software/components/grafite_engine/grafiteSync.mli new file mode 100644 index 000000000..ce3c04250 --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteSync.mli @@ -0,0 +1,38 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val add_obj: + basedir:string -> UriManager.uri -> Cic.obj -> GrafiteTypes.status -> + GrafiteTypes.status * UriManager.uri list + +val add_coercion: + basedir:string -> add_composites:bool -> GrafiteTypes.status -> + UriManager.uri -> GrafiteTypes.status * UriManager.uri list + +val time_travel: + present:GrafiteTypes.status -> past:GrafiteTypes.status -> unit + + (* also resets the imperative part of the status *) +val init: unit -> GrafiteTypes.status diff --git a/helm/software/components/grafite_engine/grafiteTypes.ml b/helm/software/components/grafite_engine/grafiteTypes.ml new file mode 100644 index 000000000..0c02e1b6c --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteTypes.ml @@ -0,0 +1,195 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception Option_error of string * string +exception Statement_error of string +exception Command_error of string + +let command_error msg = raise (Command_error msg) + +type incomplete_proof = { + proof: ProofEngineTypes.proof; + stack: Continuationals.Stack.t; +} + +type proof_status = + | No_proof + | Incomplete_proof of incomplete_proof + | Proof of ProofEngineTypes.proof + | Intermediate of Cic.metasenv + (* Status in which the proof could be while it is being processed by the + * engine. No status entering/exiting the engine could be in it. *) + +module StringMap = Map.Make (String) +type option_value = + | String of string + | Int of int +type options = option_value StringMap.t +let no_options = StringMap.empty + +type status = { + moo_content_rev: GrafiteMarshal.moo; + proof_status: proof_status; + options: options; + objects: UriManager.uri list; + coercions: UriManager.uri list; +} + +let get_current_proof status = + match status.proof_status with + | Incomplete_proof { proof = p } -> p + | _ -> raise (Statement_error "no ongoing proof") + +let get_proof_metasenv status = + match status.proof_status with + | No_proof -> [] + | Proof (_, metasenv, _, _) + | Incomplete_proof { proof = (_, metasenv, _, _) } + | Intermediate metasenv -> + metasenv + +let get_stack status = + match status.proof_status with + | Incomplete_proof p -> p.stack + | Proof _ -> Continuationals.Stack.empty + | _ -> assert false + +let set_stack stack status = + match status.proof_status with + | Incomplete_proof p -> + { status with proof_status = Incomplete_proof { p with stack = stack } } + | Proof _ -> + assert (Continuationals.Stack.is_empty stack); + status + | _ -> assert false + +let set_metasenv metasenv status = + let proof_status = + match status.proof_status with + | No_proof -> Intermediate metasenv + | Incomplete_proof ({ proof = (uri, _, proof, ty) } as incomplete_proof) -> + Incomplete_proof + { incomplete_proof with proof = (uri, metasenv, proof, ty) } + | Intermediate _ -> Intermediate metasenv + | Proof (_, metasenv', _, _) -> + assert (metasenv = metasenv'); + status.proof_status + in + { status with proof_status = proof_status } + +let get_proof_context status goal = + match status.proof_status with + | Incomplete_proof { proof = (_, metasenv, _, _) } -> + let (_, context, _) = CicUtil.lookup_meta goal metasenv in + context + | _ -> [] + +let get_proof_conclusion status goal = + match status.proof_status with + | Incomplete_proof { proof = (_, metasenv, _, _) } -> + let (_, _, conclusion) = CicUtil.lookup_meta goal metasenv in + conclusion + | _ -> raise (Statement_error "no ongoing proof") + +let add_moo_content cmds status = + let content = status.moo_content_rev in + let content' = + List.fold_right + (fun cmd acc -> +(* prerr_endline ("adding to moo command: " ^ GrafiteAstPp.pp_command cmd); *) + match cmd with + | GrafiteAst.Default _ -> + if List.mem cmd content then acc + else cmd :: acc + | _ -> cmd :: acc) + cmds content + in +(* prerr_endline ("new moo content: " ^ String.concat " " (List.map + GrafiteAstPp.pp_command content')); *) + { status with moo_content_rev = content' } + +let get_option status name = + try + StringMap.find name status.options + with Not_found -> raise (Option_error (name, "not found")) + +let set_option status name value = + let mangle_dir s = + let s = Str.global_replace (Str.regexp "//+") "/" s in + let s = Str.global_replace (Str.regexp "/$") "" s in + s + in + let types = [ "baseuri", (`String, mangle_dir); ] in + let ty_and_mangler = + try + List.assoc name types + with Not_found -> + command_error (Printf.sprintf "Unknown option \"%s\"" name) + in + let value = + match ty_and_mangler with + | `String, f -> String (f value) + | `Int, f -> + (try + Int (int_of_string (f value)) + with Failure _ -> + command_error (Printf.sprintf "Not an integer value \"%s\"" value)) + in + if StringMap.mem name status.options && name = "baseuri" then + command_error "Redefinition of 'baseuri' is forbidden." + else + { status with options = StringMap.add name value status.options } + + +let get_string_option status name = + match get_option status name with + | String s -> s + | _ -> raise (Option_error (name, "not a string value")) + +let qualify status name = get_string_option status "baseuri" ^ "/" ^ name + +let dump_status status = + HLog.message "status.aliases:\n"; + HLog.message "status.proof_status:"; + HLog.message + (match status.proof_status with + | No_proof -> "no proof\n" + | Incomplete_proof _ -> "incomplete proof\n" + | Proof _ -> "proof\n" + | Intermediate _ -> "Intermediate\n"); + HLog.message "status.options\n"; + StringMap.iter (fun k v -> + let v = + match v with + | String s -> s + | Int i -> string_of_int i + in + HLog.message (k ^ "::=" ^ v)) status.options; + HLog.message "status.coercions\n"; + HLog.message "status.objects:\n"; + List.iter + (fun u -> HLog.message (UriManager.string_of_uri u)) status.objects diff --git a/helm/software/components/grafite_engine/grafiteTypes.mli b/helm/software/components/grafite_engine/grafiteTypes.mli new file mode 100644 index 000000000..a8b86c276 --- /dev/null +++ b/helm/software/components/grafite_engine/grafiteTypes.mli @@ -0,0 +1,77 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception Option_error of string * string +exception Statement_error of string +exception Command_error of string + +val command_error: string -> 'a (** @raise Command_error *) + +type incomplete_proof = { + proof: ProofEngineTypes.proof; + stack: Continuationals.Stack.t; +} + +type proof_status = + No_proof + | Incomplete_proof of incomplete_proof + | Proof of ProofEngineTypes.proof + | Intermediate of Cic.metasenv + +type option_value = + | String of string + | Int of int +type options +val no_options: options + +type status = { + moo_content_rev: GrafiteMarshal.moo; + proof_status: proof_status; (** logical status *) + options: options; + objects: UriManager.uri list; (** in-scope objects *) + coercions: UriManager.uri list; (** defined coercions *) +} + +val dump_status : status -> unit + + (** list is not reversed, head command will be the first emitted *) +val add_moo_content: GrafiteMarshal.ast_command list -> status -> status + +val get_option : status -> string -> option_value +val get_string_option : status -> string -> string +val set_option : status -> string -> string -> status + +val qualify: status -> string -> string + +val get_current_proof: status -> ProofEngineTypes.proof +val get_proof_metasenv: status -> Cic.metasenv +val get_stack: status -> Continuationals.Stack.t +val get_proof_context : status -> int -> Cic.context +val get_proof_conclusion : status -> int -> Cic.term + +val set_stack: Continuationals.Stack.t -> status -> status +val set_metasenv: Cic.metasenv -> status -> status diff --git a/helm/software/components/grafite_parser/.depend b/helm/software/components/grafite_parser/.depend new file mode 100644 index 000000000..360429635 --- /dev/null +++ b/helm/software/components/grafite_parser/.depend @@ -0,0 +1,10 @@ +dependenciesParser.cmo: dependenciesParser.cmi +dependenciesParser.cmx: dependenciesParser.cmi +grafiteParser.cmo: dependenciesParser.cmi grafiteParser.cmi +grafiteParser.cmx: dependenciesParser.cmx grafiteParser.cmi +cicNotation2.cmo: grafiteParser.cmi cicNotation2.cmi +cicNotation2.cmx: grafiteParser.cmx cicNotation2.cmi +grafiteDisambiguator.cmo: grafiteDisambiguator.cmi +grafiteDisambiguator.cmx: grafiteDisambiguator.cmi +grafiteDisambiguate.cmo: grafiteDisambiguator.cmi grafiteDisambiguate.cmi +grafiteDisambiguate.cmx: grafiteDisambiguator.cmx grafiteDisambiguate.cmi diff --git a/helm/software/components/grafite_parser/Makefile b/helm/software/components/grafite_parser/Makefile new file mode 100644 index 000000000..8482825a6 --- /dev/null +++ b/helm/software/components/grafite_parser/Makefile @@ -0,0 +1,46 @@ +PACKAGE = grafite_parser +PREDICATES = + +INTERFACE_FILES = \ + dependenciesParser.mli \ + grafiteParser.mli \ + cicNotation2.mli \ + grafiteDisambiguator.mli \ + grafiteDisambiguate.mli \ + $(NULL) +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +all: test_parser print_grammar test_dep +clean: clean_tests + +# cross compatibility among ocaml 3.09 and ocaml 3.08, to be removed as +# soon as we have ocaml 3.09 everywhere and "loc" occurrences are replaced by +# "_loc" occurrences +UTF8DIR = $(shell $(OCAMLFIND) query helm-utf8_macros) +ULEXDIR = $(shell $(OCAMLFIND) query ulex) +MY_SYNTAXOPTIONS = -pp "camlp4o -I $(UTF8DIR) -I $(ULEXDIR) pa_extend.cmo pa_ulex.cma pa_unicode_macro.cma -loc loc" +grafiteParser.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +grafiteParser.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +depend: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) +# +# +grafiteParser.cmo: OCAMLC = $(OCAMLC_P4) +grafiteParser.cmx: OCAMLOPT = $(OCAMLOPT_P4) + +clean_tests: + rm -f test_parser{,.opt} test_dep{,.opt} print_grammar{,.opt} + +LOCAL_LINKOPTS = -package helm-$(PACKAGE) -linkpkg +test: test_parser print_grammar test_dep +test_parser: test_parser.ml $(PACKAGE).cma + @echo " OCAMLC $<" + @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< +print_grammar: print_grammar.ml $(PACKAGE).cma + @echo " OCAMLC $<" + @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< +test_dep: test_dep.ml $(PACKAGE).cma + @echo " OCAMLC $<" + @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/grafite_parser/cicNotation2.ml b/helm/software/components/grafite_parser/cicNotation2.ml new file mode 100644 index 000000000..015d426e7 --- /dev/null +++ b/helm/software/components/grafite_parser/cicNotation2.ml @@ -0,0 +1,49 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let load_notation ~include_paths fname = + let ic = open_in fname in + let lexbuf = Ulexing.from_utf8_channel ic in + let status = ref LexiconSync.init in + try + while true do + status := fst (GrafiteParser.parse_statement ~include_paths lexbuf !status) + done; + assert false + with End_of_file -> close_in ic; !status + +let parse_environment ~include_paths str = + let lexbuf = Ulexing.from_utf8_string str in + let status = ref LexiconSync.init in + try + while true do + status := fst (GrafiteParser.parse_statement ~include_paths lexbuf !status) + done; + assert false + with End_of_file -> + !status.LexiconEngine.aliases, + !status.LexiconEngine.multi_aliases diff --git a/helm/software/components/grafite_parser/cicNotation2.mli b/helm/software/components/grafite_parser/cicNotation2.mli new file mode 100644 index 000000000..00f184b3b --- /dev/null +++ b/helm/software/components/grafite_parser/cicNotation2.mli @@ -0,0 +1,35 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(** Note: notation is also loaded, but it cannot be undone since the + notation_ids part of the status is thrown away; + so far this function is useful only in Whelp *) +val parse_environment: + include_paths:string list -> + string -> + DisambiguateTypes.environment * DisambiguateTypes.multiple_environment + +(** @param fname file from which load notation *) +val load_notation: include_paths:string list -> string -> LexiconEngine.status diff --git a/helm/software/components/grafite_parser/dependenciesParser.ml b/helm/software/components/grafite_parser/dependenciesParser.ml new file mode 100644 index 000000000..fc49de600 --- /dev/null +++ b/helm/software/components/grafite_parser/dependenciesParser.ml @@ -0,0 +1,92 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception UnableToInclude of string + + (* statements meaningful for matitadep *) +type dependency = + | IncludeDep of string + | BaseuriDep of string + | UriDep of UriManager.uri + +let pp_dependency = function + | IncludeDep str -> "include \"" ^ str ^ "\"" + | BaseuriDep str -> "set \"baseuri\" \"" ^ str ^ "\"" + | UriDep uri -> "uri \"" ^ UriManager.string_of_uri uri ^ "\"" + +let parse_dependencies lexbuf = + let tok_stream,_ = + CicNotationLexer.level2_ast_lexer.Token.tok_func (Obj.magic lexbuf) + in + let rec parse acc = + (parser + | [< '("URI", u) >] -> + parse (UriDep (UriManager.uri_of_string u) :: acc) + | [< '("IDENT", "include"); '("QSTRING", fname) >] -> + parse (IncludeDep fname :: acc) + | [< '("IDENT", "set"); '("QSTRING", "baseuri"); '("QSTRING", baseuri) >] -> + parse (BaseuriDep baseuri :: acc) + | [< '("EOI", _) >] -> acc + | [< 'tok >] -> parse acc + | [< >] -> acc) tok_stream + in + List.rev (parse []) + +let make_absolute paths path = + let rec aux = function + | [] -> ignore (Unix.stat path); path + | p :: tl -> + let path = p ^ "/" ^ path in + try + ignore (Unix.stat path); path + with Unix.Unix_error _ -> aux tl + in + try + aux paths + with Unix.Unix_error _ -> raise (UnableToInclude path) +;; + +let baseuri_of_script ~include_paths file = + let file = make_absolute include_paths file in + let ic = open_in file in + let istream = Ulexing.from_utf8_channel ic in + let rec find_baseuri = + function + [] -> failwith ("No baseuri defined in " ^ file) + | BaseuriDep s::_ -> s + | _::tl -> find_baseuri tl in + let buri = find_baseuri (parse_dependencies istream) in + let uri = Http_getter_misc.strip_trailing_slash buri in + if String.length uri < 5 || String.sub uri 0 5 <> "cic:/" then + HLog.error (file ^ " sets an incorrect baseuri: " ^ buri); + (try + ignore(Http_getter.resolve uri) + with + | Http_getter_types.Unresolvable_URI _ -> + HLog.error (file ^ " sets an unresolvable baseuri: " ^ buri) + | Http_getter_types.Key_not_found _ -> ()); + uri diff --git a/helm/software/components/grafite_parser/dependenciesParser.mli b/helm/software/components/grafite_parser/dependenciesParser.mli new file mode 100644 index 000000000..882d45fb8 --- /dev/null +++ b/helm/software/components/grafite_parser/dependenciesParser.mli @@ -0,0 +1,39 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +exception UnableToInclude of string + + (* statements meaningful for matitadep *) +type dependency = + | IncludeDep of string + | BaseuriDep of string + | UriDep of UriManager.uri + +val pp_dependency: dependency -> string + + (** @raise End_of_file *) +val parse_dependencies: Ulexing.lexbuf -> dependency list + +val baseuri_of_script : include_paths:string list -> string -> string diff --git a/helm/software/components/grafite_parser/grafiteDisambiguate.ml b/helm/software/components/grafite_parser/grafiteDisambiguate.ml new file mode 100644 index 000000000..f5ea66f2f --- /dev/null +++ b/helm/software/components/grafite_parser/grafiteDisambiguate.ml @@ -0,0 +1,289 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception BaseUriNotSetYet + +let singleton = function + | [x], _ -> x + | _ -> assert false + + (** @param term not meaningful when context is given *) +let disambiguate_term lexicon_status_ref context metasenv term = + let lexicon_status = !lexicon_status_ref in + let (diff, metasenv, cic, _) = + singleton + (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ()) + ~aliases:lexicon_status.LexiconEngine.aliases + ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) + ~context ~metasenv term) + in + let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in + lexicon_status_ref := lexicon_status; + metasenv,cic + + (** disambiguate_lazy_term (circa): term -> (unit -> status) * lazy_term + * rationale: lazy_term will be invoked in different context to obtain a term, + * each invocation will disambiguate the term and can add aliases. Once all + * disambiguations have been performed, the first returned function can be + * used to obtain the resulting aliases *) +let disambiguate_lazy_term lexicon_status_ref term = + (fun context metasenv ugraph -> + let lexicon_status = !lexicon_status_ref in + let (diff, metasenv, cic, ugraph) = + singleton + (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ()) + ~initial_ugraph:ugraph ~aliases:lexicon_status.LexiconEngine.aliases + ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) + ~context ~metasenv + term) in + let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in + lexicon_status_ref := lexicon_status; + cic, metasenv, ugraph) + +let disambiguate_pattern lexicon_status_ref (wanted, hyp_paths, goal_path) = + let interp path = Disambiguate.interpretate_path [] path in + let goal_path = HExtlib.map_option interp goal_path in + let hyp_paths = List.map (fun (name, path) -> name, interp path) hyp_paths in + let wanted = + match wanted with + None -> None + | Some wanted -> + let wanted = disambiguate_lazy_term lexicon_status_ref wanted in + Some wanted + in + (wanted, hyp_paths, goal_path) + +let disambiguate_reduction_kind lexicon_status_ref = function + | `Unfold (Some t) -> + let t = disambiguate_lazy_term lexicon_status_ref t in + `Unfold (Some t) + | `Demodulate + | `Normalize + | `Reduce + | `Simpl + | `Unfold None + | `Whd as kind -> kind + +let disambiguate_tactic lexicon_status_ref context metasenv tactic = + let disambiguate_term = disambiguate_term lexicon_status_ref in + let disambiguate_pattern = disambiguate_pattern lexicon_status_ref in + let disambiguate_reduction_kind = disambiguate_reduction_kind lexicon_status_ref in + let disambiguate_lazy_term = disambiguate_lazy_term lexicon_status_ref in + match tactic with + | GrafiteAst.Absurd (loc, term) -> + let metasenv,cic = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Absurd (loc, cic) + | GrafiteAst.Apply (loc, term) -> + let metasenv,cic = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Apply (loc, cic) + | GrafiteAst.Assumption loc -> + metasenv,GrafiteAst.Assumption loc + | GrafiteAst.Auto (loc,depth,width,paramodulation,full) -> + metasenv,GrafiteAst.Auto (loc,depth,width,paramodulation,full) + | GrafiteAst.Change (loc, pattern, with_what) -> + let with_what = disambiguate_lazy_term with_what in + let pattern = disambiguate_pattern pattern in + metasenv,GrafiteAst.Change (loc, pattern, with_what) + | GrafiteAst.Clear (loc,id) -> + metasenv,GrafiteAst.Clear (loc,id) + | GrafiteAst.ClearBody (loc,id) -> + metasenv,GrafiteAst.ClearBody (loc,id) + | GrafiteAst.Compare (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Compare (loc,term) + | GrafiteAst.Constructor (loc,n) -> + metasenv,GrafiteAst.Constructor (loc,n) + | GrafiteAst.Contradiction loc -> + metasenv,GrafiteAst.Contradiction loc + | GrafiteAst.Cut (loc, ident, term) -> + let metasenv,cic = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Cut (loc, ident, cic) + | GrafiteAst.DecideEquality loc -> + metasenv,GrafiteAst.DecideEquality loc + | GrafiteAst.Decompose (loc, types, what, names) -> + let disambiguate (metasenv,types) = function + | GrafiteAst.Type _ -> assert false + | GrafiteAst.Ident id -> + (match + disambiguate_term context metasenv + (CicNotationPt.Ident(id, None)) + with + | metasenv,Cic.MutInd (uri, tyno, _) -> + metasenv,(GrafiteAst.Type (uri, tyno) :: types) + | _ -> + raise (GrafiteDisambiguator.DisambiguationError + (0,[[None,lazy "Decompose works only on inductive types"]]))) + in + let metasenv,types = + List.fold_left disambiguate (metasenv,[]) types + in + metasenv,GrafiteAst.Decompose (loc, types, what, names) + | GrafiteAst.Discriminate (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Discriminate(loc,term) + | GrafiteAst.Exact (loc, term) -> + let metasenv,cic = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Exact (loc, cic) + | GrafiteAst.Elim (loc, what, Some using, depth, idents) -> + let metasenv,what = disambiguate_term context metasenv what in + let metasenv,using = disambiguate_term context metasenv using in + metasenv,GrafiteAst.Elim (loc, what, Some using, depth, idents) + | GrafiteAst.Elim (loc, what, None, depth, idents) -> + let metasenv,what = disambiguate_term context metasenv what in + metasenv,GrafiteAst.Elim (loc, what, None, depth, idents) + | GrafiteAst.ElimType (loc, what, Some using, depth, idents) -> + let metasenv,what = disambiguate_term context metasenv what in + let metasenv,using = disambiguate_term context metasenv using in + metasenv,GrafiteAst.ElimType (loc, what, Some using, depth, idents) + | GrafiteAst.ElimType (loc, what, None, depth, idents) -> + let metasenv,what = disambiguate_term context metasenv what in + metasenv,GrafiteAst.ElimType (loc, what, None, depth, idents) + | GrafiteAst.Exists loc -> + metasenv,GrafiteAst.Exists loc + | GrafiteAst.Fail loc -> + metasenv,GrafiteAst.Fail loc + | GrafiteAst.Fold (loc,red_kind, term, pattern) -> + let pattern = disambiguate_pattern pattern in + let term = disambiguate_lazy_term term in + let red_kind = disambiguate_reduction_kind red_kind in + metasenv,GrafiteAst.Fold (loc, red_kind, term, pattern) + | GrafiteAst.FwdSimpl (loc, hyp, names) -> + metasenv,GrafiteAst.FwdSimpl (loc, hyp, names) + | GrafiteAst.Fourier loc -> + metasenv,GrafiteAst.Fourier loc + | GrafiteAst.Generalize (loc,pattern,ident) -> + let pattern = disambiguate_pattern pattern in + metasenv,GrafiteAst.Generalize (loc,pattern,ident) + | GrafiteAst.Goal (loc, g) -> + metasenv,GrafiteAst.Goal (loc, g) + | GrafiteAst.IdTac loc -> + metasenv,GrafiteAst.IdTac loc + | GrafiteAst.Injection (loc, term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Injection (loc,term) + | GrafiteAst.Intros (loc, num, names) -> + metasenv,GrafiteAst.Intros (loc, num, names) + | GrafiteAst.Inversion (loc, term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Inversion (loc, term) + | GrafiteAst.LApply (loc, depth, to_what, what, ident) -> + let f term to_what = + let metasenv,term = disambiguate_term context metasenv term in + term :: to_what + in + let to_what = List.fold_right f to_what [] in + let metasenv,what = disambiguate_term context metasenv what in + metasenv,GrafiteAst.LApply (loc, depth, to_what, what, ident) + | GrafiteAst.Left loc -> + metasenv,GrafiteAst.Left loc + | GrafiteAst.LetIn (loc, term, name) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.LetIn (loc,term,name) + | GrafiteAst.Reduce (loc, red_kind, pattern) -> + let pattern = disambiguate_pattern pattern in + let red_kind = disambiguate_reduction_kind red_kind in + metasenv,GrafiteAst.Reduce(loc, red_kind, pattern) + | GrafiteAst.Reflexivity loc -> + metasenv,GrafiteAst.Reflexivity loc + | GrafiteAst.Replace (loc, pattern, with_what) -> + let pattern = disambiguate_pattern pattern in + let with_what = disambiguate_lazy_term with_what in + metasenv,GrafiteAst.Replace (loc, pattern, with_what) + | GrafiteAst.Rewrite (loc, dir, t, pattern) -> + let metasenv,term = disambiguate_term context metasenv t in + let pattern = disambiguate_pattern pattern in + metasenv,GrafiteAst.Rewrite (loc, dir, term, pattern) + | GrafiteAst.Right loc -> + metasenv,GrafiteAst.Right loc + | GrafiteAst.Ring loc -> + metasenv,GrafiteAst.Ring loc + | GrafiteAst.Split loc -> + metasenv,GrafiteAst.Split loc + | GrafiteAst.Symmetry loc -> + metasenv,GrafiteAst.Symmetry loc + | GrafiteAst.Transitivity (loc, term) -> + let metasenv,cic = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Transitivity (loc, cic) + +let disambiguate_obj lexicon_status ~baseuri metasenv obj = + let uri = + match obj with + | CicNotationPt.Inductive (_,(name,_,_,_)::_) + | CicNotationPt.Record (_,name,_,_) -> + (match baseuri with + | Some baseuri -> + Some (UriManager.uri_of_string (baseuri ^ "/" ^ name ^ ".ind")) + | None -> raise BaseUriNotSetYet) + | CicNotationPt.Inductive _ -> assert false + | CicNotationPt.Theorem _ -> None in + let (diff, metasenv, cic, _) = + singleton + (GrafiteDisambiguator.disambiguate_obj ~dbd:(LibraryDb.instance ()) + ~aliases:lexicon_status.LexiconEngine.aliases + ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) ~uri obj) in + let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in + lexicon_status, metasenv, cic + +let disambiguate_command lexicon_status ~baseuri metasenv = + function + | GrafiteAst.Coercion _ + | GrafiteAst.Default _ + | GrafiteAst.Drop _ + | GrafiteAst.Include _ + | GrafiteAst.Qed _ + | GrafiteAst.Set _ as cmd -> + lexicon_status,metasenv,cmd + | GrafiteAst.Obj (loc,obj) -> + let lexicon_status,metasenv,obj = + disambiguate_obj lexicon_status ~baseuri metasenv obj in + lexicon_status, metasenv, GrafiteAst.Obj (loc,obj) + +let disambiguate_macro lexicon_status_ref metasenv context macro = + let disambiguate_term = disambiguate_term lexicon_status_ref in + match macro with + | GrafiteAst.WMatch (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.WMatch (loc,term) + | GrafiteAst.WInstance (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.WInstance (loc,term) + | GrafiteAst.WElim (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.WElim (loc,term) + | GrafiteAst.WHint (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.WHint (loc,term) + | GrafiteAst.Check (loc,term) -> + let metasenv,term = disambiguate_term context metasenv term in + metasenv,GrafiteAst.Check (loc,term) + | GrafiteAst.Hint _ + | GrafiteAst.WLocate _ as macro -> + metasenv,macro + | GrafiteAst.Quit _ + | GrafiteAst.Print _ + | GrafiteAst.Search_pat _ + | GrafiteAst.Search_term _ -> assert false diff --git a/helm/software/components/grafite_parser/grafiteDisambiguate.mli b/helm/software/components/grafite_parser/grafiteDisambiguate.mli new file mode 100644 index 000000000..b04aa3cde --- /dev/null +++ b/helm/software/components/grafite_parser/grafiteDisambiguate.mli @@ -0,0 +1,48 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +exception BaseUriNotSetYet + +val disambiguate_tactic: + LexiconEngine.status ref -> + Cic.context -> + Cic.metasenv -> + (CicNotationPt.term, CicNotationPt.term, CicNotationPt.term GrafiteAst.reduction, string) GrafiteAst.tactic -> + Cic.metasenv * + (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic + +val disambiguate_command: + LexiconEngine.status -> + baseuri:string option -> + Cic.metasenv -> + CicNotationPt.obj GrafiteAst.command -> + LexiconEngine.status * Cic.metasenv * Cic.obj GrafiteAst.command + +val disambiguate_macro: + LexiconEngine.status ref -> + Cic.metasenv -> + Cic.context -> + CicNotationPt.term GrafiteAst.macro -> + Cic.metasenv * Cic.term GrafiteAst.macro diff --git a/helm/software/components/grafite_parser/grafiteDisambiguator.ml b/helm/software/components/grafite_parser/grafiteDisambiguator.ml new file mode 100644 index 000000000..abe8c1de1 --- /dev/null +++ b/helm/software/components/grafite_parser/grafiteDisambiguator.ml @@ -0,0 +1,180 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +exception Ambiguous_input +(* the integer is an offset to be added to each location *) +exception DisambiguationError of + int * (Token.flocation option * string Lazy.t) list list + (** parameters are: option name, error message *) +exception Unbound_identifier of string + +type choose_uris_callback = + id:string -> UriManager.uri list -> UriManager.uri list + +type choose_interp_callback = (string * string) list list -> int list + +let mono_uris_callback ~id = + if Helm_registry.get_opt_default Helm_registry.get_bool ~default:true + "matita.auto_disambiguation" + then + function l -> l + else + raise Ambiguous_input + +let mono_interp_callback _ = raise Ambiguous_input + +let _choose_uris_callback = ref mono_uris_callback +let _choose_interp_callback = ref mono_interp_callback +let set_choose_uris_callback f = _choose_uris_callback := f +let set_choose_interp_callback f = _choose_interp_callback := f + +module Callbacks = + struct + let interactive_user_uri_choice ~selection_mode ?ok + ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = + !_choose_uris_callback ~id uris + + let interactive_interpretation_choice interp = + !_choose_interp_callback interp + + let input_or_locate_uri ~(title:string) ?id = + (* Zack: I try to avoid using this callback. I therefore assume that + * the presence of an identifier that can't be resolved via "locate" + * query is a syntax error *) + let msg = match id with Some id -> id | _ -> "_" in + raise (Unbound_identifier msg) + end + +module Disambiguator = Disambiguate.Make (Callbacks) + +(* implement module's API *) + +let disambiguate_thing ~aliases ~universe + ~(f:?fresh_instances:bool -> + aliases:DisambiguateTypes.environment -> + universe:DisambiguateTypes.multiple_environment option -> + 'a -> 'b) + ~(drop_aliases: 'b -> 'b) + ~(drop_aliases_and_clear_diff: 'b -> 'b) + (thing: 'a) += + assert (universe <> None); + let library = false, DisambiguateTypes.Environment.empty, None in + let multi_aliases = false, DisambiguateTypes.Environment.empty, universe in + let mono_aliases = true, aliases, Some DisambiguateTypes.Environment.empty in + let passes = (* *) + [ (false, mono_aliases, false); + (false, multi_aliases, false); + (true, mono_aliases, false); + (true, multi_aliases, false); + (true, mono_aliases, true); + (true, multi_aliases, true); + (true, library, true); + ] + in + let try_pass (fresh_instances, (_, aliases, universe), insert_coercions) = + CicRefine.insert_coercions := insert_coercions; + f ~fresh_instances ~aliases ~universe thing + in + let set_aliases (instances,(use_mono_aliases,_,_),_) (_, user_asked as res) = + if use_mono_aliases && not instances then + drop_aliases res + else if user_asked then + drop_aliases res (* one shot aliases *) + else + drop_aliases_and_clear_diff res + in + let rec aux errors = + function + | [ pass ] -> + (try + set_aliases pass (try_pass pass) + with Disambiguate.NoWellTypedInterpretation (offset,newerrors) -> + raise (DisambiguationError (offset, errors @ [newerrors]))) + | hd :: tl -> + (try + set_aliases hd (try_pass hd) + with Disambiguate.NoWellTypedInterpretation (_offset,newerrors) -> + aux (errors @ [newerrors]) tl) + | [] -> assert false + in + let saved_insert_coercions = !CicRefine.insert_coercions in + try + let res = aux [] passes in + CicRefine.insert_coercions := saved_insert_coercions; + res + with exn -> + CicRefine.insert_coercions := saved_insert_coercions; + raise exn + +type disambiguator_thing = + { do_it : + 'a 'b. + aliases:DisambiguateTypes.environment -> + universe:DisambiguateTypes.multiple_environment option -> + f:(?fresh_instances:bool -> + aliases:DisambiguateTypes.environment -> + universe:DisambiguateTypes.multiple_environment option -> + 'a -> 'b * bool) -> + drop_aliases:('b * bool -> 'b * bool) -> + drop_aliases_and_clear_diff:('b * bool -> 'b * bool) -> 'a -> 'b * bool + } + +let disambiguate_thing = + let profiler = HExtlib.profile "disambiguate_thing" in + { do_it = + fun ~aliases ~universe ~f ~drop_aliases ~drop_aliases_and_clear_diff thing + -> profiler.HExtlib.profile + (disambiguate_thing ~aliases ~universe ~f ~drop_aliases + ~drop_aliases_and_clear_diff) thing + } + +let drop_aliases (choices, user_asked) = + (List.map (fun (d, a, b, c) -> d, a, b, c) choices), + user_asked + +let drop_aliases_and_clear_diff (choices, user_asked) = + (List.map (fun (_, a, b, c) -> [], a, b, c) choices), + user_asked + +let disambiguate_term ?fresh_instances ~dbd ~context ~metasenv ?initial_ugraph + ~aliases ~universe term + = + assert (fresh_instances = None); + let f = + Disambiguator.disambiguate_term ~dbd ~context ~metasenv ?initial_ugraph + in + disambiguate_thing.do_it ~aliases ~universe ~f ~drop_aliases + ~drop_aliases_and_clear_diff term + +let disambiguate_obj ?fresh_instances ~dbd ~aliases ~universe ~uri obj = + assert (fresh_instances = None); + let f = Disambiguator.disambiguate_obj ~dbd ~uri in + disambiguate_thing.do_it ~aliases ~universe ~f ~drop_aliases + ~drop_aliases_and_clear_diff obj diff --git a/helm/software/components/grafite_parser/grafiteDisambiguator.mli b/helm/software/components/grafite_parser/grafiteDisambiguator.mli new file mode 100644 index 000000000..b7c85f6af --- /dev/null +++ b/helm/software/components/grafite_parser/grafiteDisambiguator.mli @@ -0,0 +1,51 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** raised when ambiguous input is found but not expected (e.g. in the batch + * compiler) *) +exception Ambiguous_input +(* the integer is an offset to be added to each location *) +exception DisambiguationError of + int * (Token.flocation option * string Lazy.t) list list + +type choose_uris_callback = id:string -> UriManager.uri list -> UriManager.uri list +type choose_interp_callback = (string * string) list list -> int list + +val set_choose_uris_callback: choose_uris_callback -> unit +val set_choose_interp_callback: choose_interp_callback -> unit + +(** @raise Ambiguous_input if called, default value for internal + * choose_uris_callback if not set otherwise with set_choose_uris_callback + * above *) +val mono_uris_callback: choose_uris_callback + +(** @raise Ambiguous_input if called, default value for internal + * choose_interp_callback if not set otherwise with set_choose_interp_callback + * above *) +val mono_interp_callback: choose_interp_callback + +(** for GUI callbacks see MatitaGui.interactive_{interp,user_uri}_choice *) + +include Disambiguate.Disambiguator diff --git a/helm/software/components/grafite_parser/grafiteParser.ml b/helm/software/components/grafite_parser/grafiteParser.ml new file mode 100644 index 000000000..e480efd34 --- /dev/null +++ b/helm/software/components/grafite_parser/grafiteParser.ml @@ -0,0 +1,566 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module Ast = CicNotationPt + +type 'a localized_option = + LSome of 'a + | LNone of Token.flocation + +type statement = + include_paths:string list -> + LexiconEngine.status -> + LexiconEngine.status * + (CicNotationPt.term, CicNotationPt.term, + CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) + GrafiteAst.statement localized_option + +let grammar = CicNotationParser.level2_ast_grammar + +let term = CicNotationParser.term +let statement = Grammar.Entry.create grammar "statement" + +let add_raw_attribute ~text t = Ast.AttributedTerm (`Raw text, t) + +let default_precedence = 50 +let default_associativity = Gramext.NonA + +EXTEND + GLOBAL: term statement; + arg: [ + [ LPAREN; names = LIST1 IDENT SEP SYMBOL ","; + SYMBOL ":"; ty = term; RPAREN -> names,ty + | name = IDENT -> [name],Ast.Implicit + ] + ]; + constructor: [ [ name = IDENT; SYMBOL ":"; typ = term -> (name, typ) ] ]; + tactic_term: [ [ t = term LEVEL "90N" -> t ] ]; + ident_list0: [ [ LPAREN; idents = LIST0 IDENT; RPAREN -> idents ] ]; + tactic_term_list1: [ + [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ] + ]; + reduction_kind: [ + [ IDENT "demodulate" -> `Demodulate + | IDENT "normalize" -> `Normalize + | IDENT "reduce" -> `Reduce + | IDENT "simplify" -> `Simpl + | IDENT "unfold"; t = OPT term -> `Unfold t + | IDENT "whd" -> `Whd ] + ]; + sequent_pattern_spec: [ + [ hyp_paths = + LIST0 + [ id = IDENT ; + path = OPT [SYMBOL ":" ; path = tactic_term -> path ] -> + (id,match path with Some p -> p | None -> Ast.UserInput) ]; + goal_path = OPT [ SYMBOL <:unicode>; term = tactic_term -> term ] -> + let goal_path = + match goal_path, hyp_paths with + None, [] -> Some Ast.UserInput + | None, _::_ -> None + | Some goal_path, _ -> Some goal_path + in + hyp_paths,goal_path + ] + ]; + pattern_spec: [ + [ res = OPT [ + "in"; + wanted_and_sps = + [ "match" ; wanted = tactic_term ; + sps = OPT [ "in"; sps = sequent_pattern_spec -> sps ] -> + Some wanted,sps + | sps = sequent_pattern_spec -> + None,Some sps + ] -> + let wanted,hyp_paths,goal_path = + match wanted_and_sps with + wanted,None -> wanted, [], Some Ast.UserInput + | wanted,Some (hyp_paths,goal_path) -> wanted,hyp_paths,goal_path + in + wanted, hyp_paths, goal_path ] -> + match res with + None -> None,[],Some Ast.UserInput + | Some ps -> ps] + ]; + direction: [ + [ SYMBOL ">" -> `LeftToRight + | SYMBOL "<" -> `RightToLeft ] + ]; + int: [ [ num = NUMBER -> int_of_string num ] ]; + intros_spec: [ + [ num = OPT [ num = int -> num ]; idents = OPT ident_list0 -> + let idents = match idents with None -> [] | Some idents -> idents in + num, idents + ] + ]; + using: [ [ using = OPT [ IDENT "using"; t = tactic_term -> t ] -> using ] ]; + tactic: [ + [ IDENT "absurd"; t = tactic_term -> + GrafiteAst.Absurd (loc, t) + | IDENT "apply"; t = tactic_term -> + GrafiteAst.Apply (loc, t) + | IDENT "assumption" -> + GrafiteAst.Assumption loc + | IDENT "auto"; + depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ]; + width = OPT [ IDENT "width"; SYMBOL "="; i = int -> i ]; + paramodulation = OPT [ IDENT "paramodulation" ]; + full = OPT [ IDENT "full" ] -> (* ALB *) + GrafiteAst.Auto (loc,depth,width,paramodulation,full) + | IDENT "clear"; id = IDENT -> + GrafiteAst.Clear (loc,id) + | IDENT "clearbody"; id = IDENT -> + GrafiteAst.ClearBody (loc,id) + | IDENT "change"; what = pattern_spec; "with"; t = tactic_term -> + GrafiteAst.Change (loc, what, t) + | IDENT "compare"; t = tactic_term -> + GrafiteAst.Compare (loc,t) + | IDENT "constructor"; n = int -> + GrafiteAst.Constructor (loc, n) + | IDENT "contradiction" -> + GrafiteAst.Contradiction loc + | IDENT "cut"; t = tactic_term; ident = OPT [ "as"; id = IDENT -> id] -> + GrafiteAst.Cut (loc, ident, t) + | IDENT "decide"; IDENT "equality" -> + GrafiteAst.DecideEquality loc + | IDENT "decompose"; types = OPT ident_list0; what = IDENT; + (num, idents) = intros_spec -> + let types = match types with None -> [] | Some types -> types in + let to_spec id = GrafiteAst.Ident id in + GrafiteAst.Decompose (loc, List.rev_map to_spec types, what, idents) + | IDENT "discriminate"; t = tactic_term -> + GrafiteAst.Discriminate (loc, t) + | IDENT "elim"; what = tactic_term; using = using; + (num, idents) = intros_spec -> + GrafiteAst.Elim (loc, what, using, num, idents) + | IDENT "elimType"; what = tactic_term; using = using; + (num, idents) = intros_spec -> + GrafiteAst.ElimType (loc, what, using, num, idents) + | IDENT "exact"; t = tactic_term -> + GrafiteAst.Exact (loc, t) + | IDENT "exists" -> + GrafiteAst.Exists loc + | IDENT "fail" -> GrafiteAst.Fail loc + | IDENT "fold"; kind = reduction_kind; t = tactic_term; p = pattern_spec -> + let (pt,_,_) = p in + if pt <> None then + raise (HExtlib.Localized (loc, CicNotationParser.Parse_error + ("the pattern cannot specify the term to replace, only its" + ^ " paths in the hypotheses and in the conclusion"))) + else + GrafiteAst.Fold (loc, kind, t, p) + | IDENT "fourier" -> + GrafiteAst.Fourier loc + | IDENT "fwd"; hyp = IDENT; idents = OPT ident_list0 -> + let idents = match idents with None -> [] | Some idents -> idents in + GrafiteAst.FwdSimpl (loc, hyp, idents) + | IDENT "generalize"; p=pattern_spec; id = OPT ["as" ; id = IDENT -> id] -> + GrafiteAst.Generalize (loc,p,id) + | IDENT "goal"; n = int -> + GrafiteAst.Goal (loc, n) + | IDENT "id" -> GrafiteAst.IdTac loc + | IDENT "injection"; t = tactic_term -> + GrafiteAst.Injection (loc, t) + | IDENT "intro"; ident = OPT IDENT -> + let idents = match ident with None -> [] | Some id -> [id] in + GrafiteAst.Intros (loc, Some 1, idents) + | IDENT "intros"; (num, idents) = intros_spec -> + GrafiteAst.Intros (loc, num, idents) + | IDENT "inversion"; t = tactic_term -> + GrafiteAst.Inversion (loc, t) + | IDENT "lapply"; + depth = OPT [ IDENT "depth"; SYMBOL "="; i = int -> i ]; + what = tactic_term; + to_what = OPT [ "to" ; t = tactic_term_list1 -> t ]; + ident = OPT [ IDENT "using" ; ident = IDENT -> ident ] -> + let to_what = match to_what with None -> [] | Some to_what -> to_what in + GrafiteAst.LApply (loc, depth, to_what, what, ident) + | IDENT "left" -> GrafiteAst.Left loc + | IDENT "letin"; where = IDENT ; SYMBOL <:unicode> ; t = tactic_term -> + GrafiteAst.LetIn (loc, t, where) + | kind = reduction_kind; p = pattern_spec -> + GrafiteAst.Reduce (loc, kind, p) + | IDENT "reflexivity" -> + GrafiteAst.Reflexivity loc + | IDENT "replace"; p = pattern_spec; "with"; t = tactic_term -> + GrafiteAst.Replace (loc, p, t) + | IDENT "rewrite" ; d = direction; t = tactic_term ; p = pattern_spec -> + let (pt,_,_) = p in + if pt <> None then + raise + (HExtlib.Localized (loc, + (CicNotationParser.Parse_error + "the pattern cannot specify the term to rewrite, only its paths in the hypotheses and in the conclusion"))) + else + GrafiteAst.Rewrite (loc, d, t, p) + | IDENT "right" -> + GrafiteAst.Right loc + | IDENT "ring" -> + GrafiteAst.Ring loc + | IDENT "split" -> + GrafiteAst.Split loc + | IDENT "symmetry" -> + GrafiteAst.Symmetry loc + | IDENT "transitivity"; t = tactic_term -> + GrafiteAst.Transitivity (loc, t) + ] + ]; + atomic_tactical: + [ "sequence" LEFTA + [ t1 = SELF; SYMBOL ";"; t2 = SELF -> + let ts = + match t1 with + | GrafiteAst.Seq (_, l) -> l @ [ t2 ] + | _ -> [ t1; t2 ] + in + GrafiteAst.Seq (loc, ts) + ] + | "then" NONA + [ tac = SELF; SYMBOL ";"; + SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"-> + (GrafiteAst.Then (loc, tac, tacs)) + ] + | "loops" RIGHTA + [ IDENT "do"; count = int; tac = SELF; IDENT "end" -> + GrafiteAst.Do (loc, count, tac) + | IDENT "repeat"; tac = SELF; IDENT "end" -> GrafiteAst.Repeat (loc, tac) + ] + | "simple" NONA + [ IDENT "first"; + SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"-> + GrafiteAst.First (loc, tacs) + | IDENT "try"; tac = SELF -> GrafiteAst.Try (loc, tac) + | IDENT "solve"; + SYMBOL "["; tacs = LIST0 SELF SEP SYMBOL "|"; SYMBOL "]"-> + GrafiteAst.Solve (loc, tacs) + | LPAREN; tac = SELF; RPAREN -> tac + | tac = tactic -> GrafiteAst.Tactic (loc, tac) + ] + ]; + punctuation_tactical: + [ + [ SYMBOL "[" -> GrafiteAst.Branch loc + | SYMBOL "|" -> GrafiteAst.Shift loc + | i = int; SYMBOL ":" -> GrafiteAst.Pos (loc, i) + | SYMBOL "]" -> GrafiteAst.Merge loc + | SYMBOL ";" -> GrafiteAst.Semicolon loc + | SYMBOL "." -> GrafiteAst.Dot loc + ] + ]; + tactical: + [ "simple" NONA + [ IDENT "focus"; goals = LIST1 int -> GrafiteAst.Focus (loc, goals) + | IDENT "unfocus" -> GrafiteAst.Unfocus loc + | IDENT "skip" -> GrafiteAst.Skip loc + | tac = atomic_tactical LEVEL "loops" -> tac + ] + ]; + theorem_flavour: [ + [ [ IDENT "definition" ] -> `Definition + | [ IDENT "fact" ] -> `Fact + | [ IDENT "lemma" ] -> `Lemma + | [ IDENT "remark" ] -> `Remark + | [ IDENT "theorem" ] -> `Theorem + ] + ]; + inductive_spec: [ [ + fst_name = IDENT; params = LIST0 [ arg=arg -> arg ]; + SYMBOL ":"; fst_typ = term; SYMBOL <:unicode>; OPT SYMBOL "|"; + fst_constructors = LIST0 constructor SEP SYMBOL "|"; + tl = OPT [ "with"; + types = LIST1 [ + name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode>; + OPT SYMBOL "|"; constructors = LIST0 constructor SEP SYMBOL "|" -> + (name, true, typ, constructors) ] SEP "with" -> types + ] -> + let params = + List.fold_right + (fun (names, typ) acc -> + (List.map (fun name -> (name, typ)) names) @ acc) + params [] + in + let fst_ind_type = (fst_name, true, fst_typ, fst_constructors) in + let tl_ind_types = match tl with None -> [] | Some types -> types in + let ind_types = fst_ind_type :: tl_ind_types in + (params, ind_types) + ] ]; + + record_spec: [ [ + name = IDENT; params = LIST0 [ arg = arg -> arg ] ; + SYMBOL ":"; typ = term; SYMBOL <:unicode>; SYMBOL "{" ; + fields = LIST0 [ + name = IDENT ; + coercion = [ SYMBOL ":" -> false | SYMBOL ":"; SYMBOL ">" -> true ] ; + ty = term -> (name,ty,coercion) + ] SEP SYMBOL ";"; SYMBOL "}" -> + let params = + List.fold_right + (fun (names, typ) acc -> + (List.map (fun name -> (name, typ)) names) @ acc) + params [] + in + (params,name,typ,fields) + ] ]; + + macro: [ + [ [ IDENT "quit" ] -> GrafiteAst.Quit loc +(* | [ IDENT "abort" ] -> GrafiteAst.Abort loc *) +(* | [ IDENT "undo" ]; steps = OPT NUMBER -> + GrafiteAst.Undo (loc, int_opt steps) + | [ IDENT "redo" ]; steps = OPT NUMBER -> + GrafiteAst.Redo (loc, int_opt steps) *) + | [ IDENT "check" ]; t = term -> + GrafiteAst.Check (loc, t) + | [ IDENT "hint" ] -> GrafiteAst.Hint loc + | [ IDENT "whelp"; "match" ] ; t = term -> + GrafiteAst.WMatch (loc,t) + | [ IDENT "whelp"; IDENT "instance" ] ; t = term -> + GrafiteAst.WInstance (loc,t) + | [ IDENT "whelp"; IDENT "locate" ] ; id = IDENT -> + GrafiteAst.WLocate (loc,id) + | [ IDENT "whelp"; IDENT "elim" ] ; t = term -> + GrafiteAst.WElim (loc, t) + | [ IDENT "whelp"; IDENT "hint" ] ; t = term -> + GrafiteAst.WHint (loc,t) + | [ IDENT "print" ]; name = QSTRING -> GrafiteAst.Print (loc, name) + ] + ]; + alias_spec: [ + [ IDENT "id"; id = QSTRING; SYMBOL "="; uri = QSTRING -> + let alpha = "[a-zA-Z]" in + let num = "[0-9]+" in + let ident_cont = "\\("^alpha^"\\|"^num^"\\|_\\|\\\\\\)" in + let ident = "\\("^alpha^ident_cont^"*\\|_"^ident_cont^"+\\)" in + let rex = Str.regexp ("^"^ident^"$") in + if Str.string_match rex id 0 then + if (try ignore (UriManager.uri_of_string uri); true + with UriManager.IllFormedUri _ -> false) + then + LexiconAst.Ident_alias (id, uri) + else + raise + (HExtlib.Localized (loc, CicNotationParser.Parse_error (sprintf "Not a valid uri: %s" uri))) + else + raise (HExtlib.Localized (loc, CicNotationParser.Parse_error ( + sprintf "Not a valid identifier: %s" id))) + | IDENT "symbol"; symbol = QSTRING; + instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ]; + SYMBOL "="; dsc = QSTRING -> + let instance = + match instance with Some i -> i | None -> 0 + in + LexiconAst.Symbol_alias (symbol, instance, dsc) + | IDENT "num"; + instance = OPT [ LPAREN; IDENT "instance"; n = int; RPAREN -> n ]; + SYMBOL "="; dsc = QSTRING -> + let instance = + match instance with Some i -> i | None -> 0 + in + LexiconAst.Number_alias (instance, dsc) + ] + ]; + argument: [ + [ l = LIST0 [ SYMBOL <:unicode> (* η *); SYMBOL "." -> () ]; + id = IDENT -> + Ast.IdentArg (List.length l, id) + ] + ]; + associativity: [ + [ IDENT "left"; IDENT "associative" -> Gramext.LeftA + | IDENT "right"; IDENT "associative" -> Gramext.RightA + | IDENT "non"; IDENT "associative" -> Gramext.NonA + ] + ]; + precedence: [ + [ "with"; IDENT "precedence"; n = NUMBER -> int_of_string n ] + ]; + notation: [ + [ dir = OPT direction; s = QSTRING; + assoc = OPT associativity; prec = OPT precedence; + IDENT "for"; + p2 = + [ blob = UNPARSED_AST -> + add_raw_attribute ~text:(sprintf "@{%s}" blob) + (CicNotationParser.parse_level2_ast + (Ulexing.from_utf8_string blob)) + | blob = UNPARSED_META -> + add_raw_attribute ~text:(sprintf "${%s}" blob) + (CicNotationParser.parse_level2_meta + (Ulexing.from_utf8_string blob)) + ] -> + let assoc = + match assoc with + | None -> default_associativity + | Some assoc -> assoc + in + let prec = + match prec with + | None -> default_precedence + | Some prec -> prec + in + let p1 = + add_raw_attribute ~text:s + (CicNotationParser.parse_level1_pattern + (Ulexing.from_utf8_string s)) + in + (dir, p1, assoc, prec, p2) + ] + ]; + level3_term: [ + [ u = URI -> Ast.UriPattern (UriManager.uri_of_string u) + | id = IDENT -> Ast.VarPattern id + | SYMBOL "_" -> Ast.ImplicitPattern + | LPAREN; terms = LIST1 SELF; RPAREN -> + (match terms with + | [] -> assert false + | [term] -> term + | terms -> Ast.ApplPattern terms) + ] + ]; + interpretation: [ + [ s = CSYMBOL; args = LIST0 argument; SYMBOL "="; t = level3_term -> + (s, args, t) + ] + ]; + + include_command: [ [ + IDENT "include" ; path = QSTRING -> loc,path + ]]; + + grafite_command: [ [ + IDENT "set"; n = QSTRING; v = QSTRING -> + GrafiteAst.Set (loc, n, v) + | IDENT "drop" -> GrafiteAst.Drop loc + | IDENT "qed" -> GrafiteAst.Qed loc + | IDENT "variant" ; name = IDENT; SYMBOL ":"; + typ = term; SYMBOL <:unicode> ; newname = IDENT -> + GrafiteAst.Obj (loc, + Ast.Theorem + (`Variant,name,typ,Some (Ast.Ident (newname, None)))) + | flavour = theorem_flavour; name = IDENT; SYMBOL ":"; typ = term; + body = OPT [ SYMBOL <:unicode> (* ≝ *); body = term -> body ] -> + GrafiteAst.Obj (loc, Ast.Theorem (flavour, name, typ, body)) + | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode> (* ≝ *); + body = term -> + GrafiteAst.Obj (loc, + Ast.Theorem (flavour, name, Ast.Implicit, Some body)) + | "let"; ind_kind = [ "corec" -> `CoInductive | "rec"-> `Inductive ]; + defs = CicNotationParser.let_defs -> + let name,ty = + match defs with + | ((Ast.Ident (name, None), Some ty),_,_) :: _ -> name,ty + | ((Ast.Ident (name, None), None),_,_) :: _ -> + name, Ast.Implicit + | _ -> assert false + in + let body = Ast.Ident (name,None) in + GrafiteAst.Obj (loc, Ast.Theorem(`Definition, name, ty, + Some (Ast.LetRec (ind_kind, defs, body)))) + | IDENT "inductive"; spec = inductive_spec -> + let (params, ind_types) = spec in + GrafiteAst.Obj (loc, Ast.Inductive (params, ind_types)) + | IDENT "coinductive"; spec = inductive_spec -> + let (params, ind_types) = spec in + let ind_types = (* set inductive flags to false (coinductive) *) + List.map (fun (name, _, term, ctors) -> (name, false, term, ctors)) + ind_types + in + GrafiteAst.Obj (loc, Ast.Inductive (params, ind_types)) + | IDENT "coercion" ; suri = URI -> + GrafiteAst.Coercion (loc, UriManager.uri_of_string suri, true) + | IDENT "record" ; (params,name,ty,fields) = record_spec -> + GrafiteAst.Obj (loc, Ast.Record (params,name,ty,fields)) + | IDENT "default" ; what = QSTRING ; uris = LIST1 URI -> + let uris = List.map UriManager.uri_of_string uris in + GrafiteAst.Default (loc,what,uris) + ]]; + lexicon_command: [ [ + IDENT "alias" ; spec = alias_spec -> + LexiconAst.Alias (loc, spec) + | IDENT "notation"; (dir, l1, assoc, prec, l2) = notation -> + LexiconAst.Notation (loc, dir, l1, assoc, prec, l2) + | IDENT "interpretation"; id = QSTRING; + (symbol, args, l3) = interpretation -> + LexiconAst.Interpretation (loc, id, (symbol, args), l3) + ]]; + executable: [ + [ cmd = grafite_command; SYMBOL "." -> GrafiteAst.Command (loc, cmd) + | tac = tactical; punct = punctuation_tactical -> + GrafiteAst.Tactical (loc, tac, Some punct) + | punct = punctuation_tactical -> GrafiteAst.Tactical (loc, punct, None) + | mac = macro; SYMBOL "." -> GrafiteAst.Macro (loc, mac) + ] + ]; + comment: [ + [ BEGINCOMMENT ; ex = executable ; ENDCOMMENT -> + GrafiteAst.Code (loc, ex) + | str = NOTE -> + GrafiteAst.Note (loc, str) + ] + ]; + statement: [ + [ ex = executable -> + fun ~include_paths status -> status,LSome(GrafiteAst.Executable (loc,ex)) + | com = comment -> + fun ~include_paths status -> status,LSome (GrafiteAst.Comment (loc, com)) + | (iloc,fname) = include_command ; SYMBOL "." -> + fun ~include_paths status -> + let path = DependenciesParser.baseuri_of_script ~include_paths fname in + let status = + LexiconEngine.eval_command status (LexiconAst.Include (iloc,path)) + in + status, + LSome + (GrafiteAst.Executable + (loc,GrafiteAst.Command + (loc,GrafiteAst.Include (iloc,path)))) + | scom = lexicon_command ; SYMBOL "." -> + fun ~include_paths status -> + let status = LexiconEngine.eval_command status scom in + status,LNone loc + | EOI -> raise End_of_file + ] + ]; +END + +let exc_located_wrapper f = + try + f () + with + | Stdpp.Exc_located (_, End_of_file) -> raise End_of_file + | Stdpp.Exc_located (floc, Stream.Error msg) -> + raise (HExtlib.Localized (floc,CicNotationParser.Parse_error msg)) + | Stdpp.Exc_located (floc, exn) -> + raise + (HExtlib.Localized (floc,CicNotationParser.Parse_error (Printexc.to_string exn))) + +let parse_statement lexbuf = + exc_located_wrapper + (fun () -> (Grammar.Entry.parse statement (Obj.magic lexbuf))) diff --git a/helm/software/components/grafite_parser/grafiteParser.mli b/helm/software/components/grafite_parser/grafiteParser.mli new file mode 100644 index 000000000..6a1980011 --- /dev/null +++ b/helm/software/components/grafite_parser/grafiteParser.mli @@ -0,0 +1,41 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +type 'a localized_option = + LSome of 'a + | LNone of Token.flocation + +type statement = + include_paths:string list -> + LexiconEngine.status -> + LexiconEngine.status * + (CicNotationPt.term, CicNotationPt.term, + CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) + GrafiteAst.statement localized_option + +val parse_statement: Ulexing.lexbuf -> statement (** @raise End_of_file *) + +val statement: statement Grammar.Entry.e + diff --git a/helm/software/components/grafite_parser/print_grammar.ml b/helm/software/components/grafite_parser/print_grammar.ml new file mode 100644 index 000000000..6a05865de --- /dev/null +++ b/helm/software/components/grafite_parser/print_grammar.ml @@ -0,0 +1,287 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Gramext + +let tex_of_unicode s = + let contractions = ("\\Longrightarrow","=>") :: [] in + if String.length s <= 1 then s + else (* probably an extended unicode symbol *) + let s = Utf8Macro.tex_of_unicode s in + try List.assoc s contractions with Not_found -> s + +let needs_brackets t = + let rec count_brothers = function + | Node {brother = brother} -> 1 + count_brothers brother + | _ -> 0 + in + count_brothers t > 1 + +let visit_description desc fmt self = + let skip s = List.mem s [ ] in + let inline s = List.mem s [ "int" ] in + + let rec visit_entry e todo is_son nesting = + let { ename = ename; edesc = desc } = e in + if inline ename then + visit_desc desc todo is_son nesting + else + begin + Format.fprintf fmt "%s " ename; + if skip ename then + todo + else + todo @ [e] + end + + and visit_desc d todo is_son nesting = + match d with + | Dlevels [] -> todo + | Dlevels [lev] -> visit_level lev todo is_son nesting + | Dlevels (lev::levels) -> + let todo = visit_level lev todo is_son nesting in + List.fold_left + (fun acc l -> + Format.fprintf fmt "@ | "; + visit_level l acc is_son nesting) + todo levels; + | _ -> todo + + and visit_level l todo is_son nesting = + let { lsuffix = suff ; lprefix = pref } = l in + let todo = visit_tree suff todo is_son nesting in + visit_tree pref todo is_son nesting + + and visit_tree t todo is_son nesting = + match t with + | Node node -> visit_node node todo is_son nesting + | _ -> todo + + and visit_node n todo is_son nesting = + let is_tree_printable t = + match t with + | Node _ -> true + | _ -> false + in + let { node = symbol; son = son ; brother = brother } = n in + let todo = visit_symbol symbol todo is_son nesting in + let todo = + if is_tree_printable son then + begin + let need_b = needs_brackets son in + if not is_son then + Format.fprintf fmt "@["; + if need_b then + Format.fprintf fmt "( "; + let todo = visit_tree son todo true nesting in + if need_b then + Format.fprintf fmt ")"; + if not is_son then + Format.fprintf fmt "@]"; + todo + end + else + todo + in + if is_tree_printable brother then + begin + Format.fprintf fmt "@ | "; + visit_tree brother todo is_son nesting + end + else + todo + + and visit_symbol s todo is_son nesting = + match s with + | Smeta (name, sl, _) -> + Format.fprintf fmt "%s " name; + List.fold_left ( + fun acc s -> + let todo = visit_symbol s acc is_son nesting in + if is_son then + Format.fprintf fmt "@ "; + todo) + todo sl + | Snterm entry -> visit_entry entry todo is_son nesting + | Snterml (entry,_) -> visit_entry entry todo is_son nesting + | Slist0 symbol -> + Format.fprintf fmt "{@[ "; + let todo = visit_symbol symbol todo is_son (nesting+1) in + Format.fprintf fmt "@]} @ "; + todo + | Slist0sep (symbol,sep) -> + Format.fprintf fmt "[@[ "; + let todo = visit_symbol symbol todo is_son (nesting + 1) in + Format.fprintf fmt "{@[ "; + let todo = visit_symbol sep todo is_son (nesting + 2) in + Format.fprintf fmt " "; + let todo = visit_symbol symbol todo is_son (nesting + 2) in + Format.fprintf fmt "@]} @]] @ "; + todo + | Slist1 symbol -> + Format.fprintf fmt "{@[ "; + let todo = visit_symbol symbol todo is_son (nesting + 1) in + Format.fprintf fmt "@]}+ @ "; + todo + | Slist1sep (symbol,sep) -> + let todo = visit_symbol symbol todo is_son nesting in + Format.fprintf fmt "{@[ "; + let todo = visit_symbol sep todo is_son (nesting + 1) in + let todo = visit_symbol symbol todo is_son (nesting + 1) in + Format.fprintf fmt "@]} @ "; + todo + | Sopt symbol -> + Format.fprintf fmt "[@[ "; + let todo = visit_symbol symbol todo is_son (nesting + 1) in + Format.fprintf fmt "@]] @ "; + todo + | Sself -> Format.fprintf fmt "%s " self; todo + | Snext -> Format.fprintf fmt "next "; todo + | Stoken pattern -> + let constructor, keyword = pattern in + if keyword = "" then + Format.fprintf fmt "`%s' " constructor + else + Format.fprintf fmt "\"%s\" " (tex_of_unicode keyword); + todo + | Stree tree -> + if needs_brackets tree then + begin + Format.fprintf fmt "@[( "; + let todo = visit_tree tree todo is_son (nesting + 1) in + Format.fprintf fmt ")@] @ "; + todo + end + else + visit_tree tree todo is_son (nesting + 1) + in + visit_desc desc [] false 0 +;; + +let rec clean_dummy_desc = function + | Dlevels l -> Dlevels (clean_levels l) + | x -> x + +and clean_levels = function + | [] -> [] + | l :: tl -> clean_level l @ clean_levels tl + +and clean_level = function + | x -> + let pref = clean_tree x.lprefix in + let suff = clean_tree x.lsuffix in + match pref,suff with + | DeadEnd, DeadEnd -> [] + | _ -> [{x with lprefix = pref; lsuffix = suff}] + +and clean_tree = function + | Node n -> clean_node n + | x -> x + +and clean_node = function + | {node=node;son=son;brother=brother} -> + let bn = is_symbol_dummy node in + let bs = is_tree_dummy son in + let bb = is_tree_dummy brother in + let son = if bs then DeadEnd else son in + let brother = if bb then DeadEnd else brother in + if bb && bs && bn then + DeadEnd + else + if bn then + Node {node=Sself;son=son;brother=brother} + else + Node {node=node;son=son;brother=brother} + +and is_level_dummy = function + | {lsuffix=lsuffix;lprefix=lprefix} -> + is_tree_dummy lsuffix && is_tree_dummy lprefix + +and is_desc_dummy = function + | Dlevels l -> List.for_all is_level_dummy l + | Dparser _ -> true + +and is_entry_dummy = function + | {edesc=edesc} -> is_desc_dummy edesc + +and is_symbol_dummy = function + | Stoken ("DUMMY", _) -> true + | Stoken _ -> false + | Smeta (_, lt, _) -> List.for_all is_symbol_dummy lt + | Snterm e | Snterml (e, _) -> is_entry_dummy e + | Slist1 x | Slist0 x -> is_symbol_dummy x + | Slist1sep (x,y) | Slist0sep (x,y) -> is_symbol_dummy x && is_symbol_dummy y + | Sopt x -> is_symbol_dummy x + | Sself | Snext -> false + | Stree t -> is_tree_dummy t + +and is_tree_dummy = function + | Node {node=node} -> is_symbol_dummy node + | _ -> true +;; + + +let rec visit_entries todo pped = + let fmt = Format.std_formatter in + match todo with + | [] -> () + | hd :: tl -> + let todo = + if not (List.memq hd pped) then + begin + let { ename = ename; edesc = desc } = hd in + Format.fprintf fmt "@[%s ::=@ " ename; + let desc = clean_dummy_desc desc in + let todo = visit_description desc fmt ename @ todo in + Format.fprintf fmt "@]"; + Format.pp_print_newline fmt (); + Format.pp_print_newline fmt (); + todo + end + else + todo + in + let clean_todo todo = + let name_of_entry e = e.ename in + let pped = hd :: pped in + let todo = tl @ todo in + let todo = List.filter (fun e -> not(List.memq e pped)) todo in + HExtlib.list_uniq + ~eq:(fun e1 e2 -> (name_of_entry e1) = (name_of_entry e2)) + (List.sort + (fun e1 e2 -> + Pervasives.compare (name_of_entry e1) (name_of_entry e2)) + todo), + pped + in + let todo,pped = clean_todo todo in + visit_entries todo pped +;; + +let _ = + let g_entry = Grammar.Entry.obj GrafiteParser.statement in + visit_entries [g_entry] [] diff --git a/helm/software/components/grafite_parser/test_dep.ml b/helm/software/components/grafite_parser/test_dep.ml new file mode 100644 index 000000000..2d0f7813f --- /dev/null +++ b/helm/software/components/grafite_parser/test_dep.ml @@ -0,0 +1,40 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let _ = + let ic = ref stdin in + let usage = "test_coarse_parser [ file ]" in + let open_file fname = + if !ic <> stdin then close_in !ic; + ic := open_in fname + in + Arg.parse [] open_file usage; + let deps = + DependenciesParser.parse_dependencies (Ulexing.from_utf8_channel !ic) + in + List.iter (fun dep -> print_endline (DependenciesParser.pp_dependency dep)) deps + diff --git a/helm/software/components/grafite_parser/test_parser.ml b/helm/software/components/grafite_parser/test_parser.ml new file mode 100644 index 000000000..2deef1bd5 --- /dev/null +++ b/helm/software/components/grafite_parser/test_parser.ml @@ -0,0 +1,133 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let _ = Helm_registry.load_from "test_parser.conf.xml" + +let xml_stream_of_markup = + let rec print_box (t: CicNotationPres.boxml_markup) = + Box.box2xml print_mpres t + and print_mpres (t: CicNotationPres.mathml_markup) = + Mpresentation.print_mpres print_box t + in + print_mpres + +let dump_xml t id_to_uri fname = + prerr_endline (sprintf "dumping MathML to %s ..." fname); + flush stdout; + let oc = open_out fname in + let markup = CicNotationPres.render id_to_uri t in + let xml_stream = CicNotationPres.print_xml markup in + Xml.pp_to_outchan xml_stream oc; + close_out oc + +let extract_loc = + function + | GrafiteAst.Executable (loc, _) + | GrafiteAst.Comment (loc, _) -> loc + +let pp_associativity = function + | Gramext.LeftA -> "left" + | Gramext.RightA -> "right" + | Gramext.NonA -> "non" + +let pp_precedence = string_of_int + +(* let last_rule_id = ref None *) + +let process_stream istream = + let char_count = ref 0 in + let module P = CicNotationPt in + let module G = GrafiteAst in + let status = + ref + (CicNotation2.load_notation + ~include_paths:[] (Helm_registry.get "notation.core_file")) + in + try + while true do + try + match + GrafiteParser.parse_statement ~include_paths:[] istream !status + with + newstatus, GrafiteParser.LNone _ -> status := newstatus + | newstatus, GrafiteParser.LSome statement -> + status := newstatus; + let floc = extract_loc statement in + let (_, y) = HExtlib.loc_of_floc floc in + char_count := y + !char_count; + match statement with + (* | G.Executable (_, G.Macro (_, G.Check (_, + P.AttributedTerm (_, P.Ident _)))) -> + prerr_endline "mega hack"; + (match !last_rule_id with + | None -> () + | Some id -> + prerr_endline "removing last notation rule ..."; + CicNotationParser.delete id) *) + | G.Executable (_, G.Macro (_, G.Check (_, t))) -> + prerr_endline (sprintf "ast: %s" (CicNotationPp.pp_term t)); + let t' = TermContentPres.pp_ast t in + prerr_endline (sprintf "rendered ast: %s" + (CicNotationPp.pp_term t')); + let tbl = Hashtbl.create 0 in + dump_xml t' tbl "out.xml" + | statement -> + prerr_endline + ("Unsupported statement: " ^ + GrafiteAstPp.pp_statement + ~term_pp:CicNotationPp.pp_term + ~lazy_term_pp:(fun _ -> "_lazy_term_here_") + ~obj_pp:(fun _ -> "_obj_here_") + statement) + with + | End_of_file -> raise End_of_file + | HExtlib.Localized (floc,CicNotationParser.Parse_error msg) -> + let (x, y) = HExtlib.loc_of_floc floc in +(* let before = String.sub line 0 x in + let error = String.sub line x (y - x) in + let after = String.sub line y (String.length line - y) in + eprintf "%s%s%s\n" before error after; + prerr_endline (sprintf "at character %d-%d: %s" x y msg) *) + prerr_endline (sprintf "Parse error at character %d-%d: %s" + (!char_count + x) (!char_count + y) msg) + | exn -> + prerr_endline + (sprintf "Uncaught exception: %s" (Printexc.to_string exn)) + done + with End_of_file -> () + +let _ = + let arg_spec = [ ] in + let usage = "" in + Arg.parse arg_spec (fun _ -> raise (Arg.Bad usage)) usage; + print_endline "Loading builtin notation ..."; + print_endline "done."; + flush stdout; + process_stream (Ulexing.from_utf8_channel stdin) + diff --git a/helm/software/components/hbugs/.depend b/helm/software/components/hbugs/.depend new file mode 100644 index 000000000..d6a85b905 --- /dev/null +++ b/helm/software/components/hbugs/.depend @@ -0,0 +1,20 @@ +hbugs_common.cmi: hbugs_types.cmi +hbugs_id_generator.cmi: hbugs_types.cmi +hbugs_messages.cmi: hbugs_types.cmi +hbugs_client.cmi: hbugs_types.cmi +hbugs_misc.cmo: hbugs_misc.cmi +hbugs_misc.cmx: hbugs_misc.cmi +hbugs_common.cmo: hbugs_types.cmi hbugs_common.cmi +hbugs_common.cmx: hbugs_types.cmi hbugs_common.cmi +hbugs_id_generator.cmo: hbugs_id_generator.cmi +hbugs_id_generator.cmx: hbugs_id_generator.cmi +hbugs_messages.cmo: hbugs_types.cmi hbugs_misc.cmi hbugs_messages.cmi +hbugs_messages.cmx: hbugs_types.cmi hbugs_misc.cmx hbugs_messages.cmi +hbugs_client_gui.cmo: hbugs_client_gui.cmi +hbugs_client_gui.cmx: hbugs_client_gui.cmi +hbugs_client.cmo: hbugs_types.cmi hbugs_misc.cmi hbugs_messages.cmi \ + hbugs_id_generator.cmi hbugs_common.cmi hbugs_client_gui.cmi \ + hbugs_client.cmi +hbugs_client.cmx: hbugs_types.cmi hbugs_misc.cmx hbugs_messages.cmx \ + hbugs_id_generator.cmx hbugs_common.cmx hbugs_client_gui.cmx \ + hbugs_client.cmi diff --git a/helm/software/components/hbugs/Makefile b/helm/software/components/hbugs/Makefile new file mode 100644 index 000000000..4170d8081 --- /dev/null +++ b/helm/software/components/hbugs/Makefile @@ -0,0 +1,98 @@ + +# Targets description: +# all (default) -> builds hbugs bytecode library hbugs.cma +# opt -> builds hbugs native library hbugs.cmxa +# daemons -> builds hbugs broker and tutors executables +# +# start -> starts up broker and tutors +# stop -> stop broker and tutors +# +# broker -> builds broker executable +# tutors -> builds tutors executables +# client -> builds hbugs client + +PACKAGE = hbugs + +IMPLEMENTATION_FILES = \ + hbugs_misc.ml \ + hbugs_common.ml \ + hbugs_id_generator.ml \ + hbugs_messages.ml \ + hbugs_client_gui.ml \ + hbugs_client.ml +INTERFACE_FILES = \ + hbugs_types.mli \ + $(patsubst %.ml, %.mli, $(IMPLEMENTATION_FILES)) + +include ../../Makefile.defs +include ../Makefile.common +include .tutors.ml +include .generated_tutors.ml + +.tutors.ml: + echo -n "TUTORS_ML = " > $@ + scripts/ls_tutors.ml | xargs >> $@ +.generated_tutors.ml: + echo -n "GENERATED_TUTORS_ML = " > $@ + scripts/ls_tutors.ml -auto | xargs >> $@ + +TUTORS = $(patsubst %.ml, %, $(TUTORS_ML)) +TUTORS_OPT = $(patsubst %, %.opt, $(TUTORS)) +GENERATED_TUTORS = $(patsubst %.ml, %, $(GENERATED_TUTORS_ML)) + +hbugs_client_gui.ml hbugs_client_gui.mli: hbugs_client_gui.glade + lablgladecc2 $< > hbugs_client_gui.ml + $(OCAMLC) -i hbugs_client_gui.ml > hbugs_client_gui.mli + +clean: clean_mains +.PHONY: clean_mains +clean_mains: + rm -f $(TUTORS) $(TUTORS_OPT) broker{,.opt} client{,.opt} +distclean: clean + rm -f $(GENERATED_TUTORS_ML) hbugs_client_gui.ml{,i} + rm -f .tutors.ml .generated_tutors.ml + +MAINS_DEPS = \ + hbugs_misc.cmo \ + hbugs_messages.cmo \ + hbugs_id_generator.cmo +TUTOR_DEPS = $(MAINS_DEPS) \ + hbugs_tutors.cmo +BROKER_DEPS = $(MAINS_DEPS) \ + hbugs_broker_registry.cmo +CLIENT_DEPS = $(MAINS_DEPS) \ + hbugs_client_gui.cmo \ + hbugs_common.cmo \ + hbugs_client.cmo +TUTOR_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(TUTOR_DEPS)) +BROKER_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(BROKER_DEPS)) +CLIENT_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(CLIENT_DEPS)) +$(GENERATED_TUTORS_ML): scripts/build_tutors.ml data/tutors_index.xml data/hbugs_tutor.TPL.ml + scripts/build_tutors.ml +hbugs_tutors.cmo: hbugs_tutors.cmi +hbugs_broker_registry.cmo: hbugs_broker_registry.cmi +.PHONY: daemons +daemons: tutors broker +.PHONY: tutors +tutors: all $(TUTORS) +%_tutor: $(TUTOR_DEPS) %_tutor.ml + $(OCAMLC) -linkpkg -o $@ $^ +%_tutor.opt: $(TUTOR_DEPS_OPT) %_tutor.ml + $(OCAMLOPT) -linkpkg -o $@ $^ +broker: $(BROKER_DEPS) broker.ml + $(OCAMLC) -linkpkg -o $@ $^ +broker.opt: $(BROKER_DEPS_OPT) broker.ml + $(OCAMLOPT) -linkpkg -o $@ $^ +client: $(CLIENT_DEPS) client.ml + $(OCAMLC) -linkpkg -o $@ $^ +client.opt: $(CLIENT_DEPS_OPT) client.ml + $(OCAMLOPT) -linkpkg -o $@ $^ + +.PHONY: start stop +start: + scripts/brokerctl.sh start + scripts/sabba.sh start +stop: + scripts/brokerctl.sh stop + scripts/sabba.sh stop + diff --git a/helm/software/components/hbugs/broker.ml b/helm/software/components/hbugs/broker.ml new file mode 100644 index 000000000..691f9d11a --- /dev/null +++ b/helm/software/components/hbugs/broker.ml @@ -0,0 +1,293 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_types;; +open Printf;; + +let debug = true ;; +let debug_print s = if debug then prerr_endline (Lazy.force s) ;; + +let daemon_name = "H-Bugs Broker" ;; +let default_port = 49081 ;; +let port_env_var = "HELM_HBUGS_BROKER_PORT" ;; +let port = + try + int_of_string (Sys.getenv port_env_var) + with + | Not_found -> default_port + | Failure "int_of_string" -> + prerr_endline "Warning: invalid port, reverting to default"; + default_port +;; +let usage_string = "HBugs Broker: usage string not yet written :-(";; + +exception Unexpected_msg of message;; + +let return_xml_msg body outchan = + Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan +;; +let parse_musing_id = function + | Musing_started (_, musing_id) -> + prerr_endline ("#### Started musing ID: " ^ musing_id); + musing_id + | Musing_aborted (_, musing_id) -> musing_id + | msg -> + prerr_endline (sprintf "Assertion failed, received msg: %s" + (Hbugs_messages.string_of_msg msg)); + assert false +;; + +let do_critical = + let mutex = Mutex.create () in + fun action -> + try +(* debug_print (lazy "Acquiring lock ..."); *) + Mutex.lock mutex; +(* debug_print (lazy "Lock Acquired!"); *) + let res = Lazy.force action in +(* debug_print (lazy "Releaseing lock ..."); *) + Mutex.unlock mutex; +(* debug_print (lazy "Lock released!"); *) + res + with e -> Mutex.unlock mutex; raise e +;; + + (* registries *) +let clients = new Hbugs_broker_registry.clients in +let tutors = new Hbugs_broker_registry.tutors in +let musings = new Hbugs_broker_registry.musings in +let registries = + [ (clients :> Hbugs_broker_registry.registry); + (tutors :> Hbugs_broker_registry.registry); + (musings :> Hbugs_broker_registry.registry) ] +in + +let my_own_id = Hbugs_id_generator.new_broker_id () in + + (* debugging: dump broker internal status, used by '/dump' method *) +let dump_registries () = + assert debug; + String.concat "\n" (List.map (fun o -> o#dump) registries) +in + +let handle_msg outchan msg = + (* messages from clients *) + (match msg with + + | Help -> + Hbugs_messages.respond_msg (Usage usage_string) outchan + | Register_client (client_id, client_url) -> do_critical (lazy ( + try + clients#register client_id client_url; + Hbugs_messages.respond_msg (Client_registered my_own_id) outchan + with Hbugs_broker_registry.Client_already_in id -> + Hbugs_messages.respond_exc "already_registered" id outchan + )) + | Unregister_client client_id -> do_critical (lazy ( + if clients#isAuthenticated client_id then begin + clients#unregister client_id; + Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan + end else + Hbugs_messages.respond_exc "forbidden" client_id outchan + )) + | List_tutors client_id -> do_critical (lazy ( + if clients#isAuthenticated client_id then begin + Hbugs_messages.respond_msg + (Tutor_list (my_own_id, tutors#index)) + outchan + end else + Hbugs_messages.respond_exc "forbidden" client_id outchan + )) + | Subscribe (client_id, tutor_ids) -> do_critical (lazy ( + if clients#isAuthenticated client_id then begin + if List.length tutor_ids <> 0 then begin (* at least one tutor id *) + if List.for_all tutors#exists tutor_ids then begin + clients#subscribe client_id tutor_ids; + Hbugs_messages.respond_msg + (Subscribed (my_own_id, tutor_ids)) outchan + end else (* required subscription to at least one unexistent tutor *) + let missing_tutors = + List.filter (fun id -> not (tutors#exists id)) tutor_ids + in + Hbugs_messages.respond_exc + "tutor_not_found" (String.concat " " missing_tutors) outchan + end else (* no tutor id specified *) + Hbugs_messages.respond_exc "no_tutor_specified" "" outchan + end else + Hbugs_messages.respond_exc "forbidden" client_id outchan + )) + | State_change (client_id, new_state) -> do_critical (lazy ( + if clients#isAuthenticated client_id then begin + let active_musings = musings#getByClientId client_id in + prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings)); + if List.length active_musings = 0 then + prerr_endline ("No active musings for client " ^ client_id); + prerr_endline "CSC: State change!!!" ; + let stop_answers = + List.map (* collect Abort_musing message's responses *) + (fun id -> (* musing id *) + let tutor = snd (musings#getByMusingId id) in + Hbugs_messages.submit_req + ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id))) + active_musings + in + let stopped_musing_ids = List.map parse_musing_id stop_answers in + List.iter musings#unregister active_musings; + (match new_state with + | Some new_state -> (* need to start new musings *) + let subscriptions = clients#getSubscription client_id in + if List.length subscriptions = 0 then + prerr_endline ("No subscriptions for client " ^ client_id); + let started_musing_ids = + List.map (* register new musings and collect their ids *) + (fun tutor_id -> + let res = + Hbugs_messages.submit_req + ~url:(tutors#getUrl tutor_id) + (Start_musing (my_own_id, new_state)) + in + let musing_id = parse_musing_id res in + musings#register musing_id client_id tutor_id; + musing_id) + subscriptions + in + Hbugs_messages.respond_msg + (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids)) + outchan + | None -> (* no need to start new musings *) + Hbugs_messages.respond_msg + (State_accepted (my_own_id, stopped_musing_ids, [])) + outchan) + end else + Hbugs_messages.respond_exc "forbidden" client_id outchan + )) + + (* messages from tutors *) + + | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy ( + try + tutors#register tutor_id tutor_url hint_type dsc; + Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan + with Hbugs_broker_registry.Tutor_already_in id -> + Hbugs_messages.respond_exc "already_registered" id outchan + )) + | Unregister_tutor tutor_id -> do_critical (lazy ( + if tutors#isAuthenticated tutor_id then begin + tutors#unregister tutor_id; + Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan + end else + Hbugs_messages.respond_exc "forbidden" tutor_id outchan + )) + + | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy ( + if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *) + Hbugs_messages.respond_exc "forbidden" tutor_id outchan; + end else if not (musings#isActive musing_id) then begin (* too late *) + Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan; + end else begin (* all is ok: autorhized and on time *) + (match result with + | Sorry -> () + | Eureka hint -> + let client_url = + clients#getUrl (fst (musings#getByMusingId musing_id)) + in + let res = + Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint)) + in + (match res with + | Wow _ -> () (* ok: client is happy with our hint *) + | unexpected_msg -> + prerr_endline + (sprintf + "Warning: unexpected msg from client: %s\nExpected was: Wow" + (Hbugs_messages.string_of_msg msg)))); + Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan; + musings#unregister musing_id + end + )) + + | msg -> (* unexpected message *) + debug_print (lazy "Unknown message!"); + Hbugs_messages.respond_exc + "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan) +in +(* (* DEBUGGING wrapper around 'handle_msg' *) +let handle_msg outchan = + if debug then + (fun msg -> (* filter handle_msg through a function which dumps input + messages *) + debug_print (lazy (Hbugs_messages.string_of_msg msg)); + handle_msg outchan msg) + else + handle_msg outchan +in +*) + + (* thread action *) +let callback (req: Http_types.request) outchan = + try + debug_print (lazy ("Connection from " ^ req#clientAddr)); + debug_print (lazy ("Received request: " ^ req#path)); + (match req#path with + (* TODO write help message *) + | "/help" -> return_xml_msg " not yet written " outchan + | "/act" -> + let msg = Hbugs_messages.msg_of_string req#body in + handle_msg outchan msg + | "/dump" -> + if debug then + Http_daemon.respond ~body:(dump_registries ()) outchan + else + Http_daemon.respond_error ~code:400 outchan + | _ -> Http_daemon.respond_error ~code:400 outchan); + debug_print (lazy "Done!\n") + with + | Http_types.Param_not_found attr_name -> + Hbugs_messages.respond_exc "missing_parameter" attr_name outchan + | exc -> + Hbugs_messages.respond_exc + "uncaught_exception" (Printexc.to_string exc) outchan +in + + (* thread who cleans up ancient client/tutor/musing registrations *) +let ragman () = + let delay = 3600.0 in (* 1 hour delay *) + while true do + Thread.delay delay; + List.iter (fun o -> o#purge) registries + done +in + + (* start daemon *) +printf "Listening on port %d ...\n" port; +flush stdout; +ignore (Thread.create ragman ()); +Http_daemon.start' ~port ~mode:`Thread callback + diff --git a/helm/software/components/hbugs/client.ml b/helm/software/components/hbugs/client.ml new file mode 100644 index 000000000..93114b305 --- /dev/null +++ b/helm/software/components/hbugs/client.ml @@ -0,0 +1,46 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_common;; +open Printf;; + +let client = + new Hbugs_client.hbugsClient + ~use_hint_callback: + (fun hint -> + prerr_endline (sprintf "Using hint: %s" (string_of_hint hint))) + ~describe_hint_callback: + (fun hint -> + prerr_endline (sprintf "Describing hint: %s" (string_of_hint hint))) + () +in +client#show (); +GtkThread.main () + diff --git a/helm/software/components/hbugs/data/hbugs_tutor.TPL.ml b/helm/software/components/hbugs/data/hbugs_tutor.TPL.ml new file mode 100644 index 000000000..947e351c7 --- /dev/null +++ b/helm/software/components/hbugs/data/hbugs_tutor.TPL.ml @@ -0,0 +1,42 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +module TutorDescription = + struct + let addr = "@ADDR@" + let port = @PORT@ + let tactic = @TACTIC@ + let hint = @HINT@ + let hint_type = "@HINT_TYPE@" + let description = "@DESCRIPTION@" + let environment_file = "@ENVIRONMENT_FILE@" + end +;; +module Tutor = Hbugs_tutors.BuildTutor (TutorDescription) ;; +Tutor.start () ;; + diff --git a/helm/software/components/hbugs/data/tutors_index.xml b/helm/software/components/hbugs/data/tutors_index.xml new file mode 100644 index 000000000..bd4baad45 --- /dev/null +++ b/helm/software/components/hbugs/data/tutors_index.xml @@ -0,0 +1,140 @@ + + + + + + + + + 127.0.0.1 + 50001 + Ring.ring_tac + Hbugs_types.Use_ring_Luke + Use Ring Luke + Ring tutor + ring.environment + + + 127.0.0.1 + 50002 + FourierR.fourier_tac + Hbugs_types.Use_fourier_Luke + Use Fourier Luke + Fourier tutor + fourier.environment + + + 127.0.0.1 + 50003 + EqualityTactics.reflexivity_tac + Hbugs_types.Use_reflexivity_Luke + Use Reflexivity Luke + Reflexivity tutor + reflexivity.environment + + + 127.0.0.1 + 50004 + EqualityTactics.symmetry_tac + Hbugs_types.Use_symmetry_Luke + Use Symmetry Luke + Symmetry tutor + symmetry.environment + + + 127.0.0.1 + 50005 + VariousTactics.assumption_tac + Hbugs_types.Use_assumption_Luke + Use Assumption Luke + Assumption tutor + assumption.environment + + + 127.0.0.1 + 50006 + NegationTactics.contradiction_tac + Hbugs_types.Use_contradiction_Luke + Use Contradiction Luke + Contradiction tutor + contradiction.environment + + + 127.0.0.1 + 50007 + IntroductionTactics.exists_tac + Hbugs_types.Use_exists_Luke + Use Exists Luke + Exists tutor + exists.environment + + + 127.0.0.1 + 50008 + IntroductionTactics.split_tac + Hbugs_types.Use_split_Luke + Use Split Luke + Split tutor + split.environment + + + 127.0.0.1 + 50009 + IntroductionTactics.left_tac + Hbugs_types.Use_left_Luke + Use Left Luke + Left tutor + left.environment + + + 127.0.0.1 + 50010 + IntroductionTactics.right_tac + Hbugs_types.Use_right_Luke + Use Right Luke + Right tutor + right.environment + + + + 127.0.0.1 + 50011 + PrimitiveTactics.apply_tac + Hbugs_types.Use_apply_Luke + Use Apply Luke (with argument) + Search pattern apply tutor + search_pattern_apply.environment + + + diff --git a/helm/software/components/hbugs/doc/hbugs.dia b/helm/software/components/hbugs/doc/hbugs.dia new file mode 100644 index 000000000..b1c4e64e2 Binary files /dev/null and b/helm/software/components/hbugs/doc/hbugs.dia differ diff --git a/helm/software/components/hbugs/hbugs_broker_registry.ml b/helm/software/components/hbugs/hbugs_broker_registry.ml new file mode 100644 index 000000000..4670b5eca --- /dev/null +++ b/helm/software/components/hbugs/hbugs_broker_registry.ml @@ -0,0 +1,317 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_misc;; +open Hbugs_types;; +open Printf;; + +exception Client_already_in of client_id;; +exception Client_not_found of client_id;; +exception Musing_already_in of musing_id;; +exception Musing_not_found of musing_id;; +exception Tutor_already_in of tutor_id;; +exception Tutor_not_found of tutor_id;; + +class type registry = + object + method dump: string + method purge: unit + end + +let expire_time = 1800. (* 30 minutes *) + +class clients = + object (self) + + inherit ThreadSafe.threadSafe +(* + (* *) + method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + (* *) +*) + + val timetable: (client_id, float) Hashtbl.t = Hashtbl.create 17 + val urls: (client_id, string) Hashtbl.t = Hashtbl.create 17 + val subscriptions: (client_id, tutor_id list) Hashtbl.t = Hashtbl.create 17 + + (** INVARIANT: each client registered has an entry in 'urls' hash table + _and_ in 'subscriptions hash table even if it hasn't yet invoked + 'subscribe' method *) + + method register id url = self#doWriter (lazy ( + if Hashtbl.mem urls id then + raise (Client_already_in id) + else begin + Hashtbl.add urls id url; + Hashtbl.add subscriptions id []; + Hashtbl.add timetable id (Unix.time ()) + end + )) + method private remove id = + Hashtbl.remove urls id; + Hashtbl.remove subscriptions id; + Hashtbl.remove timetable id + method unregister id = self#doWriter (lazy ( + if Hashtbl.mem urls id then + self#remove id + else + raise (Client_not_found id) + )) + method isAuthenticated id = self#doReader (lazy ( + Hashtbl.mem urls id + )) + method subscribe client_id tutor_ids = self#doWriter (lazy ( + if Hashtbl.mem urls client_id then + Hashtbl.replace subscriptions client_id tutor_ids + else + raise (Client_not_found client_id) + )) + method getUrl id = self#doReader (lazy ( + if Hashtbl.mem urls id then + Hashtbl.find urls id + else + raise (Client_not_found id) + )) + method getSubscription id = self#doReader (lazy ( + if Hashtbl.mem urls id then + Hashtbl.find subscriptions id + else + raise (Client_not_found id) + )) + + method dump = self#doReader (lazy ( + "\n" ^ + (Hashtbl.fold + (fun id url dump -> + (dump ^ + (sprintf "\n" id url) ^ + "\n" ^ + (String.concat "\n" (* id's subscriptions *) + (List.map + (fun tutor_id -> sprintf "\n" tutor_id) + (Hashtbl.find subscriptions id))) ^ + "\n\n")) + urls "") ^ + "" + )) + method purge = self#doWriter (lazy ( + let now = Unix.time () in + Hashtbl.iter + (fun id birthday -> + if now -. birthday > expire_time then + self#remove id) + timetable + )) + + end + +class tutors = + object (self) + + inherit ThreadSafe.threadSafe +(* + (* *) + method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + (* *) +*) + + val timetable: (tutor_id, float) Hashtbl.t = Hashtbl.create 17 + val tbl: (tutor_id, string * hint_type * string) Hashtbl.t = + Hashtbl.create 17 + + method register id url hint_type dsc = self#doWriter (lazy ( + if Hashtbl.mem tbl id then + raise (Tutor_already_in id) + else begin + Hashtbl.add tbl id (url, hint_type, dsc); + Hashtbl.add timetable id (Unix.time ()) + end + )) + method private remove id = + Hashtbl.remove tbl id; + Hashtbl.remove timetable id + method unregister id = self#doWriter (lazy ( + if Hashtbl.mem tbl id then + self#remove id + else + raise (Tutor_not_found id) + )) + method isAuthenticated id = self#doReader (lazy ( + Hashtbl.mem tbl id + )) + method exists id = self#doReader (lazy ( + Hashtbl.mem tbl id + )) + method getTutor id = self#doReader (lazy ( + if Hashtbl.mem tbl id then + Hashtbl.find tbl id + else + raise (Tutor_not_found id) + )) + method getUrl id = + let (url, _, _) = self#getTutor id in + url + method getHintType id = + let (_, hint_type, _) = self#getTutor id in + hint_type + method getDescription id = + let (_, _, dsc) = self#getTutor id in + dsc + method index = self#doReader (lazy ( + Hashtbl.fold + (fun id (url, hint_type, dsc) idx -> (id, dsc) :: idx) tbl [] + )) + + method dump = self#doReader (lazy ( + "\n" ^ + (Hashtbl.fold + (fun id (url, hint_type, dsc) dump -> + dump ^ + (sprintf +"\n%s\n%s\n" + id url hint_type dsc)) + tbl "") ^ + "" + )) + method purge = self#doWriter (lazy ( + let now = Unix.time () in + Hashtbl.iter + (fun id birthday -> + if now -. birthday > expire_time then + self#remove id) + timetable + )) + + end + +class musings = + object (self) + + inherit ThreadSafe.threadSafe +(* + (* *) + method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act + (* *) +*) + + val timetable: (musing_id, float) Hashtbl.t = Hashtbl.create 17 + val musings: (musing_id, client_id * tutor_id) Hashtbl.t = Hashtbl.create 17 + val clients: (client_id, musing_id list) Hashtbl.t = Hashtbl.create 17 + val tutors: (tutor_id, musing_id list) Hashtbl.t = Hashtbl.create 17 + + (** INVARIANT: each registered musing has + an entry in 'musings' table, an entry in 'clients' (i.e. one of the + musings for client_id is musing_id) table, an entry in 'tutors' table + (i.e. one of the musings for tutor_id is musing_id) and an entry in + 'timetable' table *) + + + method register musing_id client_id tutor_id = self#doWriter (lazy ( + if Hashtbl.mem musings musing_id then + raise (Musing_already_in musing_id) + else begin + Hashtbl.add musings musing_id (client_id, tutor_id); + (* now add this musing as the first one of musings list for client and + tutor *) + Hashtbl.replace clients client_id + (musing_id :: + (try Hashtbl.find clients client_id with Not_found -> [])); + Hashtbl.replace tutors tutor_id + (musing_id :: + (try Hashtbl.find tutors tutor_id with Not_found -> [])); + Hashtbl.add timetable musing_id (Unix.time ()) + end + )) + method private remove id = + (* ASSUMPTION: this method is invoked under a 'writer' lock *) + let (client_id, tutor_id) = self#getByMusingId' id in + Hashtbl.remove musings id; + (* now remove this musing from the list of musings for client and tutor + *) + Hashtbl.replace clients client_id + (List.filter ((<>) id) + (try Hashtbl.find clients client_id with Not_found -> [])); + Hashtbl.replace tutors tutor_id + (List.filter ((<>) id) + (try Hashtbl.find tutors tutor_id with Not_found -> [])); + Hashtbl.remove timetable id + method unregister id = self#doWriter (lazy ( + if Hashtbl.mem musings id then + self#remove id + )) + method private getByMusingId' id = + (* ASSUMPTION: this method is invoked under a 'reader' lock *) + try + Hashtbl.find musings id + with Not_found -> raise (Musing_not_found id) + method getByMusingId id = self#doReader (lazy ( + self#getByMusingId' id + )) + method getByClientId id = self#doReader (lazy ( + try + Hashtbl.find clients id + with Not_found -> [] + )) + method getByTutorId id = self#doReader (lazy ( + try + Hashtbl.find tutors id + with Not_found -> [] + )) + method isActive id = self#doReader (lazy ( + Hashtbl.mem musings id + )) + + method dump = self#doReader (lazy ( + "\n" ^ + (Hashtbl.fold + (fun mid (cid, tid) dump -> + dump ^ + (sprintf "\n" + mid cid tid)) + musings "") ^ + "" + )) + method purge = self#doWriter (lazy ( + let now = Unix.time () in + Hashtbl.iter + (fun id birthday -> + if now -. birthday > expire_time then + self#remove id) + timetable + )) + + end + diff --git a/helm/software/components/hbugs/hbugs_broker_registry.mli b/helm/software/components/hbugs/hbugs_broker_registry.mli new file mode 100644 index 000000000..ece9e07cf --- /dev/null +++ b/helm/software/components/hbugs/hbugs_broker_registry.mli @@ -0,0 +1,87 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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;; + +exception Client_already_in of client_id +exception Client_not_found of client_id +exception Musing_already_in of musing_id +exception Musing_not_found of musing_id +exception Tutor_already_in of tutor_id +exception Tutor_not_found of tutor_id + +class type registry = + object + method dump: string + method purge: unit + end + +class clients: + object + (** 'register client_id client_url' *) + method register: client_id -> string -> unit + method unregister: client_id -> unit + method isAuthenticated: client_id -> bool + (** subcribe a client to a set of tutor removing previous subcriptions *) + method subscribe: client_id -> tutor_id list -> unit + method getUrl: client_id -> string + method getSubscription: client_id -> tutor_id list + + method dump: string + method purge: unit + end + +class tutors: + object + method register: tutor_id -> string -> hint_type -> string -> unit + method unregister: tutor_id -> unit + method isAuthenticated: tutor_id -> bool + method exists: tutor_id -> bool + method getTutor: tutor_id -> string * hint_type * string + method getUrl: tutor_id -> string + method getHintType: tutor_id -> hint_type + method getDescription: tutor_id -> string + method index: tutor_dsc list + + method dump: string + method purge: unit + end + +class musings: + object + method register: musing_id -> client_id -> tutor_id -> unit + method unregister: musing_id -> unit + method getByMusingId: musing_id -> client_id * tutor_id + method getByClientId: client_id -> musing_id list + method getByTutorId: tutor_id -> musing_id list + method isActive: musing_id -> bool + + method dump: string + method purge: unit + end + diff --git a/helm/software/components/hbugs/hbugs_client.ml b/helm/software/components/hbugs/hbugs_client.ml new file mode 100644 index 000000000..c7b5fae75 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_client.ml @@ -0,0 +1,526 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_common;; +open Hbugs_types;; +open Printf;; + +exception Invalid_URL of string;; + +let do_nothing _ = ();; + +module SmartHbugs_client_gui = + struct + class ['a] oneColumnCList gtree_view ~column_type ~column_title + = + let obj = + ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in + let columns = new GTree.column_list in + let col = columns#add column_type in + let vcol = GTree.view_column ~title:column_title () + ~renderer:(GTree.cell_renderer_text[], ["text",col]) in + let store = GTree.list_store columns in + object(self) + inherit GTree.view obj + method clear = store#clear + method append (v : 'a) = + let row = store#append () in + store#set ~row ~column:col v; + method column = col + initializer + self#set_model (Some (store :> GTree.model)) ; + ignore (self#append_column vcol) + end + + class ['a,'b] twoColumnsCList gtree_view ~column1_type ~column2_type + ~column1_title ~column2_title + = + let obj = + ((Gobject.unsafe_cast gtree_view#as_widget) : Gtk.tree_view Gtk.obj) in + let columns = new GTree.column_list in + let col1 = columns#add column1_type in + let vcol1 = GTree.view_column ~title:column1_title () + ~renderer:(GTree.cell_renderer_text[], ["text",col1]) in + let col2 = columns#add column2_type in + let vcol2 = GTree.view_column ~title:column2_title () + ~renderer:(GTree.cell_renderer_text[], ["text",col2]) in + let store = GTree.list_store columns in + object(self) + inherit GTree.view obj + method clear = store#clear + method append (v1 : 'a) (v2 : 'b) = + let row = store#append () in + store#set ~row ~column:col1 v1; + store#set ~row ~column:col2 v2 + method column1 = col1 + method column2 = col2 + initializer + self#set_model (Some (store :> GTree.model)) ; + ignore (self#append_column vcol1) ; + ignore (self#append_column vcol2) ; + end + + class subscribeWindow () = + object(self) + inherit Hbugs_client_gui.subscribeWindow () + val mutable tutorsSmartCList = None + method tutorsSmartCList = + match tutorsSmartCList with + None -> assert false + | Some w -> w + initializer + tutorsSmartCList <- + Some + (new twoColumnsCList self#tutorsCList + ~column1_type:Gobject.Data.string ~column2_type:Gobject.Data.string + ~column1_title:"Id" ~column2_title:"Description") + end + + class hbugsMainWindow () = + object(self) + inherit Hbugs_client_gui.hbugsMainWindow () + val mutable subscriptionSmartCList = None + val mutable hintsSmartCList = None + method subscriptionSmartCList = + match subscriptionSmartCList with + None -> assert false + | Some w -> w + method hintsSmartCList = + match hintsSmartCList with + None -> assert false + | Some w -> w + initializer + subscriptionSmartCList <- + Some + (new oneColumnCList self#subscriptionCList + ~column_type:Gobject.Data.string ~column_title:"Description") + initializer + hintsSmartCList <- + Some + (new oneColumnCList self#hintsCList + ~column_type:Gobject.Data.string ~column_title:"Description") + end + + end +;; + +class hbugsClient + ?(use_hint_callback: hint -> unit = do_nothing) + ?(describe_hint_callback: hint -> unit = do_nothing) + ?(destroy_callback: unit -> unit = do_nothing) + () + = + + let http_url_RE = Pcre.regexp "^(http://)?(.*):(\\d+)" in + let port_of_http_url url = + try + let subs = Pcre.extract ~rex:http_url_RE url in + int_of_string subs.(3) + with e -> raise (Invalid_URL url) + in + + object (self) + + val mainWindow = new SmartHbugs_client_gui.hbugsMainWindow () + val subscribeWindow = new SmartHbugs_client_gui.subscribeWindow () + val messageDialog = new Hbugs_client_gui.messageDialog () + val myOwnId = Hbugs_id_generator.new_client_id () + val mutable use_hint_callback = use_hint_callback + val mutable myOwnUrl = "localhost:49082" + val mutable brokerUrl = "localhost:49081" + val mutable brokerId: broker_id option = None + (* all available tutors, saved last time a List_tutors message was sent to + broker *) + val mutable availableTutors: tutor_dsc list = [] + val mutable statusContext = None + val mutable subscribeWindowStatusContext = None + val mutable debug = false (* enable/disable debugging buttons *) + val mutable hints = [] (* actually available hints *) + + initializer + self#initGui; + self#startLocalHttpDaemon (); + self#testLocalHttpDaemon (); + self#testBroker (); + self#registerToBroker (); + self#reconfigDebuggingButtons + + method show = mainWindow#hbugsMainWindow#show + method hide = mainWindow#hbugsMainWindow#misc#hide + + method setUseHintCallback callback = + use_hint_callback <- callback + + method private debugButtons = + List.map + (fun (b: GButton.button) -> new GObj.misc_ops b#as_widget) + [ mainWindow#startLocalHttpDaemonButton; + mainWindow#testLocalHttpDaemonButton; mainWindow#testBrokerButton ] + + method private initGui = + + (* GUI: main window *) + + (* ignore delete events so that hbugs window is closable only using + menu; on destroy (e.g. while quitting gTopLevel) self#quit is invoked + *) + + ignore (mainWindow#hbugsMainWindow#event#connect#delete (fun _ -> true)); + ignore (mainWindow#hbugsMainWindow#event#connect#destroy + (fun _ -> self#quit (); false)); + + (* GUI main window's menu *) + mainWindow#toggleDebuggingMenuItem#set_active debug; + ignore (mainWindow#toggleDebuggingMenuItem#connect#toggled + self#toggleDebug); + + (* GUI: local HTTP daemon settings *) + ignore (mainWindow#clientUrlEntry#connect#changed + (fun _ -> myOwnUrl <- mainWindow#clientUrlEntry#text)); + mainWindow#clientUrlEntry#set_text myOwnUrl; + ignore (mainWindow#startLocalHttpDaemonButton#connect#clicked + self#startLocalHttpDaemon); + ignore (mainWindow#testLocalHttpDaemonButton#connect#clicked + self#testLocalHttpDaemon); + + (* GUI: broker choice *) + ignore (mainWindow#brokerUrlEntry#connect#changed + (fun _ -> brokerUrl <- mainWindow#brokerUrlEntry#text)); + mainWindow#brokerUrlEntry#set_text brokerUrl; + ignore (mainWindow#testBrokerButton#connect#clicked self#testBroker); + mainWindow#clientIdLabel#set_text myOwnId; + + (* GUI: client registration *) + ignore (mainWindow#registerClientButton#connect#clicked + self#registerToBroker); + + (* GUI: subscriptions *) + ignore (mainWindow#showSubscriptionWindowButton#connect#clicked + (fun () -> + self#listTutors (); + subscribeWindow#subscribeWindow#show ())); + + let get_selected_row_index () = + match mainWindow#hintsCList#selection#get_selected_rows with + [path] -> + (match GTree.Path.get_indices path with + [|n|] -> n + | _ -> assert false) + | _ -> assert false + in + (* GUI: hints list *) + ignore ( + let event_ops = new GObj.event_ops mainWindow#hintsCList#as_widget in + event_ops#connect#button_press + (fun event -> + if GdkEvent.get_type event = `TWO_BUTTON_PRESS then + use_hint_callback (self#hint (get_selected_row_index ())) ; + false)); + + ignore (mainWindow#hintsCList#selection#connect#changed + (fun () -> + describe_hint_callback (self#hint (get_selected_row_index ())))) ; + + (* GUI: main status bar *) + let ctxt = mainWindow#mainWindowStatusBar#new_context "0" in + statusContext <- Some ctxt; + ignore (ctxt#push "Ready"); + + (* GUI: subscription window *) + subscribeWindow#tutorsCList#selection#set_mode `MULTIPLE; + ignore (subscribeWindow#subscribeWindow#event#connect#delete + (fun _ -> subscribeWindow#subscribeWindow#misc#hide (); true)); + ignore (subscribeWindow#listTutorsButton#connect#clicked self#listTutors); + ignore (subscribeWindow#subscribeButton#connect#clicked + self#subscribeSelected); + ignore (subscribeWindow#subscribeAllButton#connect#clicked + self#subscribeAll); + (subscribeWindow#tutorsCList#get_column 0)#set_visible false; + let ctxt = subscribeWindow#subscribeWindowStatusBar#new_context "0" in + subscribeWindowStatusContext <- Some ctxt; + ignore (ctxt#push "Ready"); + + (* GUI: message dialog *) + ignore (messageDialog#messageDialog#event#connect#delete + (fun _ -> messageDialog#messageDialog#misc#hide (); true)); + ignore (messageDialog#okDialogButton#connect#clicked + (fun _ -> messageDialog#messageDialog#misc#hide ())) + + (* accessory methods *) + + (** pop up a (modal) dialog window showing msg to the user *) + method private showDialog msg = + messageDialog#dialogLabel#set_text msg; + messageDialog#messageDialog#show () + (** use showDialog to display an hbugs message to the user *) + method private showMsgInDialog msg = + self#showDialog (Hbugs_messages.string_of_msg msg) + + (** create a new thread which sends msg to broker, wait for an answer and + invoke callback passing response message as argument *) + method private sendReq ?(wait = false) ~msg callback = + let thread () = + try + callback (Hbugs_messages.submit_req ~url:(brokerUrl ^ "/act") msg) + with + | (Hbugs_messages.Parse_error (subj, reason)) as e -> + self#showDialog + (sprintf +"Parse_error, unable to fullfill request. Details follow. +Request: %s +Error: %s" + (Hbugs_messages.string_of_msg msg) (Printexc.to_string e)); + | (Unix.Unix_error _) as e -> + self#showDialog + (sprintf +"Can't connect to HBugs Broker +Url: %s +Error: %s" + brokerUrl (Printexc.to_string e)) + | e -> + self#showDialog + (sprintf "hbugsClient#sendReq: Uncaught exception: %s" + (Printexc.to_string e)) + in + let th = Thread.create thread () in + if wait then + Thread.join th + else () + + (** check if a broker is authenticated using its broker_id + [ Background: during client registration, client save broker_id of its + broker, further messages from broker are accepted only if they carry the + same broker id ] *) + method private isAuthenticated id = + match brokerId with + | None -> false + | Some broker_id -> (id = broker_id) + + (* actions *) + + method private startLocalHttpDaemon = + (* flatten an hint tree to an hint list *) + let rec flatten_hint = function + | Hints hints -> List.concat (List.map flatten_hint hints) + | hint -> [hint] + in + fun () -> + let callback req outchan = + try + (match Hbugs_messages.msg_of_string req#body with + | Help -> + Hbugs_messages.respond_msg + (Usage "Local Http Daemon up and running!") outchan + | Hint (broker_id, hint) -> + if self#isAuthenticated broker_id then begin + let received_hints = flatten_hint hint in + List.iter + (fun h -> + (match h with Hints _ -> assert false | _ -> ()); + ignore(mainWindow#hintsSmartCList#append(string_of_hint h))) + received_hints; + hints <- hints @ received_hints; + Hbugs_messages.respond_msg (Wow myOwnId) outchan + end else (* msg from unauthorized broker *) + Hbugs_messages.respond_exc "forbidden" broker_id outchan + | msg -> + Hbugs_messages.respond_exc + "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan) + with (Hbugs_messages.Parse_error _) as e -> + Hbugs_messages.respond_exc + "parse_error" (Printexc.to_string e) outchan + in + let addr = "0.0.0.0" in (* TODO actually user specified "My URL" is used + only as a value to be sent to broker, local HTTP + daemon will listen on "0.0.0.0", port is parsed + from My URL though *) + let httpDaemonThread () = + try + Http_daemon.start' + ~addr ~port:(port_of_http_url myOwnUrl) ~mode:`Single callback + with + | Invalid_URL url -> self#showDialog (sprintf "Invalid URL: \"%s\"" url) + | e -> + self#showDialog (sprintf "Can't start local HTTP daemon: %s" + (Printexc.to_string e)) + in + ignore (Thread.create httpDaemonThread ()) + + method private testLocalHttpDaemon () = + try + let msg = + Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg Help) + myOwnUrl + in + ignore msg +(* self#showDialog msg *) + with + | Hbugs_misc.Malformed_URL url -> + self#showDialog + (sprintf + "Handshake with local HTTP daemon failed, Invalid URL: \"%s\"" + url) + | Hbugs_misc.Malformed_HTTP_response res -> + self#showDialog + (sprintf + "Handshake with local HTTP daemon failed, can't parse HTTP response: \"%s\"" + res) + | (Unix.Unix_error _) as e -> + self#showDialog + (sprintf + "Handshake with local HTTP daemon failed, can't connect: \"%s\"" + (Printexc.to_string e)) + + method private testBroker () = + self#sendReq ~msg:Help + (function + | Usage _ -> () + | unexpected_msg -> + self#showDialog + (sprintf + "Handshake with HBugs Broker failed, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method registerToBroker () = + (match brokerId with (* undo previous registration, if any *) + | Some id -> self#unregisterFromBroker () + | _ -> ()); + self#sendReq ~msg:(Register_client (myOwnId, myOwnUrl)) + (function + | Client_registered broker_id -> (brokerId <- Some broker_id) + | unexpected_msg -> + self#showDialog + (sprintf "Client NOT registered, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method unregisterFromBroker () = + self#sendReq ~wait:true ~msg:(Unregister_client myOwnId) + (function + | Client_unregistered _ -> (brokerId <- None) + | unexpected_msg -> ()) +(* + self#showDialog + (sprintf "Client NOT unregistered, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) +*) + + method stateChange new_state = + mainWindow#hintsSmartCList#clear (); + hints <- []; + self#sendReq + ~msg:(State_change (myOwnId, new_state)) + (function + | State_accepted _ -> () + | unexpected_msg -> + self#showDialog + (sprintf "State NOT accepted by Hbugs, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method hint = List.nth hints + + method private listTutors () = + (* wait is set to true just to make sure that after invoking listTutors + "availableTutors" is correctly filled *) + self#sendReq ~wait:true ~msg:(List_tutors myOwnId) + (function + | Tutor_list (_, descriptions) -> + availableTutors <- (* sort accordingly to tutor description *) + List.sort (fun (a,b) (c,d) -> compare (b,a) (d,c)) descriptions; + subscribeWindow#tutorsSmartCList#clear (); + List.iter + (fun (id, dsc) -> + ignore (subscribeWindow#tutorsSmartCList#append id dsc)) + availableTutors + | unexpected_msg -> + self#showDialog + (sprintf "Can't list tutors, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + (* low level used by subscribeSelected and subscribeAll *) + method private subscribe' tutors_id = + self#sendReq ~msg:(Subscribe (myOwnId, tutors_id)) + (function + | (Subscribed (_, subscribedTutors)) as msg -> + let sort = List.sort compare in + mainWindow#subscriptionSmartCList#clear (); + List.iter + (fun tutor_id -> + ignore + (mainWindow#subscriptionSmartCList#append + ( try + List.assoc tutor_id availableTutors + with Not_found -> assert false ))) + tutors_id; + subscribeWindow#subscribeWindow#misc#hide (); + if sort subscribedTutors <> sort tutors_id then + self#showDialog + (sprintf "Subscription mismatch\n: %s" + (Hbugs_messages.string_of_msg msg)) + | unexpected_msg -> + mainWindow#subscriptionSmartCList#clear (); + self#showDialog + (sprintf "Subscription FAILED, unexpected message:\n%s" + (Hbugs_messages.string_of_msg unexpected_msg))) + + method private subscribeSelected () = + let tutorsSmartCList = subscribeWindow#tutorsSmartCList in + let selectedTutors = + List.map + (fun p -> + tutorsSmartCList#model#get + ~row:(tutorsSmartCList#model#get_iter p) + ~column:tutorsSmartCList#column1) + tutorsSmartCList#selection#get_selected_rows + in + self#subscribe' selectedTutors + + method subscribeAll () = + self#listTutors (); (* this fills 'availableTutors' field *) + self#subscribe' (List.map fst availableTutors) + + method private quit () = + self#unregisterFromBroker (); + destroy_callback () + + (** enable/disable debugging *) + method private setDebug value = debug <- value + + method private reconfigDebuggingButtons = + List.iter (* debug value changed, reconfigure buttons *) + (fun (b: GObj.misc_ops) -> if debug then b#show () else b#hide ()) + self#debugButtons; + + method private toggleDebug () = + self#setDebug (not debug); + self#reconfigDebuggingButtons + + end +;; + diff --git a/helm/software/components/hbugs/hbugs_client.mli b/helm/software/components/hbugs/hbugs_client.mli new file mode 100644 index 000000000..0c2e93d80 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_client.mli @@ -0,0 +1,33 @@ + +open Hbugs_types + +exception Invalid_URL of string + + (* + @param use_hint_callback is called when the user double click on a hint + (default: do nothing) + @param describe_hint_callback is called when the user click on a hint + (default: do nothing) + *) +class hbugsClient : + ?use_hint_callback: (hint -> unit) -> + ?describe_hint_callback: (hint -> unit) -> + ?destroy_callback: (unit -> unit) -> + unit -> + object + + method show : unit -> unit + method hide : unit -> unit + + method setUseHintCallback : (hint -> unit) -> unit + method registerToBroker : unit -> unit + method unregisterFromBroker : unit -> unit + method subscribeAll : unit -> unit + + method stateChange : state option -> unit + + (** @return an hint by index *) + method hint : int -> hint + + end + diff --git a/helm/software/components/hbugs/hbugs_client_gui.glade b/helm/software/components/hbugs/hbugs_client_gui.glade new file mode 100644 index 000000000..f88a8c388 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_client_gui.glade @@ -0,0 +1,672 @@ + + + + + + + + Hbugs: your personal proof trainer! + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + + + + True + False + 0 + + + + + + + True + Tools + True + + + + True + + + + True + Debugging + True + False + + + + + + + + + 0 + False + False + + + + + + True + False + 2 + + + + True + My URL: + False + False + GTK_JUSTIFY_CENTER + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Local HTTP daemon URL + True + False + True + 0 + + True + * + False + + + 0 + True + True + + + + + + True + Start the local HTTP daemon listening on the specified URL + True + Start! + True + GTK_RELIEF_NORMAL + + + 0 + False + False + + + + + + True + True + Test! + True + GTK_RELIEF_NORMAL + + + 0 + False + False + + + + + 0 + False + False + + + + + + True + False + 0 + + + + True + False + 2 + + + + True + Broker: + False + False + GTK_JUSTIFY_CENTER + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + HBugs broker URL + True + False + True + 0 + + True + * + False + + + 0 + True + True + + + + + + True + True + Test! + True + GTK_RELIEF_NORMAL + + + 0 + False + False + + + + + 0 + False + False + + + + + + True + False + 2 + + + + Client ID: + False + False + GTK_JUSTIFY_CENTER + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + True + True + + + + + + True + True + (Re)Register + True + GTK_RELIEF_NORMAL + + + 0 + False + False + + + + + 0 + False + False + + + + + 0 + False + True + + + + + + True + 0 + + + + 4 + True + 0 + 0.5 + GTK_SHADOW_ETCHED_IN + + + + True + False + 2 + + + + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + False + True + + + + + 0 + True + True + + + + + + True + + + + 0 + 0 + True + True + Subscribe ... + True + GTK_RELIEF_NORMAL + + + 0 + 0 + + + + + 0 + False + False + + + + + + + + True + Subscriptions + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + label_item + + + + + False + False + + + + + + 4 + True + 0 + 0.5 + GTK_SHADOW_ETCHED_IN + + + + True + False + 0 + + + + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + False + True + + + + + 0 + True + True + + + + + + + + True + Hints + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + label_item + + + + + True + True + + + + + 0 + True + True + + + + + + True + + + 0 + False + False + + + + + + + + Hbugs: subscribe ... + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + + + + True + False + 0 + + + + True + True + Refresh + True + GTK_RELIEF_NORMAL + + + 0 + False + False + + + + + + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + False + True + + + + + 0 + True + True + + + + + + True + False + 0 + + + + True + True + Subscribe to Selected + True + GTK_RELIEF_NORMAL + + + 0 + True + True + + + + + + True + True + Subscribe to All + True + GTK_RELIEF_NORMAL + + + 0 + True + True + + + + + 0 + False + False + + + + + + True + True + + + 0 + False + False + + + + + + + + Message + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + True + 220 + 150 + True + False + True + + + + True + False + 0 + + + + True + GTK_BUTTONBOX_END + + + + True + True + OK + True + GTK_RELIEF_NORMAL + 0 + + + + + 0 + False + True + GTK_PACK_END + + + + + + 5 + True + 1 + 1 + False + 0 + 0 + + + + True + + False + False + GTK_JUSTIFY_CENTER + True + False + 0.5 + 0.5 + 0 + 0 + + + 0 + 1 + 0 + 1 + + + + + 0 + True + True + + + + + + + diff --git a/helm/software/components/hbugs/hbugs_common.ml b/helm/software/components/hbugs/hbugs_common.ml new file mode 100644 index 000000000..fe2ecfcae --- /dev/null +++ b/helm/software/components/hbugs/hbugs_common.ml @@ -0,0 +1,48 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_types;; +open Printf;; + +let rec string_of_hint = function + | Use_ring -> "Use Ring, Luke!" + | Use_fourier -> "Use Fourier, Luke!" + | Use_reflexivity -> "Use reflexivity, Luke!" + | Use_symmetry -> "Use symmetry, Luke!" + | Use_assumption -> "Use assumption, Luke!" + | Use_contradiction -> "Use contradiction, Luke!" + | Use_exists -> "Use exists, Luke!" + | Use_split -> "Use split, Luke!" + | Use_left -> "Use left, Luke!" + | Use_right -> "Use right, Luke!" + | Use_apply term -> sprintf "Apply %s, Luke!" term + | Hints hints -> String.concat "; " (List.map string_of_hint hints) +;; + diff --git a/helm/software/components/hbugs/hbugs_common.mli b/helm/software/components/hbugs/hbugs_common.mli new file mode 100644 index 000000000..2d51075f3 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_common.mli @@ -0,0 +1,32 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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;; + +val string_of_hint: hint -> string + diff --git a/helm/software/components/hbugs/hbugs_id_generator.ml b/helm/software/components/hbugs/hbugs_id_generator.ml new file mode 100644 index 000000000..5b1998ac2 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_id_generator.ml @@ -0,0 +1,67 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +let _ = Random.self_init () + +let id_length = 32 +let min_ascii = 33 +let max_ascii = 126 + (* characters forbidden inside an XML attribute value. Well, '>' and ''' + aren't really forbidden, but are listed here ... just to be sure *) +let forbidden_chars = (* i.e. [ '"'; '&'; '\''; '<'; '>' ] *) + [ 34; 38; 39; 60; 62 ] (* assumption: is sorted! *) +let chars_range = max_ascii - min_ascii + 1 - (List.length forbidden_chars) + + (* return a random id char c such that + (min_ascii <= Char.code c) && + (Char.code c <= max_ascii) && + (not (List.mem (Char.code c) forbidden_chars)) + *) +let random_id_char () = + let rec nth_char ascii shifts = function + | [] -> Char.chr (ascii + shifts) + | hd::tl when ascii + shifts < hd -> Char.chr (ascii + shifts) + | hd::tl (* when ascii + shifts >= hd *) -> nth_char ascii (shifts + 1) tl + in + nth_char (Random.int chars_range + min_ascii) 0 forbidden_chars + + (* return a random id string which have length id_length *) +let new_id () = + let str = String.create id_length in + for i = 0 to id_length - 1 do + String.set str i (random_id_char ()) + done; + str + +let new_broker_id = new_id +let new_client_id = new_id +let new_musing_id = new_id +let new_tutor_id = new_id + diff --git a/helm/software/components/hbugs/hbugs_id_generator.mli b/helm/software/components/hbugs/hbugs_id_generator.mli new file mode 100644 index 000000000..dad0c9391 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_id_generator.mli @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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;; + +val new_broker_id: unit -> broker_id +val new_client_id: unit -> client_id +val new_musing_id: unit -> musing_id +val new_tutor_id: unit -> tutor_id + diff --git a/helm/software/components/hbugs/hbugs_messages.ml b/helm/software/components/hbugs/hbugs_messages.ml new file mode 100644 index 000000000..4767b2aee --- /dev/null +++ b/helm/software/components/hbugs/hbugs_messages.ml @@ -0,0 +1,368 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_types;; +open Printf;; +open Pxp_document;; +open Pxp_dtd;; +open Pxp_types;; +open Pxp_yacc;; + +let debug = 2;; (* 0 -> no debug + 1 -> waiting for an answer / answer received + 2 -> XML messages dumping + *) + +exception Attribute_not_found of string;; +exception Empty_node;; (** found a node with no _element_ children *) +exception No_element_found of string;; +exception Parse_error of string * string;; (* parsing subject, reason *) +exception Unexpected_message of message;; + +let is_xml_element n = match n#node_type with T_element _ -> true | _ -> false +let get_attr node name = + try + (match node#attribute name with + | Value s -> s + | _ -> raise Not_found) + with Not_found -> raise (Attribute_not_found name) +let assert_element n name = + match n#node_type with + | T_element n when n = name -> + () + | _ -> raise (Parse_error ("", "Expected node: " ^ name)) + + (** given a string representation of a proof asistant state (e.g. the first + child of the XML root of a State_change or Start_musing message), build from + it an HBugs view of a proof assistant state *) +let parse_state (root: ('a node extension as 'a) node) = + if (List.filter is_xml_element root#sub_nodes) = [] then + raise Empty_node; + let buf = Buffer.create 10240 in + let node_to_string (node: ('a node extension as 'a) node) = + Buffer.clear buf; + node#write (`Out_buffer buf) `Enc_utf8; + let res = Buffer.contents buf in + Buffer.clear buf; + res + in + let (goal_node, type_node, body_node) = + try + (find_element "CurrentGoal" root, + find_element "ConstantType" root, + find_element "CurrentProof" root) + with Not_found -> + raise (Parse_error ("", "Malformed HBugs status XML document")) + in + assert_element root "gTopLevelStatus"; + assert_element goal_node "CurrentGoal"; + assert_element type_node "ConstantType"; + assert_element body_node "CurrentProof"; + goal_node#write (`Out_buffer buf) `Enc_utf8; + let (type_string, body_string) = + (node_to_string type_node, node_to_string body_node) + in + let goal = + try + int_of_string (goal_node#data) + with Failure "int_of_string" -> + raise (Parse_error (goal_node#data, "can't parse goal")) + in + (type_string, body_string, goal) + + (** parse an hint from an XML node, XML node should have type 'T_element _' + (the name is ignored), attributes on it are ignored *) +let parse_hint node = + let rec parse_hint_node node = + match node#node_type with + | T_element "ring" -> Use_ring + | T_element "fourier" -> Use_fourier + | T_element "reflexivity" -> Use_reflexivity + | T_element "symmetry" -> Use_symmetry + | T_element "assumption" -> Use_assumption + | T_element "contradiction" -> Use_contradiction + | T_element "exists" -> Use_exists + | T_element "split" -> Use_split + | T_element "left" -> Use_left + | T_element "right" -> Use_right + | T_element "apply" -> Use_apply node#data + | T_element "hints" -> + Hints + (List.map parse_hint_node (List.filter is_xml_element node#sub_nodes)) + | _ -> assert false (* CSC: should this assert false be a raise something? *) + in + match List.filter is_xml_element node#sub_nodes with + [node] -> parse_hint_node node + | _ -> assert false (* CSC: should this assert false be a raise something? *) + +let parse_hint_type n = n#data (* TODO parsare il possibile tipo di suggerimento *) +let parse_tutor_dscs n = + List.map + (fun n -> (get_attr n "id", n#data)) + (List.filter is_xml_element n#sub_nodes) +let parse_tutor_ids node = + List.map + (fun n -> get_attr n "id") (List.filter is_xml_element node#sub_nodes) + +let tutors_sep = Pcre.regexp ",\\s*" + +let pxp_config = PxpHelmConf.pxp_config +let msg_of_string' s = + let root = (* xml tree's root *) + parse_wfcontent_entity pxp_config (from_string s) PxpHelmConf.pxp_spec + in + match root#node_type with + + (* general purpose *) + | T_element "help" -> Help + | T_element "usage" -> Usage root#data + | T_element "exception" -> Exception (get_attr root "name", root#data) + + (* client -> broker *) + | T_element "register_client" -> + Register_client (get_attr root "id", get_attr root "url") + | T_element "unregister_client" -> Unregister_client (get_attr root "id") + | T_element "list_tutors" -> List_tutors (get_attr root "id") + | T_element "subscribe" -> + Subscribe (get_attr root "id", parse_tutor_ids root) + | T_element "state_change" -> + let state_node = + try + Some (find_element ~deeply:false "gTopLevelStatus" root) + with Not_found -> None + in + State_change + (get_attr root "id", + match state_node with + | Some n -> (try Some (parse_state n) with Empty_node -> None) + | None -> None) + | T_element "wow" -> Wow (get_attr root "id") + + (* tutor -> broker *) + | T_element "register_tutor" -> + let hint_node = find_element "hint_type" root in + let dsc_node = find_element "description" root in + Register_tutor + (get_attr root "id", get_attr root "url", + parse_hint_type hint_node, dsc_node#data) + | T_element "unregister_tutor" -> Unregister_tutor (get_attr root "id") + | T_element "musing_started" -> + Musing_started (get_attr root "id", get_attr root "musing_id") + | T_element "musing_aborted" -> + Musing_started (get_attr root "id", get_attr root "musing_id") + | T_element "musing_completed" -> + let main_node = + try + find_element "eureka" root + with Not_found -> find_element "sorry" root + in + Musing_completed + (get_attr root "id", get_attr root "musing_id", + (match main_node#node_type with + | T_element "eureka" -> + Eureka (parse_hint main_node) + | T_element "sorry" -> Sorry + | _ -> assert false)) (* can't be there, see 'find_element' above *) + + (* broker -> client *) + | T_element "client_registered" -> Client_registered (get_attr root "id") + | T_element "client_unregistered" -> Client_unregistered (get_attr root "id") + | T_element "tutor_list" -> + Tutor_list (get_attr root "id", parse_tutor_dscs root) + | T_element "subscribed" -> + Subscribed (get_attr root "id", parse_tutor_ids root) + | T_element "state_accepted" -> + State_accepted + (get_attr root "id", + List.map + (fun n -> get_attr n "id") + (List.filter is_xml_element (find_element "stopped" root)#sub_nodes), + List.map + (fun n -> get_attr n "id") + (List.filter is_xml_element (find_element "started" root)#sub_nodes)) + | T_element "hint" -> Hint (get_attr root "id", parse_hint root) + + (* broker -> tutor *) + | T_element "tutor_registered" -> Tutor_registered (get_attr root "id") + | T_element "tutor_unregistered" -> Tutor_unregistered (get_attr root "id") + | T_element "start_musing" -> + let state_node = + try + find_element ~deeply:false "gTopLevelStatus" root + with Not_found -> raise (No_element_found "gTopLevelStatus") + in + Start_musing (get_attr root "id", parse_state state_node) + | T_element "abort_musing" -> + Abort_musing (get_attr root "id", get_attr root "musing_id") + | T_element "thanks" -> Thanks (get_attr root "id", get_attr root "musing_id") + | T_element "too_late" -> + Too_late (get_attr root "id", get_attr root "musing_id") + + | _ -> raise (No_element_found s) + +let msg_of_string s = + try + msg_of_string' s + with e -> raise (Parse_error (s, Printexc.to_string e)) + +let pp_state = function + | Some (type_string, body_string, goal) -> + (* ASSUMPTION: type_string and body_string are well formed XML document + contents (i.e. they don't contain heading declaration nor + DOCTYPE one *) + "\n" ^ + (sprintf "%d\n" goal) ^ + type_string ^ "\n" ^ + body_string ^ "\n" ^ + "\n" + | None -> "\n" + +let rec pp_hint = function + | Use_ring -> sprintf "" + | Use_fourier -> sprintf "" + | Use_reflexivity -> sprintf "" + | Use_symmetry -> sprintf "" + | Use_assumption -> sprintf "" + | Use_contradiction -> sprintf "" + | Use_exists -> sprintf "" + | Use_split -> sprintf "" + | Use_left -> sprintf "" + | Use_right -> sprintf "" + | Use_apply term -> sprintf "%s" term + | Hints hints -> + sprintf "\n%s\n" + (String.concat "\n" (List.map pp_hint hints)) + +let pp_hint_type s = s (* TODO pretty print hint_type *) +let pp_tutor_dscs = + List.fold_left + (fun s (id, dsc) -> + sprintf "%s%s" s id dsc) + "" +let pp_tutor_ids = + List.fold_left (fun s id -> sprintf "%s" s id) "" + +let string_of_msg = function + | Help -> "" + | Usage usage_string -> sprintf "%s" usage_string + | Exception (name, value) -> + sprintf "%s" name value + | Register_client (id, url) -> + sprintf "" id url + | Unregister_client id -> sprintf "" id + | List_tutors id -> sprintf "" id + | Subscribe (id, tutor_ids) -> + sprintf "%s" + id (pp_tutor_ids tutor_ids) + | State_change (id, state) -> + sprintf "%s" + id (pp_state state) + | Wow id -> sprintf "" id + | Register_tutor (id, url, hint_type, dsc) -> + sprintf +" +%s +%s +" + id url (pp_hint_type hint_type) dsc + | Unregister_tutor id -> sprintf "" id + | Musing_started (id, musing_id) -> + sprintf "" id musing_id + | Musing_aborted (id, musing_id) -> + sprintf "" id musing_id + | Musing_completed (id, musing_id, result) -> + sprintf + "%s" + id musing_id + (match result with + | Sorry -> "" + | Eureka hint -> sprintf "%s" (pp_hint hint)) + | Client_registered id -> sprintf "" id + | Client_unregistered id -> sprintf "" id + | Tutor_list (id, tutor_dscs) -> + sprintf "%s" + id (pp_tutor_dscs tutor_dscs) + | Subscribed (id, tutor_ids) -> + sprintf "%s" + id (pp_tutor_ids tutor_ids) + | State_accepted (id, stop_ids, start_ids) -> + sprintf +" +%s +%s +" + id + (String.concat "" + (List.map (fun id -> sprintf "" id) stop_ids)) + (String.concat "" + (List.map (fun id -> sprintf "" id) start_ids)) + | Hint (id, hint) -> sprintf "%s" id (pp_hint hint) + | Tutor_registered id -> sprintf "" id + | Tutor_unregistered id -> sprintf "" id + | Start_musing (id, state) -> + sprintf "%s" + id (pp_state (Some state)) + | Abort_musing (id, musing_id) -> + sprintf "" id musing_id + | Thanks (id, musing_id) -> + sprintf "" id musing_id + | Too_late (id, musing_id) -> + sprintf "" id musing_id +;; + + (* debugging function that dump on stderr the sent messages *) +let dump_msg msg = + if debug >= 2 then + prerr_endline + (sprintf "\n%s\n" + (match msg with + | State_change _ -> "omissis ..." + | msg -> string_of_msg msg)) +;; + +let submit_req ~url msg = + dump_msg msg; + if debug >= 1 then (prerr_string "Waiting for an answer ... "; flush stderr); + let res = + msg_of_string (Hbugs_misc.http_post ~body:(string_of_msg msg) url) + in + if debug >= 1 then (prerr_string "answer received!\n"; flush stderr); + res +;; +let return_xml_msg body outchan = + Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan +;; +let respond_msg msg outchan = + dump_msg msg; + return_xml_msg (string_of_msg msg) outchan +(* close_out outchan *) +;; +let respond_exc name value = respond_msg (Exception (name, value));; + diff --git a/helm/software/components/hbugs/hbugs_messages.mli b/helm/software/components/hbugs/hbugs_messages.mli new file mode 100644 index 000000000..642c0b0e2 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_messages.mli @@ -0,0 +1,49 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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;; + +exception Parse_error of string * string (* parsing subject, reason *) +exception Unexpected_message of message;; + +val msg_of_string: string -> message +val string_of_msg: message -> string + +val submit_req: url:string -> message -> message + (** close outchan afterwards *) +val respond_msg: message -> out_channel -> unit + (** close outchan afterwards *) + (* exception_name, exception_value, output_channel *) +val respond_exc: string -> string -> out_channel -> unit + +(* TODO the below functions are for debugging only and shouldn't be exposed *) +val parse_state: + ('a Pxp_document.node Pxp_document.extension as 'a) Pxp_document.node -> + (string * string * int) +val pp_state: (string * string * int) option -> string + diff --git a/helm/software/components/hbugs/hbugs_misc.ml b/helm/software/components/hbugs/hbugs_misc.ml new file mode 100644 index 000000000..32b8e8b46 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_misc.ml @@ -0,0 +1,122 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Printf;; + +let rec hashtbl_remove_all tbl key = + if Hashtbl.mem tbl key then begin + Hashtbl.remove tbl key; + hashtbl_remove_all tbl key + end else + () + + (** follows cut and paste from zack's Http_client_smart module *) + +exception Malformed_URL of string;; +exception Malformed_HTTP_response of string;; + +let bufsiz = 16384;; +let tcp_bufsiz = 4096;; + +let body_sep_RE = Pcre.regexp "\r\n\r\n";; +let http_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "^http://";; +let url_RE = Pcre.regexp "^([\\w.]+)(:(\\d+))?(/.*)?$";; +let parse_url url = + try + let subs = + Pcre.extract ~rex:url_RE (Pcre.replace ~rex:http_scheme_RE url) + in + (subs.(1), + (if subs.(2) = "" then 80 else int_of_string subs.(3)), + (if subs.(4) = "" then "/" else subs.(4))) + with exc -> raise (Malformed_URL url) +;; +let get_body answer = + match Pcre.split ~rex:body_sep_RE answer with + | [_; body] -> body + | _ -> raise (Malformed_HTTP_response answer) +;; + +let init_socket addr port = + let inet_addr = (Unix.gethostbyname addr).Unix.h_addr_list.(0) in + let sockaddr = Unix.ADDR_INET (inet_addr, port) in + let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.connect suck sockaddr; + let outchan = Unix.out_channel_of_descr suck in + let inchan = Unix.in_channel_of_descr suck in + (inchan, outchan) +;; +let rec retrieve inchan buf = + Buffer.add_string buf (input_line inchan ^ "\n"); + retrieve inchan buf +;; + +let http_get_iter_buf ~callback url = + let (address, port, path) = parse_url url in + let buf = String.create tcp_bufsiz in + let (inchan, outchan) = init_socket address port in + output_string outchan (sprintf "GET %s\r\n" path); + flush outchan; + (try + while true do + match input inchan buf 0 tcp_bufsiz with + | 0 -> raise End_of_file + | bytes when bytes = tcp_bufsiz -> (* buffer full, no need to slice it *) + callback buf + | bytes when bytes < tcp_bufsiz -> (* buffer not full, slice it *) + callback (String.sub buf 0 bytes) + | _ -> (* ( bytes < 0 ) || ( bytes > tcp_bufsiz ) *) + assert false + done + with End_of_file -> ()); + close_in inchan (* close also outchan, same fd *) +;; + +let http_get url = + let buf = Buffer.create (tcp_bufsiz * 10) in + http_get_iter_buf (fun data -> Buffer.add_string buf data) url; + get_body (Buffer.contents buf) +;; + +let http_post ?(body = "") url = + let (address, port, path) = parse_url url in + let (inchan, outchan) = init_socket address port in + output_string outchan (sprintf "POST %s HTTP/1.0\r\n" path); + output_string outchan (sprintf "Content-Length: %d\r\n" (String.length body)); + output_string outchan "\r\n"; + output_string outchan body; + flush outchan; + let buf = Buffer.create bufsiz in + (try + retrieve inchan buf + with End_of_file -> close_in inchan); (* close also outchan, same fd *) + get_body (Buffer.contents buf) +;; + diff --git a/helm/software/components/hbugs/hbugs_misc.mli b/helm/software/components/hbugs/hbugs_misc.mli new file mode 100644 index 000000000..b0ef59719 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_misc.mli @@ -0,0 +1,50 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + + (** helpers *) + + (** remove all bindings of a given key from an hash table *) +val hashtbl_remove_all: ('a, 'b) Hashtbl.t -> 'a -> unit + + (** follows cut and paste from zack's Http_client_smart module *) + + (** can't parse an HTTP url *) +exception Malformed_URL of string + (** can't parse an HTTP response *) +exception Malformed_HTTP_response of string + + (** HTTP GET request for a given url, return http response's body *) +val http_get: string -> string + (** HTTP POST request for a given url, return http response's body, + body argument, if specified, is sent as body along with request *) +val http_post: ?body:string -> string -> string + + (** perform an HTTP GET request and apply a given function on each + 'slice' of HTTP response read from server *) +val http_get_iter_buf: callback:(string -> unit) -> string -> unit + diff --git a/helm/software/components/hbugs/hbugs_tutors.ml b/helm/software/components/hbugs/hbugs_tutors.ml new file mode 100644 index 000000000..6a73e2cc2 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_tutors.ml @@ -0,0 +1,266 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +open Hbugs_types;; +open Printf;; + +let broker_url = "localhost:49081/act";; +let dump_environment_on_exit = false;; + +let init_tutor = Hbugs_id_generator.new_tutor_id;; + + (** register a tutor to broker *) +let register_to_broker id url hint_type dsc = + try + let res = + Hbugs_messages.submit_req + ~url:broker_url (Register_tutor (id, url, hint_type, dsc)) + in + (match res with + | Tutor_registered id -> + prerr_endline (sprintf "Tutor registered, broker id: %s" id); + id + | unexpected_msg -> + raise (Hbugs_messages.Unexpected_message unexpected_msg)) + with e -> + failwith (sprintf "Can't register tutor to broker: uncaught exception: %s" + (Printexc.to_string e)) +;; + (** unregister a tutor from the broker *) +let unregister_from_broker id = + let res = Hbugs_messages.submit_req ~url:broker_url (Unregister_tutor id) in + match res with + | Tutor_unregistered _ -> prerr_endline "Tutor unregistered!" + | unexpected_msg -> + failwith + (sprintf "Can't unregister from broker, received unexpected msg: %s" + (Hbugs_messages.string_of_msg unexpected_msg)) +;; + + (* typecheck a loaded proof *) + (* TODO this is a cut and paste from gTopLevel.ml *) +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) +;; + +type xml_kind = Body | Type;; +let mk_dtdname ~ask_dtd_to_the_getter dtd = + if ask_dtd_to_the_getter then + Helm_registry.get "getter.url" ^ "getdtd?uri=" ^ dtd + else + "http://mowgli.cs.unibo.it/dtd/" ^ dtd +;; + (** this function must be the inverse function of GTopLevel.strip_xml_headings + *) +let add_xml_headings ~kind s = + let dtdname = mk_dtdname ~ask_dtd_to_the_getter:true "cic.dtd" in + let root = + match kind with + | Body -> "CurrentProof" + | Type -> "ConstantType" + in + "\n\n" ^ + "\n\n" ^ + s +;; + +let load_state (type_string, body_string, goal) = + prerr_endline "a0"; + let ((tmp1, oc1), (tmp2, oc2)) = + (Filename.open_temp_file "" "", Filename.open_temp_file "" "") + in + prerr_endline "a1"; + output_string oc1 (add_xml_headings ~kind:Type type_string); + output_string oc2 (add_xml_headings ~kind:Body body_string); + close_out oc1; close_out oc2; + prerr_endline (sprintf "Proof Type available in %s" tmp1); + prerr_endline (sprintf "Proof Body available in %s" tmp2); + let (proof, goal) = + prerr_endline "a2"; + (match CicParser.obj_of_xml tmp1 (Some tmp2) with + | Cic.CurrentProof (_,metasenv,bo,ty,_) -> (* TODO il primo argomento e' una URI valida o e' casuale? *) + prerr_endline "a3"; + let uri = UriManager.uri_of_string "cic:/foo.con" in + prerr_endline "a4"; + typecheck_loaded_proof metasenv bo ty; + prerr_endline "a5"; + ((uri, metasenv, bo, ty), goal) + | _ -> assert false) + in + prerr_endline "a6"; + Sys.remove tmp1; Sys.remove tmp2; + (proof, goal) + +(* tutors creation stuff from now on *) + +module type HbugsTutor = + sig + val start: unit -> unit + end + +module type HbugsTutorDescription = + sig + val addr: string + val port: int + val tactic: ProofEngineTypes.tactic + val hint: hint + val hint_type: hint_type + val description: string + val environment_file: string + end + +module BuildTutor (Dsc: HbugsTutorDescription) : HbugsTutor = + struct + let broker_id = ref None + let my_own_id = init_tutor () + let my_own_addr, my_own_port = Dsc.addr, Dsc.port + let my_own_url = sprintf "%s:%d" my_own_addr my_own_port + + let is_authenticated id = + match !broker_id with + | None -> false + | Some broker_id -> id = broker_id + + (* thread who do the dirty work *) + let slave (state, musing_id) = + prerr_endline (sprintf "Hi, I'm the slave for musing %s" musing_id); + let (proof, goal) = load_state state in + let success = + try + ignore (Dsc.tactic (proof, goal)); + true + with e -> false + in + let answer = + Musing_completed + (my_own_id, musing_id, (if success then Eureka Dsc.hint else Sorry)) + in + ignore (Hbugs_messages.submit_req ~url:broker_url answer); + prerr_endline + (sprintf "Bye, I've completed my duties (success = %b)" success) + + let hbugs_callback = + (* hashtbl mapping musings ids to PID of threads doing the related (dirty) + work *) + let slaves = Hashtbl.create 17 in + let forbidden () = + prerr_endline "ignoring request from unauthorized broker"; + Exception ("forbidden", "") + in + function (* _the_ callback *) + | Start_musing (broker_id, state) -> + if is_authenticated broker_id then begin + prerr_endline "received Start_musing"; + let new_musing_id = Hbugs_id_generator.new_musing_id () in + prerr_endline + (sprintf "starting a new musing (id = %s)" new_musing_id); +(* let slave_thread = Thread.create slave (state, new_musing_id) in *) + let slave_thread = + ExtThread.create slave (state, new_musing_id) + in + Hashtbl.add slaves new_musing_id slave_thread; + Musing_started (my_own_id, new_musing_id) + end else (* broker unauthorized *) + forbidden (); + | Abort_musing (broker_id, musing_id) -> + if is_authenticated broker_id then begin + (try (* kill thread responsible for "musing_id" *) + let slave_thread = Hashtbl.find slaves musing_id in + ExtThread.kill slave_thread; + Hashtbl.remove slaves musing_id + with + | ExtThread.Can_t_kill (_, reason) -> + prerr_endline (sprintf "Unable to kill slave: %s" reason) + | Not_found -> + prerr_endline (sprintf + "Can't find slave corresponding to musing %s, can't kill it" + musing_id)); + Musing_aborted (my_own_id, musing_id) + end else (* broker unauthorized *) + forbidden (); + | unexpected_msg -> + Exception ("unexpected_msg", + Hbugs_messages.string_of_msg unexpected_msg) + + let callback (req: Http_types.request) outchan = + try + let req_msg = Hbugs_messages.msg_of_string req#body in + let answer = hbugs_callback req_msg in + Http_daemon.respond ~body:(Hbugs_messages.string_of_msg answer) outchan + with Hbugs_messages.Parse_error (subj, reason) -> + Http_daemon.respond + ~body:(Hbugs_messages.string_of_msg + (Exception ("parse_error", reason))) + outchan + + let restore_environment () = + let ic = open_in Dsc.environment_file in + prerr_endline "Restoring environment ..."; + CicEnvironment.restore_from_channel + ~callback:(fun uri -> prerr_endline uri) ic; + prerr_endline "... done!"; + close_in ic + + let dump_environment () = + let oc = open_out Dsc.environment_file in + prerr_endline "Dumping environment ..."; + CicEnvironment.dump_to_channel + ~callback:(fun uri -> prerr_endline uri) oc; + prerr_endline "... done!"; + close_out oc + + let main () = + try + Sys.catch_break true; + at_exit (fun () -> + if dump_environment_on_exit then + dump_environment (); + unregister_from_broker my_own_id); + broker_id := + Some (register_to_broker + my_own_id my_own_url Dsc.hint_type Dsc.description); + if Sys.file_exists Dsc.environment_file then + restore_environment (); + Http_daemon.start' + ~addr:my_own_addr ~port:my_own_port ~mode:`Thread callback + with Sys.Break -> () (* exit nicely, invoking at_exit functions *) + + let start = main + + end + diff --git a/helm/software/components/hbugs/hbugs_tutors.mli b/helm/software/components/hbugs/hbugs_tutors.mli new file mode 100644 index 000000000..43cd99cce --- /dev/null +++ b/helm/software/components/hbugs/hbugs_tutors.mli @@ -0,0 +1,60 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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;; + +val broker_url: string + +val register_to_broker: + tutor_id -> string -> hint_type -> string -> + broker_id +val unregister_from_broker: tutor_id -> unit + +val init_tutor: unit -> tutor_id +val load_state: + Hbugs_types.state -> + ProofEngineTypes.proof * ProofEngineTypes.goal + +module type HbugsTutor = + sig + val start: unit -> unit + end + +module type HbugsTutorDescription = + sig + val addr: string + val port: int + val tactic: ProofEngineTypes.tactic + val hint: hint + val hint_type: hint_type + val description: string + val environment_file: string + end + +module BuildTutor (Dsc: HbugsTutorDescription) : HbugsTutor + diff --git a/helm/software/components/hbugs/hbugs_types.mli b/helm/software/components/hbugs/hbugs_types.mli new file mode 100644 index 000000000..e3067f2e9 --- /dev/null +++ b/helm/software/components/hbugs/hbugs_types.mli @@ -0,0 +1,104 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +type broker_id = string +type client_id = string +type musing_id = string +type tutor_id = string +type tutor_dsc = tutor_id * string (* tutor id, tutor description *) + +type state = (* proof assitant's state: proof type, proof body, goal *) + string * string * int + +type hint = + (* tactics usage related hints *) + | Use_ring + | Use_fourier + | Use_reflexivity + | Use_symmetry + | Use_assumption + | Use_contradiction + | Use_exists + | Use_split + | Use_left + | Use_right + | Use_apply of string (* use apply tactic on embedded term *) + (* hints list *) + | Hints of hint list + +type hint_type = string (* TODO tipo di consiglio per l'utente *) + +type musing_result = + | Eureka of hint (* extra information, if any, parsed depending + on tutor's hint_type *) + | Sorry + + (* for each message, first component is an ID that identify the sender *) +type message = + + (* general purpose *) + | Help (* help request *) + | Usage of string (* help response *) (* usage string *) + | Exception of string * string (* name, value *) + + (* client -> broker *) + | Register_client of client_id * string (* client id, client url *) + | Unregister_client of client_id (* client id *) + | List_tutors of client_id (* client_id *) + | Subscribe of client_id * tutor_id list (* client id, tutor id list *) + | State_change of client_id * state option (* client_id, new state *) + | Wow of client_id (* client_id *) + + (* tutor -> broker *) + | Register_tutor of tutor_id * string * hint_type * string + (* tutor id, tutor url, hint type, + tutor description *) + | Unregister_tutor of tutor_id (* tutor id *) + | Musing_started of tutor_id * musing_id (* tutor id, musing id *) + | Musing_aborted of tutor_id * musing_id (* tutor id, musing id *) + | Musing_completed of tutor_id * musing_id * musing_result + (* tutor id, musing id, result *) + + (* broker -> client *) + | Client_registered of broker_id (* broker id *) + | Client_unregistered of broker_id (* broker id *) + | Tutor_list of broker_id * tutor_dsc list (* broker id, tutor list *) + | Subscribed of broker_id * tutor_id list (* broker id, tutor list *) + | State_accepted of broker_id * musing_id list * musing_id list + (* broker id, stopped musing ids, + started musing ids *) + | Hint of broker_id * hint (* broker id, hint *) + + (* broker -> tutor *) + | Tutor_registered of broker_id (* broker id *) + | Tutor_unregistered of broker_id (* broker id *) + | Start_musing of broker_id * state (* broker id, state *) + | Abort_musing of broker_id * musing_id (* broker id, musing id *) + | Thanks of broker_id * musing_id (* broker id, musing id *) + | Too_late of broker_id * musing_id (* broker id, musing id *) + diff --git a/helm/software/components/hbugs/scripts/brokerctl.sh b/helm/software/components/hbugs/scripts/brokerctl.sh new file mode 100755 index 000000000..3da998d6c --- /dev/null +++ b/helm/software/components/hbugs/scripts/brokerctl.sh @@ -0,0 +1,15 @@ +#!/bin/sh +daemon="broker" +if [ "$1" = "--help" -o "$1" = "" ]; then + echo "ctl.sh { start | stop | --help }" + exit 0 +fi +if [ "$1" = "start" ]; then + echo -n "Starting HBugs broker ... " + ./$daemon &> run/$daemon.log & + echo "done!" +elif [ "$1" = "stop" ]; then + echo -n "Stopping HBugs broker ... " + killall -9 $daemon + echo "done!" +fi diff --git a/helm/software/components/hbugs/scripts/build_tutors.ml b/helm/software/components/hbugs/scripts/build_tutors.ml new file mode 100755 index 000000000..9b742d84d --- /dev/null +++ b/helm/software/components/hbugs/scripts/build_tutors.ml @@ -0,0 +1,112 @@ +#!/usr/bin/ocamlrun /usr/bin/ocaml +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) +#use "topfind" +#require "pcre" +#require "pxp" +open Printf +open Pxp_document +open Pxp_dtd +open Pxp_types +open Pxp_yacc + +let index = "data/tutors_index.xml" +let template = "data/hbugs_tutor.TPL.ml" + + (* apply a set of regexp substitutions specified as a list of pairs + to a string *) +let rec apply_subst ~fill s = + match fill with + | [] -> s + | (pat, templ)::rest -> + apply_subst ~fill:rest (Pcre.replace ~pat ~templ s) + (* fill a ~template file with substitutions specified in ~fill (see + apply_subst) and save output to ~output *) +let fill_template ~template ~fill ~output = + printf "Creating %s ... " output; flush stdout; + let (ic, oc) = (open_in template, open_out output) in + let rec fill_template' () = + output_string oc ((apply_subst ~fill (input_line ic)) ^ "\n"); + fill_template' () + in + try + output_string oc (sprintf +"(* + THIS CODE IS GENERATED - DO NOT MODIFY! + + the source of this code is template \"%s\" + the template was filled with data read from \"%s\" +*)\n" + template index); + fill_template' () + with End_of_file -> + close_in ic; + close_out oc; + printf "done!\n"; flush stdout +let parse_xml fname = + parse_wfdocument_entity default_config (from_file fname) default_spec +let is_tutor node = + match node#node_type with T_element "tutor" -> true | _ -> false +let is_element node = + match node#node_type with T_element _ -> true | _ -> false +let main () = + (parse_xml index)#root#iter_nodes + (fun node -> + try + (match node with + | node when is_tutor node -> + (try (* skip hand-written tutors *) + ignore (find_element "no_auto" node); + raise Exit + with Not_found -> ()); + let output = + try + (match node#attribute "source" with + | Value s -> s + | _ -> assert false) + with Not_found -> assert false + in + let fill = + List.map (* create substitution list from index data *) + (fun node -> + let name = (* node name *) + (match node#node_type with + | T_element s -> s + | _ -> assert false) + in + let value = node#data in (* node value *) + (sprintf "@%s@" (String.uppercase name), (* pattern *) + value)) (* substitution *) + (List.filter is_element node#sub_nodes) + in + fill_template ~fill ~template ~output + | _ -> ()) + with Exit -> ()) + +let _ = main () + diff --git a/helm/software/components/hbugs/scripts/ls_tutors.ml b/helm/software/components/hbugs/scripts/ls_tutors.ml new file mode 100755 index 000000000..5fe796ca1 --- /dev/null +++ b/helm/software/components/hbugs/scripts/ls_tutors.ml @@ -0,0 +1,68 @@ +#!/usr/bin/ocamlrun /usr/bin/ocaml +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* Usage: ls_tutors.ml # lists all tutors + * ls_tutors.ml -auto # lists only generated tutors + *) + +#use "topfind" +#require "pxp" +open Printf +open Pxp_document +open Pxp_dtd +open Pxp_types +open Pxp_yacc + +let index = "data/tutors_index.xml" +let auto_only = + try + (match Sys.argv.(1) with "-auto" -> true | _ -> false) + with Invalid_argument _ -> false +let parse_xml fname = + parse_wfdocument_entity default_config (from_file fname) default_spec +let is_tutor node = + match node#node_type with T_element "tutor" -> true | _ -> false +let main () = + List.iter + (fun tutor -> + try + (match tutor#attribute "source" with + | Value s -> + if not auto_only then + print_endline s + else (* we should print only generated tutors *) + (try + ignore (find_element "no_auto" tutor); + with Not_found -> + print_endline s) + | _ -> assert false) + with Not_found -> assert false) + (List.filter is_tutor (parse_xml index)#root#sub_nodes) +let _ = main () + diff --git a/helm/software/components/hbugs/scripts/sabba.sh b/helm/software/components/hbugs/scripts/sabba.sh new file mode 100755 index 000000000..2031e295f --- /dev/null +++ b/helm/software/components/hbugs/scripts/sabba.sh @@ -0,0 +1,47 @@ +#!/bin/sh +# Copyright (C) 2003: +# Stefano Zacchiroli +# 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/ +if [ "$1" = "--help" -o "$1" = "" ]; then + echo "sabba.sh { start | stop | --help }" + exit 0 +fi + +./scripts/ls_tutors.ml | +while read line; do + tutor=`echo $line | sed 's/\.ml//'` + if [ "$1" = "stop" ]; then + echo -n "Stopping HBugs tutor $tutor ... " + killall -9 $tutor + echo "done!" + elif [ "$1" = "start" ]; then + echo -n "Starting HBugs tutor $tutor ... " + nice -n 19 ./$tutor &> run/$tutor.log & + echo "done!" + else + echo "Uh? Try --help" + exit 1 + fi +done diff --git a/helm/software/components/hbugs/search_pattern_apply_tutor.ml b/helm/software/components/hbugs/search_pattern_apply_tutor.ml new file mode 100644 index 000000000..79c94beed --- /dev/null +++ b/helm/software/components/hbugs/search_pattern_apply_tutor.ml @@ -0,0 +1,147 @@ +(* $Id$ *) + +open Hbugs_types;; +open Printf;; + +exception Empty_must;; + +module MQI = MQueryInterpreter +module MQIC = MQIConn + +let broker_id = ref None +let my_own_id = Hbugs_tutors.init_tutor () +let my_own_addr, my_own_port = "127.0.0.1", 50011 +let my_own_url = sprintf "%s:%d" my_own_addr my_own_port +let environment_file = "search_pattern_apply.environment" +let dump_environment_on_exit = false + +let is_authenticated id = + match !broker_id with + | None -> false + | Some broker_id -> id = broker_id + + (* thread who do the dirty work *) +let slave mqi_handle (state, musing_id) = + try + prerr_endline (sprintf "Hi, I'm the slave for musing %s" musing_id); + let (proof, goal) = Hbugs_tutors.load_state state in + let hint = + try + let choose_must must only = (* euristic: use 2nd precision level + 1st is more precise but is more slow *) + match must with + | [] -> raise Empty_must + | _::hd::tl -> hd + | hd::tl -> hd + in + let uris = + TacticChaser.matchConclusion mqi_handle + ~output_html:prerr_endline ~choose_must () ~status:(proof, goal) + in + if uris = [] then + Sorry + else + Eureka (Hints (List.map (fun uri -> Use_apply uri) uris)) + with Empty_must -> Sorry + in + let answer = Musing_completed (my_own_id, musing_id, hint) in + ignore (Hbugs_messages.submit_req ~url:Hbugs_tutors.broker_url answer); + prerr_endline + (sprintf "Bye, I've completed my duties (success = %b)" (hint <> Sorry)) + with + (Pxp_types.At _) as e -> + let rec unbox_exception = + function + Pxp_types.At (_,e) -> unbox_exception e + | e -> e + in + prerr_endline ("Uncaught PXP exception: " ^ Pxp_types.string_of_exn e) ; + (* e could be the Thread.exit exception; otherwise we will release an *) + (* uncaught exception and the Pxp_types.At was already an uncaught *) + (* exception ==> no additional arm *) + raise (unbox_exception e) + +let hbugs_callback mqi_handle = + let ids = Hashtbl.create 17 in + let forbidden () = + prerr_endline "ignoring request from unauthorized broker"; + Exception ("forbidden", "") + in + function + | Start_musing (broker_id, state) -> + if is_authenticated broker_id then begin + prerr_endline "received Start_musing"; + let new_musing_id = Hbugs_id_generator.new_musing_id () in + let id = ExtThread.create (slave mqi_handle) (state, new_musing_id) in + prerr_endline (sprintf "starting a new musing (id = %s)" new_musing_id); + Hashtbl.add ids new_musing_id id; + (*ignore (Thread.create slave (state, new_musing_id));*) + Musing_started (my_own_id, new_musing_id) + end else (* broker unauthorized *) + forbidden (); + | Abort_musing (broker_id, musing_id) -> + prerr_endline "CSC: Abort_musing received" ; + if is_authenticated broker_id then begin + (* prerr_endline "Ignoring 'Abort_musing' message ..."; *) + (try + ExtThread.kill (Hashtbl.find ids musing_id) ; + Hashtbl.remove ids musing_id ; + with + Not_found + | ExtThread.Can_t_kill _ -> + prerr_endline ("Can not kill slave " ^ musing_id)) ; + Musing_aborted (my_own_id, musing_id) + end else (* broker unauthorized *) + forbidden (); + | unexpected_msg -> + Exception ("unexpected_msg", + Hbugs_messages.string_of_msg unexpected_msg) + +let callback mqi_handle (req: Http_types.request) outchan = + try + let req_msg = Hbugs_messages.msg_of_string req#body in + let answer = hbugs_callback mqi_handle req_msg in + Http_daemon.respond ~body:(Hbugs_messages.string_of_msg answer) outchan + with Hbugs_messages.Parse_error (subj, reason) -> + Http_daemon.respond + ~body:(Hbugs_messages.string_of_msg + (Exception ("parse_error", reason))) + outchan + +let restore_environment () = + let ic = open_in environment_file in + prerr_endline "Restoring environment ..."; + CicEnvironment.restore_from_channel + ~callback:(fun uri -> prerr_endline uri) ic; + prerr_endline "... done!"; + close_in ic + +let dump_environment () = + let oc = open_out environment_file in + prerr_endline "Dumping environment ..."; + CicEnvironment.dump_to_channel + ~callback:(fun uri -> prerr_endline uri) oc; + prerr_endline "... done!"; + close_out oc + +let main () = + try + Sys.catch_break true; + at_exit (fun () -> + if dump_environment_on_exit then + dump_environment (); + Hbugs_tutors.unregister_from_broker my_own_id); + broker_id := + Some (Hbugs_tutors.register_to_broker + my_own_id my_own_url "FOO" "Search_pattern_apply tutor"); + let mqi_handle = MQIC.init ~log:prerr_string () in + if Sys.file_exists environment_file then + restore_environment (); + Http_daemon.start' + ~addr:my_own_addr ~port:my_own_port ~mode:`Thread (callback mqi_handle); + MQIC.close mqi_handle + with Sys.Break -> () (* exit nicely, invoking at_exit functions *) +;; + +main () + diff --git a/helm/software/components/hbugs/test/HBUGS_MESSAGES.xml b/helm/software/components/hbugs/test/HBUGS_MESSAGES.xml new file mode 100644 index 000000000..cf15dde3d --- /dev/null +++ b/helm/software/components/hbugs/test/HBUGS_MESSAGES.xml @@ -0,0 +1,144 @@ + + + + + + + usage string + + corpo dell'exc + + + + + + + + + + + + + + + + + + + 0 + + + + + + + + + + + + + + + + + + + + + descrizione del tutor + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + description 1 + description 2 + + description N + + + + description 1 + description 2 + + description N + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + + + + + + + + + diff --git a/helm/software/components/hbugs/test/Makefile b/helm/software/components/hbugs/test/Makefile new file mode 100644 index 000000000..0b3debf74 --- /dev/null +++ b/helm/software/components/hbugs/test/Makefile @@ -0,0 +1,5 @@ +all: test_serialization +test_serialization: test_serialization.ml + OCAMLPATH="../meta" ocamlfind ocamlc -linkpkg -package hbugs-common -o test_serialization test_serialization.ml +clean: + rm -f *.cm[io] test_serialization diff --git a/helm/software/components/hbugs/test/test_serialization.ml b/helm/software/components/hbugs/test/test_serialization.ml new file mode 100644 index 000000000..1afd74379 --- /dev/null +++ b/helm/software/components/hbugs/test/test_serialization.ml @@ -0,0 +1,70 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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 Pxp_document;; +open Pxp_dtd;; +open Pxp_types;; +open Pxp_yacc;; + +open Printf;; + +let test_data = "HBUGS_MESSAGES.xml" ;; + +let test_message (n:('a Pxp_document.extension as 'b) Pxp_document.node as 'a) = + try + let msg_string = + let buf = Buffer.create 1000 in + n#write (`Out_buffer buf) `Enc_utf8; + Buffer.contents buf + in + let msg = Hbugs_messages.msg_of_string msg_string in + let pp = Hbugs_messages.string_of_msg msg in + let msg' = Hbugs_messages.msg_of_string pp in + if (msg <> msg') then + prerr_endline + (sprintf "Failure with msg %s" + (match n#node_type with T_element name -> name | _ -> assert false)) + with e -> + prerr_endline + (sprintf "Failure with msg %s: uncaught exception %s" + (match n#node_type with T_element name -> name | _ -> assert false) + (Printexc.to_string e)) +;; + +let is_xml_element n = + match n#node_type with T_element _ -> true | _ -> false +;; + +let root = + parse_wfcontent_entity default_config (from_file test_data) default_spec +in +printf "Testing all messages from %s ...\n" test_data; flush stdout; +List.iter test_message (List.filter is_xml_element root#sub_nodes); +printf "Done!\n" +;; + diff --git a/helm/software/components/hgdome/.depend b/helm/software/components/hgdome/.depend new file mode 100644 index 000000000..bf9c09af7 --- /dev/null +++ b/helm/software/components/hgdome/.depend @@ -0,0 +1,4 @@ +domMisc.cmo: domMisc.cmi +domMisc.cmx: domMisc.cmi +xml2Gdome.cmo: xml2Gdome.cmi +xml2Gdome.cmx: xml2Gdome.cmi diff --git a/helm/software/components/hgdome/Makefile b/helm/software/components/hgdome/Makefile new file mode 100644 index 000000000..9630da26a --- /dev/null +++ b/helm/software/components/hgdome/Makefile @@ -0,0 +1,12 @@ +PACKAGE = hgdome + +# modules which have both a .ml and a .mli +INTERFACE_FILES = \ + domMisc.mli \ + xml2Gdome.mli \ + $(NULL) + +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/hgdome/domMisc.ml b/helm/software/components/hgdome/domMisc.ml new file mode 100644 index 000000000..97a15b7f8 --- /dev/null +++ b/helm/software/components/hgdome/domMisc.ml @@ -0,0 +1,43 @@ +(* 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 *) +(* 06/01/2002 *) +(* *) +(* *) +(******************************************************************************) + +(* $Id$ *) + +let domImpl = Gdome.domImplementation () +let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm" +let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink" +let mathml_ns = Gdome.domString "http://www.w3.org/1998/Math/MathML" +let boxml_ns = Gdome.domString "http://helm.cs.unibo.it/2003/BoxML" + diff --git a/helm/software/components/hgdome/domMisc.mli b/helm/software/components/hgdome/domMisc.mli new file mode 100644 index 000000000..25d642bc5 --- /dev/null +++ b/helm/software/components/hgdome/domMisc.mli @@ -0,0 +1,42 @@ +(* 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 *) +(* 15/01/2003 *) +(* *) +(* *) +(******************************************************************************) + +val domImpl : Gdome.domImplementation + +val helm_ns : Gdome.domString (** HELM namespace *) +val xlink_ns : Gdome.domString (** XLink namespace *) +val mathml_ns : Gdome.domString (** MathML namespace *) +val boxml_ns : Gdome.domString (** BoxML namespace *) + diff --git a/helm/software/components/hgdome/xml2Gdome.ml b/helm/software/components/hgdome/xml2Gdome.ml new file mode 100644 index 000000000..eb6a7641c --- /dev/null +++ b/helm/software/components/hgdome/xml2Gdome.ml @@ -0,0 +1,135 @@ +(* 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/. + *) + +(* $Id$ *) + +let document_of_xml (domImplementation : Gdome.domImplementation) strm = + let module G = Gdome in + let module X = Xml in + let rec update_namespaces ((defaultns,bindings) as namespaces) = + function + [] -> namespaces + | (None,"xmlns",value)::tl -> + update_namespaces (Some (Gdome.domString value),bindings) tl + | (prefix,name,value)::tl when prefix = Some "xmlns" -> + update_namespaces (defaultns,(name,Gdome.domString value)::bindings) tl + | _::tl -> update_namespaces namespaces tl in + let rec namespace_of_prefix (defaultns,bindings) = + function + None -> None + | Some "xmlns" -> Some (Gdome.domString "xml-ns") + | Some p' -> + try + Some (List.assoc p' bindings) + with + Not_found -> + raise + (Failure ("The prefix " ^ p' ^ " is not bound to any namespace")) in + let get_qualified_name p n = + match p with + None -> Gdome.domString n + | Some p' -> Gdome.domString (p' ^ ":" ^ n) in + let root_prefix,root_name,root_attributes,root_content = + ignore (Stream.next strm) ; (* to skip the declaration *) + ignore (Stream.next strm) ; (* to skip the DOCTYPE declaration *) + match Stream.next strm with + X.Empty(p,n,l) -> p,n,l,[<>] + | X.NEmpty(p,n,l,c) -> p,n,l,c + | _ -> assert false + in + let namespaces = update_namespaces (None,[]) root_attributes in + let namespaceURI = namespace_of_prefix namespaces root_prefix in + let document = + domImplementation#createDocument ~namespaceURI + ~qualifiedName:(get_qualified_name root_prefix root_name) + ~doctype:None + in + let rec aux namespaces (node : Gdome.node) = + parser + [< 'X.Str a ; s >] -> + let textnode = document#createTextNode ~data:(Gdome.domString a) in + ignore (node#appendChild ~newChild:(textnode :> Gdome.node)) ; + aux namespaces node s + | [< 'X.Empty(p,n,l) ; s >] -> + let namespaces' = update_namespaces namespaces l in + let namespaceURI = namespace_of_prefix namespaces' p in + let element = + document#createElementNS ~namespaceURI + ~qualifiedName:(get_qualified_name p n) + in + List.iter + (function (p,n,v) -> + if p = None then + element#setAttribute ~name:(Gdome.domString n) + ~value:(Gdome.domString v) + else + let namespaceURI = namespace_of_prefix namespaces' p in + element#setAttributeNS + ~namespaceURI + ~qualifiedName:(get_qualified_name p n) + ~value:(Gdome.domString v) + ) l ; + ignore + (node#appendChild + ~newChild:(element : Gdome.element :> Gdome.node)) ; + aux namespaces node s + | [< 'X.NEmpty(p,n,l,c) ; s >] -> + let namespaces' = update_namespaces namespaces l in + let namespaceURI = namespace_of_prefix namespaces' p in + let element = + document#createElementNS ~namespaceURI + ~qualifiedName:(get_qualified_name p n) + in + List.iter + (function (p,n,v) -> + if p = None then + element#setAttribute ~name:(Gdome.domString n) + ~value:(Gdome.domString v) + else + let namespaceURI = namespace_of_prefix namespaces' p in + element#setAttributeNS ~namespaceURI + ~qualifiedName:(get_qualified_name p n) + ~value:(Gdome.domString v) + ) l ; + ignore (node#appendChild ~newChild:(element :> Gdome.node)) ; + aux namespaces' (element :> Gdome.node) c ; + aux namespaces node s + | [< >] -> () + in + let root = document#get_documentElement in + List.iter + (function (p,n,v) -> + if p = None then + root#setAttribute ~name:(Gdome.domString n) + ~value:(Gdome.domString v) + else + let namespaceURI = namespace_of_prefix namespaces p in + root#setAttributeNS ~namespaceURI + ~qualifiedName:(get_qualified_name p n) + ~value:(Gdome.domString v) + ) root_attributes ; + aux namespaces (root : Gdome.element :> Gdome.node) root_content ; + document +;; diff --git a/helm/software/components/hgdome/xml2Gdome.mli b/helm/software/components/hgdome/xml2Gdome.mli new file mode 100644 index 000000000..45d0e9532 --- /dev/null +++ b/helm/software/components/hgdome/xml2Gdome.mli @@ -0,0 +1,27 @@ +(* 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 document_of_xml : + Gdome.domImplementation -> Xml.token Stream.t -> Gdome.document diff --git a/helm/software/components/hmysql/.depend b/helm/software/components/hmysql/.depend new file mode 100644 index 000000000..e67a0660c --- /dev/null +++ b/helm/software/components/hmysql/.depend @@ -0,0 +1,2 @@ +hMysql.cmo: hMysql.cmi +hMysql.cmx: hMysql.cmi diff --git a/helm/software/components/hmysql/Makefile b/helm/software/components/hmysql/Makefile new file mode 100644 index 000000000..8a83eb23e --- /dev/null +++ b/helm/software/components/hmysql/Makefile @@ -0,0 +1,12 @@ +PACKAGE = hmysql +PREDICATES = + +INTERFACE_FILES = \ + hMysql.mli +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/hmysql/hMysql.ml b/helm/software/components/hmysql/hMysql.ml new file mode 100644 index 000000000..94f3efe03 --- /dev/null +++ b/helm/software/components/hmysql/hMysql.ml @@ -0,0 +1,80 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +type dbd = Mysql.dbd option +type result = Mysql.result option +type error_code = Mysql.error_code + +let profiler = HExtlib.profile "mysql" + +let use_real_db () = + not (Helm_registry.get_opt_default Helm_registry.bool + ~default:false "db.nodb") + +let quick_connect ?host ?database ?port ?password ?user () = + profiler.HExtlib.profile + (fun () -> + if use_real_db () then + (Some (Mysql.quick_connect ?host ?database ?port ?password ?user ())) + else + None) + () + +let disconnect = function + | None -> () + | Some dbd -> profiler.HExtlib.profile Mysql.disconnect dbd + +let escape s = + profiler.HExtlib.profile Mysql.escape s + +let exec dbd s = + match dbd with + | None -> None + | Some dbd -> Some (profiler.HExtlib.profile (Mysql.exec dbd) s) + +let map res ~f = + match res with + | None -> [] + | Some res -> + let map f = Mysql.map res ~f in + profiler.HExtlib.profile map f + +let iter res ~f = + match res with + | None -> () + | Some res -> + let iter f = Mysql.iter res ~f in + profiler.HExtlib.profile iter f + +let errno = function + | None -> Mysql.Connection_error + | Some dbd -> profiler.HExtlib.profile Mysql.errno dbd + +let status = function + | None -> Mysql.StatusError Mysql.Connection_error + | Some dbd -> profiler.HExtlib.profile Mysql.status dbd + diff --git a/helm/software/components/hmysql/hMysql.mli b/helm/software/components/hmysql/hMysql.mli new file mode 100644 index 000000000..a5b90593e --- /dev/null +++ b/helm/software/components/hmysql/hMysql.mli @@ -0,0 +1,56 @@ +(* Copyright (C) 2005, 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/. + *) + +(** + * {2 Proxy module around MySQL conection} + * + * The behaviour of this module is influenced by the Helm_registry boolean value + * of the "db.nodb" key. When set to "false" the module works as expected. When + * set to "true" all functions perform dummy action: connect and disconnect do + * nothing; exec, iter, and map work like the empty set of results has been + * returned; errno and status return Mysql.Connection_error + *) + +type dbd +type result + +(* the exceptions raised are from the Mysql module *) + +val quick_connect : + ?host:string -> + ?database:string -> + ?port:int -> ?password:string -> ?user:string -> unit -> dbd + +val disconnect : dbd -> unit + +val exec: dbd -> string -> result +val map : result -> f:(string option array -> 'a) -> 'a list +val iter : result -> f:(string option array -> unit) -> unit + +val errno : dbd -> Mysql.error_code +val status : dbd -> Mysql.status + +val escape: string -> string + diff --git a/helm/software/components/lexicon/.depend b/helm/software/components/lexicon/.depend new file mode 100644 index 000000000..452167c72 --- /dev/null +++ b/helm/software/components/lexicon/.depend @@ -0,0 +1,20 @@ +lexiconAstPp.cmi: lexiconAst.cmo +disambiguatePp.cmi: lexiconAst.cmo +lexiconMarshal.cmi: lexiconAst.cmo +cicNotation.cmi: lexiconAst.cmo +lexiconEngine.cmi: lexiconMarshal.cmi lexiconAst.cmo cicNotation.cmi +lexiconSync.cmi: lexiconEngine.cmi +lexiconAstPp.cmo: lexiconAst.cmo lexiconAstPp.cmi +lexiconAstPp.cmx: lexiconAst.cmx lexiconAstPp.cmi +disambiguatePp.cmo: lexiconAstPp.cmi lexiconAst.cmo disambiguatePp.cmi +disambiguatePp.cmx: lexiconAstPp.cmx lexiconAst.cmx disambiguatePp.cmi +lexiconMarshal.cmo: lexiconAstPp.cmi lexiconAst.cmo lexiconMarshal.cmi +lexiconMarshal.cmx: lexiconAstPp.cmx lexiconAst.cmx lexiconMarshal.cmi +cicNotation.cmo: lexiconAst.cmo cicNotation.cmi +cicNotation.cmx: lexiconAst.cmx cicNotation.cmi +lexiconEngine.cmo: lexiconMarshal.cmi lexiconAst.cmo disambiguatePp.cmi \ + cicNotation.cmi lexiconEngine.cmi +lexiconEngine.cmx: lexiconMarshal.cmx lexiconAst.cmx disambiguatePp.cmx \ + cicNotation.cmx lexiconEngine.cmi +lexiconSync.cmo: lexiconEngine.cmi cicNotation.cmi lexiconSync.cmi +lexiconSync.cmx: lexiconEngine.cmx cicNotation.cmx lexiconSync.cmi diff --git a/helm/software/components/lexicon/Makefile b/helm/software/components/lexicon/Makefile new file mode 100644 index 000000000..b8582baca --- /dev/null +++ b/helm/software/components/lexicon/Makefile @@ -0,0 +1,18 @@ +PACKAGE = lexicon +PREDICATES = + +INTERFACE_FILES = \ + lexiconAstPp.mli \ + disambiguatePp.mli \ + lexiconMarshal.mli \ + cicNotation.mli \ + lexiconEngine.mli \ + lexiconSync.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + lexiconAst.ml \ + $(INTERFACE_FILES:%.mli=%.ml) + + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/lexicon/cicNotation.ml b/helm/software/components/lexicon/cicNotation.ml new file mode 100644 index 000000000..1d18691ff --- /dev/null +++ b/helm/software/components/lexicon/cicNotation.ml @@ -0,0 +1,83 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open LexiconAst + +type notation_id = + | RuleId of CicNotationParser.rule_id + | InterpretationId of TermAcicContent.interpretation_id + | PrettyPrinterId of TermContentPres.pretty_printer_id + +let process_notation st = + match st with + | Notation (loc, dir, l1, associativity, precedence, l2) -> + let rule_id = + if dir <> Some `RightToLeft then + [ RuleId (CicNotationParser.extend l1 ?precedence ?associativity + (fun env loc -> + CicNotationPt.AttributedTerm + (`Loc loc,TermContentPres.instantiate_level2 env l2))) ] + else + [] + in + let pp_id = + if dir <> Some `LeftToRight then + [ PrettyPrinterId + (TermContentPres.add_pretty_printer ?precedence ?associativity + l2 l1) ] + else + [] + in + rule_id @ pp_id + | Interpretation (loc, dsc, l2, l3) -> + let interp_id = TermAcicContent.add_interpretation dsc l2 l3 in + [InterpretationId interp_id] + | st -> [] + +let remove_notation = function + | RuleId id -> CicNotationParser.delete id + | PrettyPrinterId id -> TermContentPres.remove_pretty_printer id + | InterpretationId id -> TermAcicContent.remove_interpretation id + +let get_all_notations () = + List.map + (fun (interp_id, dsc) -> + InterpretationId interp_id, "interpretation: " ^ dsc) + (TermAcicContent.get_all_interpretations ()) + +let get_active_notations () = + List.map (fun id -> InterpretationId id) + (TermAcicContent.get_active_interpretations ()) + +let set_active_notations ids = + let interp_ids = + HExtlib.filter_map + (function InterpretationId interp_id -> Some interp_id | _ -> None) + ids + in + TermAcicContent.set_active_interpretations interp_ids + diff --git a/helm/software/components/lexicon/cicNotation.mli b/helm/software/components/lexicon/cicNotation.mli new file mode 100644 index 000000000..944438df8 --- /dev/null +++ b/helm/software/components/lexicon/cicNotation.mli @@ -0,0 +1,40 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +type notation_id + +val process_notation: LexiconAst.command -> notation_id list + +val remove_notation: notation_id -> unit + +(** {2 Notation enabling/disabling} + * Right now, only disabling of notation during pretty printing is supporting. + * If it is useful to disable it also for the input phase is still to be + * understood ... *) + +val get_all_notations: unit -> (notation_id * string) list (* id, dsc *) +val get_active_notations: unit -> notation_id list +val set_active_notations: notation_id list -> unit + diff --git a/helm/software/components/lexicon/disambiguatePp.ml b/helm/software/components/lexicon/disambiguatePp.ml new file mode 100644 index 000000000..5f6512477 --- /dev/null +++ b/helm/software/components/lexicon/disambiguatePp.ml @@ -0,0 +1,53 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open DisambiguateTypes + +let alias_of_domain_and_codomain_items domain_item (dsc,_) = + match domain_item with + Id id -> LexiconAst.Ident_alias (id, dsc) + | Symbol (symb, i) -> LexiconAst.Symbol_alias (symb, i, dsc) + | Num i -> LexiconAst.Number_alias (i, dsc) + +let aliases_of_environment env = + Environment.fold + (fun domain_item codomain_item acc -> + alias_of_domain_and_codomain_items domain_item codomain_item::acc + ) env [] + +let aliases_of_domain_and_codomain_items_list l = + List.fold_left + (fun acc (domain_item,codomain_item) -> + alias_of_domain_and_codomain_items domain_item codomain_item::acc + ) [] l + +let pp_environment env = + let aliases = aliases_of_environment env in + let strings = + List.map (fun alias -> LexiconAstPp.pp_alias alias ^ ".") aliases + in + String.concat "\n" (List.sort compare strings) diff --git a/helm/software/components/lexicon/disambiguatePp.mli b/helm/software/components/lexicon/disambiguatePp.mli new file mode 100644 index 000000000..e8d9b94a4 --- /dev/null +++ b/helm/software/components/lexicon/disambiguatePp.mli @@ -0,0 +1,30 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val aliases_of_domain_and_codomain_items_list: + (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list -> + LexiconAst.alias_spec list + +val pp_environment: DisambiguateTypes.environment -> string diff --git a/helm/software/components/lexicon/lexiconAst.ml b/helm/software/components/lexicon/lexiconAst.ml new file mode 100644 index 000000000..aed4b0b15 --- /dev/null +++ b/helm/software/components/lexicon/lexiconAst.ml @@ -0,0 +1,55 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +type direction = [ `LeftToRight | `RightToLeft ] + +type loc = Token.flocation + +type alias_spec = + | Ident_alias of string * string (* identifier, uri *) + | Symbol_alias of string * int * string (* name, instance no, description *) + | Number_alias of int * string (* instance no, description *) + +(** To be increased each time the command type below changes, used for "safe" + * marshalling *) +let magic = 5 + +type command = + | Include of loc * string + | Alias of loc * alias_spec + (** parameters, name, type, fields *) + | Notation of loc * direction option * CicNotationPt.term * Gramext.g_assoc * + int * CicNotationPt.term + (* direction, l1 pattern, associativity, precedence, l2 pattern *) + | Interpretation of loc * + string * (string * CicNotationPt.argument_pattern list) * + CicNotationPt.cic_appl_pattern + (* description (i.e. id), symbol, arg pattern, appl pattern *) + +(* composed magic: term + command magics. No need to change this value *) +let magic = magic + 10000 * CicNotationPt.magic + diff --git a/helm/software/components/lexicon/lexiconAstPp.ml b/helm/software/components/lexicon/lexiconAstPp.ml new file mode 100644 index 000000000..e49a66f60 --- /dev/null +++ b/helm/software/components/lexicon/lexiconAstPp.ml @@ -0,0 +1,84 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open LexiconAst + +let pp_l1_pattern = CicNotationPp.pp_term +let pp_l2_pattern = CicNotationPp.pp_term + +let pp_alias = function + | Ident_alias (id, uri) -> sprintf "alias id \"%s\" = \"%s\"" id uri + | Symbol_alias (symb, instance, desc) -> + sprintf "alias symbol \"%s\" (instance %d) = \"%s\"" + symb instance desc + | Number_alias (instance,desc) -> + sprintf "alias num (instance %d) = \"%s\"" instance desc + +let pp_associativity = function + | Gramext.LeftA -> "left associative" + | Gramext.RightA -> "right associative" + | Gramext.NonA -> "non associative" + +let pp_precedence i = sprintf "with precedence %d" i + +let pp_argument_pattern = function + | CicNotationPt.IdentArg (eta_depth, name) -> + let eta_buf = Buffer.create 5 in + for i = 1 to eta_depth do + Buffer.add_string eta_buf "\\eta." + done; + sprintf "%s%s" (Buffer.contents eta_buf) name + +let pp_interpretation dsc symbol arg_patterns cic_appl_pattern = + sprintf "interpretation \"%s\" '%s %s = %s" + dsc symbol + (String.concat " " (List.map pp_argument_pattern arg_patterns)) + (CicNotationPp.pp_cic_appl_pattern cic_appl_pattern) + +let pp_dir_opt = function + | None -> "" + | Some `LeftToRight -> "> " + | Some `RightToLeft -> "< " + +let pp_notation dir_opt l1_pattern assoc prec l2_pattern = + sprintf "notation %s\"%s\" %s %s for %s" + (pp_dir_opt dir_opt) + (pp_l1_pattern l1_pattern) + (pp_associativity assoc) + (pp_precedence prec) + (pp_l2_pattern l2_pattern) + +let pp_command = function + | Include (_,path) -> "include " ^ path + | Alias (_,s) -> pp_alias s + | Interpretation (_, dsc, (symbol, arg_patterns), cic_appl_pattern) -> + pp_interpretation dsc symbol arg_patterns cic_appl_pattern + | Notation (_, dir_opt, l1_pattern, assoc, prec, l2_pattern) -> + pp_notation dir_opt l1_pattern assoc prec l2_pattern + diff --git a/helm/software/components/lexicon/lexiconAstPp.mli b/helm/software/components/lexicon/lexiconAstPp.mli new file mode 100644 index 000000000..b7ad59f3c --- /dev/null +++ b/helm/software/components/lexicon/lexiconAstPp.mli @@ -0,0 +1,29 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val pp_command: LexiconAst.command -> string + +val pp_alias: LexiconAst.alias_spec -> string + diff --git a/helm/software/components/lexicon/lexiconEngine.ml b/helm/software/components/lexicon/lexiconEngine.ml new file mode 100644 index 000000000..aec759c96 --- /dev/null +++ b/helm/software/components/lexicon/lexiconEngine.ml @@ -0,0 +1,150 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception IncludedFileNotCompiled of string (* file name *) +exception MetadataNotFound of string (* file name *) + +type status = { + aliases: DisambiguateTypes.environment; (** disambiguation aliases *) + multi_aliases: DisambiguateTypes.multiple_environment; + lexicon_content_rev: LexiconMarshal.lexicon; + notation_ids: CicNotation.notation_id list; (** in-scope notation ids *) + metadata: LibraryNoDb.metadata list; +} + +let add_lexicon_content cmds status = + let content = status.lexicon_content_rev in + let content' = + List.fold_right + (fun cmd acc -> cmd :: (List.filter ((<>) cmd) acc)) + cmds content + in +(* prerr_endline ("new lexicon content: " ^ String.concat " " (List.map + LexiconAstPp.pp_command content')); *) + { status with lexicon_content_rev = content' } + +let add_metadata new_metadata status = + if Helm_registry.get_bool "db.nodb" then + let metadata = status.metadata in + let metadata' = + List.fold_left + (fun acc m -> + match m with + | LibraryNoDb.Dependency buri -> + if List.exists (LibraryNoDb.eq_metadata m) metadata + then acc + else m :: acc) + metadata new_metadata + in + { status with metadata = metadata' } + else + status + +let set_proof_aliases status new_aliases = + let commands_of_aliases = + List.map + (fun alias -> LexiconAst.Alias (HExtlib.dummy_floc, alias)) + in + let deps_of_aliases = + HExtlib.filter_map + (function + | LexiconAst.Ident_alias (_, suri) -> + let buri = UriManager.buri_of_uri (UriManager.uri_of_string suri) in + Some (LibraryNoDb.Dependency buri) + | _ -> None) + in + let aliases = + List.fold_left (fun acc (d,c) -> DisambiguateTypes.Environment.add d c acc) + status.aliases new_aliases in + let multi_aliases = + List.fold_left (fun acc (d,c) -> DisambiguateTypes.Environment.cons d c acc) + status.multi_aliases new_aliases in + let new_status = + { status with multi_aliases = multi_aliases ; aliases = aliases} + in + if new_aliases = [] then + new_status + else + let aliases = + DisambiguatePp.aliases_of_domain_and_codomain_items_list new_aliases + in + let status = add_lexicon_content (commands_of_aliases aliases) new_status in + let status = add_metadata (deps_of_aliases aliases) status in + status + +let rec eval_command status cmd = + let notation_ids' = CicNotation.process_notation cmd in + let status = + { status with notation_ids = notation_ids' @ status.notation_ids } in + let basedir = Helm_registry.get "matita.basedir" in + match cmd with + | LexiconAst.Include (loc, baseuri) -> + let lexiconpath = LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri in + if not (Sys.file_exists lexiconpath) then + raise (IncludedFileNotCompiled lexiconpath); + let lexicon = LexiconMarshal.load_lexicon lexiconpath in + let status = List.fold_left eval_command status lexicon in + if Helm_registry.get_bool "db.nodb" then + let metadatapath = LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri in + if not (Sys.file_exists metadatapath) then + raise (MetadataNotFound metadatapath) + else + add_metadata (LibraryNoDb.load_metadata ~fname:metadatapath) status + else + status + | LexiconAst.Alias (loc, spec) -> + let diff = + (*CSC: Warning: this code should be factorized with the corresponding + code in DisambiguatePp *) + match spec with + | LexiconAst.Ident_alias (id,uri) -> + [DisambiguateTypes.Id id, + (uri,(fun _ _ _-> CicUtil.term_of_uri(UriManager.uri_of_string uri)))] + | LexiconAst.Symbol_alias (symb, instance, desc) -> + [DisambiguateTypes.Symbol (symb,instance), + DisambiguateChoices.lookup_symbol_by_dsc symb desc] + | LexiconAst.Number_alias (instance,desc) -> + [DisambiguateTypes.Num instance, + DisambiguateChoices.lookup_num_by_dsc desc] + in + set_proof_aliases status diff + | LexiconAst.Interpretation (_, dsc, (symbol, _), cic_appl_pattern) as stm -> + let status = add_lexicon_content [stm] status in + let uris = + List.map + (fun uri -> LibraryNoDb.Dependency (UriManager.buri_of_uri uri)) + (CicNotationUtil.find_appl_pattern_uris cic_appl_pattern) + in + let diff = + [DisambiguateTypes.Symbol (symbol, 0), + DisambiguateChoices.lookup_symbol_by_dsc symbol dsc] + in + let status = set_proof_aliases status diff in + let status = add_metadata uris status in + status + | LexiconAst.Notation _ as stm -> add_lexicon_content [stm] status + diff --git a/helm/software/components/lexicon/lexiconEngine.mli b/helm/software/components/lexicon/lexiconEngine.mli new file mode 100644 index 000000000..ba0938640 --- /dev/null +++ b/helm/software/components/lexicon/lexiconEngine.mli @@ -0,0 +1,41 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +exception IncludedFileNotCompiled of string + +type status = { + aliases: DisambiguateTypes.environment; (** disambiguation aliases *) + multi_aliases: DisambiguateTypes.multiple_environment; + lexicon_content_rev: LexiconMarshal.lexicon; + notation_ids: CicNotation.notation_id list; (** in-scope notation ids *) + metadata: LibraryNoDb.metadata list; +} + +val eval_command : status -> LexiconAst.command -> status + +val set_proof_aliases: + status -> + (DisambiguateTypes.Environment.key * DisambiguateTypes.codomain_item) list -> + status diff --git a/helm/software/components/lexicon/lexiconMarshal.ml b/helm/software/components/lexicon/lexiconMarshal.ml new file mode 100644 index 000000000..7b9422db5 --- /dev/null +++ b/helm/software/components/lexicon/lexiconMarshal.ml @@ -0,0 +1,67 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +type lexicon = LexiconAst.command list + +let format_name = "lexicon" + +let save_lexicon_to_file ~fname lexicon = + HMarshal.save ~fmt:format_name ~version:LexiconAst.magic ~fname lexicon + +let load_lexicon_from_file ~fname = + let raw = HMarshal.load ~fmt:format_name ~version:LexiconAst.magic ~fname in + (raw: lexicon) + +let rehash_cmd_uris = + let rehash_uri uri = + UriManager.uri_of_string (UriManager.string_of_uri uri) in + function + | LexiconAst.Interpretation (loc, dsc, args, cic_appl_pattern) -> + let rec aux = + function + | CicNotationPt.UriPattern uri -> + CicNotationPt.UriPattern (rehash_uri uri) + | CicNotationPt.ApplPattern args -> + CicNotationPt.ApplPattern (List.map aux args) + | CicNotationPt.VarPattern _ + | CicNotationPt.ImplicitPattern as pat -> pat + in + let appl_pattern = aux cic_appl_pattern in + LexiconAst.Interpretation (loc, dsc, args, appl_pattern) + | LexiconAst.Notation _ + | LexiconAst.Alias _ as cmd -> cmd + | cmd -> + prerr_endline "Found a command not expected in a .lexicon:"; + prerr_endline (LexiconAstPp.pp_command cmd); + assert false + +let save_lexicon ~fname lexicon = save_lexicon_to_file ~fname (List.rev lexicon) + +let load_lexicon ~fname = + let lexicon = load_lexicon_from_file ~fname in + List.map rehash_cmd_uris lexicon + diff --git a/helm/software/components/lexicon/lexiconMarshal.mli b/helm/software/components/lexicon/lexiconMarshal.mli new file mode 100644 index 000000000..930d73f8d --- /dev/null +++ b/helm/software/components/lexicon/lexiconMarshal.mli @@ -0,0 +1,32 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +type lexicon = LexiconAst.command list + +val save_lexicon: fname:string -> lexicon -> unit + + (** @raise HMarshal.* *) +val load_lexicon: fname:string -> lexicon + diff --git a/helm/software/components/lexicon/lexiconSync.ml b/helm/software/components/lexicon/lexiconSync.ml new file mode 100644 index 000000000..d7fa27f90 --- /dev/null +++ b/helm/software/components/lexicon/lexiconSync.ml @@ -0,0 +1,119 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let alias_diff ~from status = + let module Map = DisambiguateTypes.Environment in + Map.fold + (fun domain_item (description1,_ as codomain_item) acc -> + try + let description2,_ = Map.find domain_item from.LexiconEngine.aliases in + if description1 <> description2 then + (domain_item,codomain_item)::acc + else + acc + with + Not_found -> + (domain_item,codomain_item)::acc) + status.LexiconEngine.aliases [] + +let alias_diff = + let profiler = HExtlib.profile "alias_diff (conteggiato anche in include)" in + fun ~from status -> profiler.HExtlib.profile (alias_diff ~from) status + +(** given a uri and a type list (the contructors types) builds a list of pairs + * (name,uri) that is used to generate automatic aliases **) +let extract_alias types uri = + fst(List.fold_left ( + fun (acc,i) (name, _, _, cl) -> + (name, UriManager.uri_of_uriref uri i None) :: + (fst(List.fold_left ( + fun (acc,j) (name,_) -> + (((name,UriManager.uri_of_uriref uri i + (Some j)) :: acc) , j+1) + ) (acc,1) cl)),i+1 + ) ([],0) types) + +let build_aliases = + List.map + (fun (name,uri) -> + DisambiguateTypes.Id name, + (UriManager.string_of_uri uri, fun _ _ _ -> CicUtil.term_of_uri uri)) + +let add_aliases_for_inductive_def status types uri = + let aliases = build_aliases (extract_alias types uri) in + LexiconEngine.set_proof_aliases status aliases + +let add_alias_for_constant status uri = + let name = UriManager.name_of_uri uri in + let new_env = build_aliases [(name,uri)] in + LexiconEngine.set_proof_aliases status new_env + +let add_aliases_for_object status uri = + function + Cic.InductiveDefinition (types,_,_,_) -> + add_aliases_for_inductive_def status types uri + | Cic.Constant _ -> add_alias_for_constant status uri + | Cic.Variable _ + | Cic.CurrentProof _ -> assert false + +let add_aliases_for_objs = + List.fold_left + (fun status uri -> + let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + add_aliases_for_object status uri obj) + +module OrderedId = +struct + type t = CicNotation.notation_id + let compare = Pervasives.compare +end + +module IdSet = Set.Make (OrderedId) + + (** @return l2 \ l1 *) +let id_list_diff l2 l1 = + let module S = IdSet in + let s1 = List.fold_left (fun set uri -> S.add uri set) S.empty l1 in + let s2 = List.fold_left (fun set uri -> S.add uri set) S.empty l2 in + let diff = S.diff s2 s1 in + S.fold (fun uri uris -> uri :: uris) diff [] + +let time_travel ~present ~past = + let notation_to_remove = + id_list_diff present.LexiconEngine.notation_ids + past.LexiconEngine.notation_ids + in + List.iter CicNotation.remove_notation notation_to_remove + +let init = + { + LexiconEngine.aliases = DisambiguateTypes.Environment.empty; + multi_aliases = DisambiguateTypes.Environment.empty; + lexicon_content_rev = []; + notation_ids = []; + metadata = []; + } diff --git a/helm/software/components/lexicon/lexiconSync.mli b/helm/software/components/lexicon/lexiconSync.mli new file mode 100644 index 000000000..62d8b97f5 --- /dev/null +++ b/helm/software/components/lexicon/lexiconSync.mli @@ -0,0 +1,40 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val add_aliases_for_objs: + LexiconEngine.status -> UriManager.uri list -> LexiconEngine.status + +val time_travel: + present:LexiconEngine.status -> past:LexiconEngine.status -> unit + + (** perform a diff between the aliases contained in two statuses, assuming + * that the second one can only have more aliases than the first one + * @return the list of aliases that should be added to aliases of from in + * order to be equal to aliases of the second argument *) +val alias_diff: + from:LexiconEngine.status -> LexiconEngine.status -> + (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list + +val init: LexiconEngine.status diff --git a/helm/software/components/library/.depend b/helm/software/components/library/.depend new file mode 100644 index 000000000..5054959da --- /dev/null +++ b/helm/software/components/library/.depend @@ -0,0 +1,25 @@ +cicCoercion.cmi: coercDb.cmi +cicElim.cmo: cicElim.cmi +cicElim.cmx: cicElim.cmi +cicRecord.cmo: cicRecord.cmi +cicRecord.cmx: cicRecord.cmi +libraryMisc.cmo: libraryMisc.cmi +libraryMisc.cmx: libraryMisc.cmi +libraryDb.cmo: libraryDb.cmi +libraryDb.cmx: libraryDb.cmi +coercDb.cmo: coercDb.cmi +coercDb.cmx: coercDb.cmi +cicCoercion.cmo: coercDb.cmi cicCoercion.cmi +cicCoercion.cmx: coercDb.cmx cicCoercion.cmi +coercGraph.cmo: coercDb.cmi coercGraph.cmi +coercGraph.cmx: coercDb.cmx coercGraph.cmi +librarySync.cmo: libraryDb.cmi coercGraph.cmi coercDb.cmi cicRecord.cmi \ + cicElim.cmi cicCoercion.cmi librarySync.cmi +librarySync.cmx: libraryDb.cmx coercGraph.cmx coercDb.cmx cicRecord.cmx \ + cicElim.cmx cicCoercion.cmx librarySync.cmi +libraryNoDb.cmo: libraryNoDb.cmi +libraryNoDb.cmx: libraryNoDb.cmi +libraryClean.cmo: librarySync.cmi libraryNoDb.cmi libraryMisc.cmi \ + libraryDb.cmi libraryClean.cmi +libraryClean.cmx: librarySync.cmx libraryNoDb.cmx libraryMisc.cmx \ + libraryDb.cmx libraryClean.cmi diff --git a/helm/software/components/library/Makefile b/helm/software/components/library/Makefile new file mode 100644 index 000000000..4f0ca3eb8 --- /dev/null +++ b/helm/software/components/library/Makefile @@ -0,0 +1,20 @@ +PACKAGE = library +PREDICATES = + +INTERFACE_FILES = \ + cicElim.mli \ + cicRecord.mli \ + libraryMisc.mli \ + libraryDb.mli \ + coercDb.mli \ + cicCoercion.mli \ + coercGraph.mli \ + librarySync.mli \ + libraryNoDb.mli \ + libraryClean.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/library/cicCoercion.ml b/helm/software/components/library/cicCoercion.ml new file mode 100644 index 000000000..fe636ee35 --- /dev/null +++ b/helm/software/components/library/cicCoercion.ml @@ -0,0 +1,156 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) else () + +(* given the new coercion uri from src to tgt returns the list + * of new coercions to create. hte list elements are + * (source, list of coercions to follow, target) + *) +let get_closure_coercions src tgt uri coercions = + let eq_carr s t = + try + CoercDb.eq_carr s t + with + | CoercDb.EqCarrNotImplemented _ | CoercDb.EqCarrOnNonMetaClosed -> false + in + match src,tgt with + | CoercDb.Uri _, CoercDb.Uri _ -> + let c_from_tgt = + List.filter (fun (f,_,_) -> eq_carr f tgt) coercions + in + let c_to_src = + List.filter (fun (_,t,_) -> eq_carr t src) coercions + in + (List.map (fun (_,t,u) -> src,[uri; u],t) c_from_tgt) @ + (List.map (fun (s,_,u) -> s,[u; uri],tgt) c_to_src) @ + (List.fold_left ( + fun l (s,_,u1) -> + ((List.map (fun (_,t,u2) -> + (s,[u1;uri;u2],t) + )c_from_tgt)@l) ) + [] c_to_src) + | _ -> [] (* do not close in case source or target is not an indty ?? *) +;; + +let obj_attrs = [`Class `Coercion; `Generated] + +(* generate_composite_closure (c2 (c1 s)) in the universe graph univ *) +let generate_composite_closure c1 c2 univ = + let c1_ty,univ = CicTypeChecker.type_of_aux' [] [] c1 univ in + let rec mk_rels n = + match n with + | 0 -> [] + | _ -> (Cic.Rel n) :: (mk_rels (n-1)) + in + let rec compose k = + function + | Cic.Prod (name,src,tgt) -> + let name = + match name with + | Cic.Anonymous -> Cic.Name "x" + | _ -> name + in + Cic.Lambda (name,src,compose (k+1) tgt) + | Cic.Appl (he::tl) -> + Cic.Appl (c2 :: tl @ [Cic.Appl (c1 :: (mk_rels k)) ]) + | _ -> Cic.Appl (c2 :: [Cic.Appl (c1 :: (mk_rels k)) ]) + in + let c = compose 0 c1_ty in + let c_ty,univ = + try + CicTypeChecker.type_of_aux' [] [] c univ + with CicTypeChecker.TypeCheckerFailure s as exn -> + debug_print (lazy (Printf.sprintf "Generated composite coercion:\n%s\n%s" + (CicPp.ppterm c) (Lazy.force s))); + raise exn + in + let cleaned_ty = + FreshNamesGenerator.clean_dummy_dependent_types c_ty + in + let obj = Cic.Constant ("xxxx",Some c,cleaned_ty,[],obj_attrs) in + obj,univ +;; + +(* removes from l the coercions that are in !coercions *) +let filter_duplicates l coercions = + List.filter ( + fun (src,_,tgt) -> + not (List.exists (fun (s,t,u) -> + CoercDb.eq_carr s src && + CoercDb.eq_carr t tgt) + coercions)) + l + +(* given a new coercion uri from src to tgt returns + * a list of (new coercion uri, coercion obj, universe graph) + *) +let close_coercion_graph src tgt uri = + (* check if the coercion already exists *) + let coercions = CoercDb.to_list () in + let todo_list = get_closure_coercions src tgt uri coercions in + let todo_list = filter_duplicates todo_list coercions in + let new_coercions = + List.map ( + fun (src, l , tgt) -> + match l with + | [] -> assert false + | he :: tl -> + let first_step = + Cic.Constant ("", + Some (CoercDb.term_of_carr (CoercDb.Uri he)), + Cic.Sort Cic.Prop, [], obj_attrs) + in + let o,_ = + List.fold_left (fun (o,univ) coer -> + match o with + | Cic.Constant (_,Some c,_,[],_) -> + generate_composite_closure c (CoercDb.term_of_carr (CoercDb.Uri + coer)) univ + | _ -> assert false + ) (first_step, CicUniv.empty_ugraph) tl + in + let name_src = CoercDb.name_of_carr src in + let name_tgt = CoercDb.name_of_carr tgt in + let name = name_tgt ^ "_of_" ^ name_src in + let buri = UriManager.buri_of_uri uri in + let c_uri = + UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") + in + let named_obj = + match o with + | Cic.Constant (_,bo,ty,vl,attrs) -> + Cic.Constant (name,bo,ty,vl,attrs) + | _ -> assert false + in + ((src,tgt,c_uri,named_obj)) + ) todo_list + in + new_coercions +;; + diff --git a/helm/software/components/library/cicCoercion.mli b/helm/software/components/library/cicCoercion.mli new file mode 100644 index 000000000..c9eaf0aac --- /dev/null +++ b/helm/software/components/library/cicCoercion.mli @@ -0,0 +1,31 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* This module implements the Coercions transitive closure *) + +val close_coercion_graph: + CoercDb.coerc_carr -> CoercDb.coerc_carr -> UriManager.uri -> + (CoercDb.coerc_carr * CoercDb.coerc_carr * UriManager.uri * Cic.obj) list + diff --git a/helm/software/components/library/cicElim.ml b/helm/software/components/library/cicElim.ml new file mode 100644 index 000000000..fb3c0655c --- /dev/null +++ b/helm/software/components/library/cicElim.ml @@ -0,0 +1,421 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +exception Elim_failure of string Lazy.t +exception Can_t_eliminate + +let debug_print = fun _ -> () +(*let debug_print s = prerr_endline (Lazy.force s) *) + +let counter = ref ~-1 ;; + +let fresh_binder () = Cic.Name "matita_dummy" +(* + incr counter; + Cic.Name ("e" ^ string_of_int !counter) *) + + (** verifies if a given inductive type occurs in a term in target position *) +let rec recursive uri typeno = function + | Cic.Prod (_, _, target) -> recursive uri typeno target + | Cic.MutInd (uri', typeno', []) + | Cic.Appl (Cic.MutInd (uri', typeno', []) :: _) -> + UriManager.eq uri uri' && typeno = typeno' + | _ -> false + + (** given a list of constructor types, return true if at least one of them is + * recursive, false otherwise *) +let recursive_type uri typeno constructors = + let rec aux = function + | Cic.Prod (_, src, tgt) -> recursive uri typeno src || aux tgt + | _ -> false + in + List.exists (fun (_, ty) -> aux ty) constructors + +let unfold_appl = function + | Cic.Appl ((Cic.Appl args) :: tl) -> Cic.Appl (args @ tl) + | t -> t + +let rec split l n = + match (l,n) with + (l,0) -> ([], l) + | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) + | (_,_) -> assert false + + (** build elimination principle part related to a single constructor + * @param paramsno number of Prod to ignore in this constructor (i.e. number of + * inductive parameters) + * @param dependent true if we are in the dependent case (i.e. sort <> Prop) *) +let rec delta (uri, typeno) dependent paramsno consno t p args = + match t with + | Cic.MutInd (uri', typeno', []) when + UriManager.eq uri uri' && typeno = typeno' -> + if dependent then + (match args with + | [] -> assert false + | [arg] -> unfold_appl (Cic.Appl [p; arg]) + | _ -> unfold_appl (Cic.Appl [p; unfold_appl (Cic.Appl args)])) + else + p + | Cic.Appl (Cic.MutInd (uri', typeno', []) :: tl) when + UriManager.eq uri uri' && typeno = typeno' -> + let (lparams, rparams) = split tl paramsno in + if dependent then + (match args with + | [] -> assert false + | [arg] -> unfold_appl (Cic.Appl (p :: rparams @ [arg])) + | _ -> + unfold_appl (Cic.Appl (p :: + rparams @ [unfold_appl (Cic.Appl args)]))) + else (* non dependent *) + (match rparams with + | [] -> p + | _ -> Cic.Appl (p :: rparams)) + | Cic.Prod (binder, src, tgt) -> + if recursive uri typeno src then + let args = List.map (CicSubstitution.lift 2) args in + let phi = + let src = CicSubstitution.lift 1 src in + delta (uri, typeno) dependent paramsno consno src + (CicSubstitution.lift 1 p) [Cic.Rel 1] + in + let tgt = CicSubstitution.lift 1 tgt in + Cic.Prod (fresh_binder (), src, + Cic.Prod (Cic.Anonymous, phi, + delta (uri, typeno) dependent paramsno consno tgt + (CicSubstitution.lift 2 p) (args @ [Cic.Rel 2]))) + else (* non recursive *) + let args = List.map (CicSubstitution.lift 1) args in + Cic.Prod (fresh_binder (), src, + delta (uri, typeno) dependent paramsno consno tgt + (CicSubstitution.lift 1 p) (args @ [Cic.Rel 1])) + | _ -> assert false + +let rec strip_left_params consno leftno = function + | t when leftno = 0 -> t (* no need to lift, the term is (hopefully) closed *) + | Cic.Prod (_, _, tgt) (* when leftno > 0 *) -> + (* after stripping the parameters we lift of consno. consno is 1 based so, + * the first constructor will be lifted by 1 (for P), the second by 2 (1 + * for P and 1 for the 1st constructor), and so on *) + if leftno = 1 then + CicSubstitution.lift consno tgt + else + strip_left_params consno (leftno - 1) tgt + | _ -> assert false + +let delta (ury, typeno) dependent paramsno consno t p args = + let t = strip_left_params consno paramsno t in + delta (ury, typeno) dependent paramsno consno t p args + +let rec add_params binder indno ty eliminator = + if indno = 0 then + eliminator + else + match ty with + | Cic.Prod (name, src, tgt) -> + let name = + match name with + Cic.Name _ -> name + | Cic.Anonymous -> fresh_binder () + in + binder name src (add_params binder (indno - 1) tgt eliminator) + | _ -> assert false + +let rec mk_rels consno = function + | 0 -> [] + | n -> Cic.Rel (n+consno) :: mk_rels consno (n-1) + +let rec strip_pi = function + | Cic.Prod (_, _, tgt) -> strip_pi tgt + | t -> t + +let rec count_pi = function + | Cic.Prod (_, _, tgt) -> count_pi tgt + 1 + | t -> 0 + +let rec type_of_p sort dependent leftno indty = function + | Cic.Prod (n, src, tgt) when leftno = 0 -> + let n = + if dependent then + match n with + Cic.Name _ -> n + | Cic.Anonymous -> fresh_binder () + else + n + in + Cic.Prod (n, src, type_of_p sort dependent leftno indty tgt) + | Cic.Prod (_, _, tgt) -> type_of_p sort dependent (leftno - 1) indty tgt + | t -> + if dependent then + Cic.Prod (Cic.Anonymous, indty, Cic.Sort sort) + else + Cic.Sort sort + +let rec add_right_pi dependent strip liftno liftfrom rightno indty = function + | Cic.Prod (_, src, tgt) when strip = 0 -> + Cic.Prod (fresh_binder (), + CicSubstitution.lift_from liftfrom liftno src, + add_right_pi dependent strip liftno (liftfrom + 1) rightno indty tgt) + | Cic.Prod (_, _, tgt) -> + add_right_pi dependent (strip - 1) liftno liftfrom rightno indty tgt + | t -> + if dependent then + Cic.Prod (fresh_binder (), + CicSubstitution.lift_from (rightno + 1) liftno indty, + Cic.Appl (Cic.Rel (1 + liftno + rightno) :: mk_rels 0 (rightno + 1))) + else + Cic.Prod (Cic.Anonymous, + CicSubstitution.lift_from (rightno + 1) liftno indty, + if rightno = 0 then + Cic.Rel (1 + liftno + rightno) + else + Cic.Appl (Cic.Rel (1 + liftno + rightno) :: mk_rels 1 rightno)) + +let rec add_right_lambda dependent strip liftno liftfrom rightno indty case = +function + | Cic.Prod (_, src, tgt) when strip = 0 -> + Cic.Lambda (fresh_binder (), + CicSubstitution.lift_from liftfrom liftno src, + add_right_lambda dependent strip liftno (liftfrom + 1) rightno indty + case tgt) + | Cic.Prod (_, _, tgt) -> + add_right_lambda true (strip - 1) liftno liftfrom rightno indty + case tgt + | t -> + Cic.Lambda (fresh_binder (), + CicSubstitution.lift_from (rightno + 1) liftno indty, case) + +let rec branch (uri, typeno) insource paramsno t fix head args = + match t with + | Cic.MutInd (uri', typeno', []) when + UriManager.eq uri uri' && typeno = typeno' -> + if insource then + (match args with + | [arg] -> Cic.Appl (fix :: args) + | _ -> Cic.Appl (head :: [Cic.Appl args])) + else + (match args with + | [] -> head + | _ -> Cic.Appl (head :: args)) + | Cic.Appl (Cic.MutInd (uri', typeno', []) :: tl) when + UriManager.eq uri uri' && typeno = typeno' -> + if insource then + let (lparams, rparams) = split tl paramsno in + match args with + | [arg] -> Cic.Appl (fix :: rparams @ args) + | _ -> Cic.Appl (fix :: rparams @ [Cic.Appl args]) + else + (match args with + | [] -> head + | _ -> Cic.Appl (head :: args)) + | Cic.Prod (binder, src, tgt) -> + if recursive uri typeno src then + let args = List.map (CicSubstitution.lift 1) args in + let phi = + let fix = CicSubstitution.lift 1 fix in + let src = CicSubstitution.lift 1 src in + branch (uri, typeno) true paramsno src fix head [Cic.Rel 1] + in + Cic.Lambda (fresh_binder (), src, + branch (uri, typeno) insource paramsno tgt + (CicSubstitution.lift 1 fix) (CicSubstitution.lift 1 head) + (args @ [Cic.Rel 1; phi])) + else (* non recursive *) + let args = List.map (CicSubstitution.lift 1) args in + Cic.Lambda (fresh_binder (), src, + branch (uri, typeno) insource paramsno tgt + (CicSubstitution.lift 1 fix) (CicSubstitution.lift 1 head) + (args @ [Cic.Rel 1])) + | _ -> assert false + +let branch (uri, typeno) insource liftno paramsno t fix head args = + let t = strip_left_params liftno paramsno t in + branch (uri, typeno) insource paramsno t fix head args + +let elim_of ~sort uri typeno = + counter := ~-1; + let (obj, univ) = (CicEnvironment.get_obj CicUniv.empty_ugraph uri) in + match obj with + | Cic.InductiveDefinition (indTypes, params, leftno, _) -> + let (name, inductive, ty, constructors) = + try + List.nth indTypes typeno + with Failure _ -> assert false + in + let paramsno = count_pi ty in (* number of (left or right) parameters *) + let rightno = paramsno - leftno in + let dependent = (strip_pi ty <> Cic.Sort Cic.Prop) in + let head = + match strip_pi ty with + Cic.Sort s -> s + | _ -> assert false + in + let conslen = List.length constructors in + let consno = ref (conslen + 1) in + if + not + (CicTypeChecker.check_allowed_sort_elimination uri typeno head sort) + then + raise Can_t_eliminate; + let indty = + let indty = Cic.MutInd (uri, typeno, []) in + if paramsno = 0 then + indty + else + Cic.Appl (indty :: mk_rels 0 paramsno) + in + let mk_constructor consno = + let constructor = Cic.MutConstruct (uri, typeno, consno, []) in + if leftno = 0 then + constructor + else + Cic.Appl (constructor :: mk_rels consno leftno) + in + let p_ty = type_of_p sort dependent leftno indty ty in + let final_ty = + add_right_pi dependent leftno (conslen + 1) 1 rightno indty ty + in + let eliminator_type = + let cic = + Cic.Prod (Cic.Name "P", p_ty, + (List.fold_right + (fun (_, constructor) acc -> + decr consno; + let p = Cic.Rel !consno in + Cic.Prod (Cic.Anonymous, + (delta (uri, typeno) dependent leftno !consno + constructor p [mk_constructor !consno]), + acc)) + constructors final_ty)) + in + add_params (fun b s t -> Cic.Prod (b, s, t)) leftno ty cic + in + let consno = ref (conslen + 1) in + let eliminator_body = + let fix = Cic.Rel (rightno + 2) in + let is_recursive = recursive_type uri typeno constructors in + let recshift = if is_recursive then 1 else 0 in + let (_, branches) = + List.fold_right + (fun (_, ty) (shift, branches) -> + let head = Cic.Rel (rightno + shift + 1 + recshift) in + let b = + branch (uri, typeno) false + (rightno + conslen + 2 + recshift) leftno ty fix head [] + in + (shift + 1, b :: branches)) + constructors (1, []) + in + let shiftno = conslen + rightno + 2 + recshift in + let outtype = + if dependent then + Cic.Rel shiftno + else + let head = + if rightno = 0 then + CicSubstitution.lift 1 (Cic.Rel shiftno) + else + Cic.Appl + ((CicSubstitution.lift (rightno + 1) (Cic.Rel shiftno)) :: + mk_rels 1 rightno) + in + add_right_lambda true leftno shiftno 1 rightno indty head ty + in + let mutcase = + Cic.MutCase (uri, typeno, outtype, Cic.Rel 1, branches) + in + let body = + if is_recursive then + let fixfun = + add_right_lambda dependent leftno (conslen + 2) 1 rightno + indty mutcase ty + in + (* rightno is the decreasing argument, i.e. the argument of + * inductive type *) + Cic.Fix (0, ["f", rightno, final_ty, fixfun]) + else + add_right_lambda dependent leftno (conslen + 1) 1 rightno indty + mutcase ty + in + let cic = + Cic.Lambda (Cic.Name "P", p_ty, + (List.fold_right + (fun (_, constructor) acc -> + decr consno; + let p = Cic.Rel !consno in + Cic.Lambda (fresh_binder (), + (delta (uri, typeno) dependent leftno !consno + constructor p [mk_constructor !consno]), + acc)) + constructors body)) + in + add_params (fun b s t -> Cic.Lambda (b, s, t)) leftno ty cic + in +(* +debug_print (lazy (CicPp.ppterm eliminator_type)); +debug_print (lazy (CicPp.ppterm eliminator_body)); +*) + let eliminator_type = + FreshNamesGenerator.mk_fresh_names [] [] [] eliminator_type in + let eliminator_body = + FreshNamesGenerator.mk_fresh_names [] [] [] eliminator_body in +(* +debug_print (lazy (CicPp.ppterm eliminator_type)); +debug_print (lazy (CicPp.ppterm eliminator_body)); +*) + let (computed_type, ugraph) = + try + CicTypeChecker.type_of_aux' [] [] eliminator_body CicUniv.empty_ugraph + with CicTypeChecker.TypeCheckerFailure msg -> + raise (Elim_failure (lazy (sprintf + "type checker failure while type checking:\n%s\nerror:\n%s" + (CicPp.ppterm eliminator_body) (Lazy.force msg)))) + in + if not (fst (CicReduction.are_convertible [] + eliminator_type computed_type ugraph)) + then + raise (Failure (sprintf + "internal error: type mismatch on eliminator type\n%s\n%s" + (CicPp.ppterm eliminator_type) (CicPp.ppterm computed_type))); + let suffix = + match sort with + | Cic.Prop -> "_ind" + | Cic.Set -> "_rec" + | Cic.Type _ -> "_rect" + | _ -> assert false + in + let name = UriManager.name_of_uri uri ^ suffix in + let buri = UriManager.buri_of_uri uri in + let uri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in + let obj_attrs = [`Class (`Elim sort); `Generated] in + uri, + Cic.Constant (name, Some eliminator_body, eliminator_type, [], obj_attrs) + | _ -> + failwith (sprintf "not an inductive definition (%s)" + (UriManager.string_of_uri uri)) + diff --git a/helm/software/components/library/cicElim.mli b/helm/software/components/library/cicElim.mli new file mode 100644 index 000000000..f1f84c92e --- /dev/null +++ b/helm/software/components/library/cicElim.mli @@ -0,0 +1,41 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + + (** can't build the required elimination principle (e.g. elimination from Prop + * to Set *) +exception Can_t_eliminate + + (** internal error while generating elimination principle *) +exception Elim_failure of string Lazy.t + +(** @param sort target sort +* @param uri inductive type uri +* @param typeno inductive type number +* @raise Failure +* @raise Can_t_eliminate +* @return Cic constant corresponding to the required elimination principle +* and its uri +*) +val elim_of: sort:Cic.sort -> UriManager.uri -> int -> UriManager.uri * Cic.obj diff --git a/helm/software/components/library/cicRecord.ml b/helm/software/components/library/cicRecord.ml new file mode 100644 index 000000000..775292ccb --- /dev/null +++ b/helm/software/components/library/cicRecord.ml @@ -0,0 +1,88 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let rec_ty uri leftno = + let rec_ty = Cic.MutInd (uri,0,[]) in + if leftno = 0 then rec_ty else + Cic.Appl (rec_ty :: (CicUtil.mk_rels leftno 0)) + +let generate_one_proj uri params paramsno fields t i = + let mk_lambdas l start = + List.fold_right (fun (name,ty) acc -> + Cic.Lambda (Cic.Name name,ty,acc)) l start in + let recty = rec_ty uri paramsno in + let outtype = Cic.Lambda (Cic.Name "w'", CicSubstitution.lift 1 recty, t) in + (mk_lambdas params + (Cic.Lambda (Cic.Name "w", recty, + Cic.MutCase (uri,0,outtype, Cic.Rel 1, + [mk_lambdas fields (Cic.Rel i)])))) + +let projections_of uri field_names = + let buri = UriManager.buri_of_uri uri in + let obj,ugraph = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri in + match obj with + Cic.InductiveDefinition ([_,_,sort,[_,ty]],params,paramsno,_) -> + assert (params = []); (* general case not implemented *) + let leftparams,ty = + let rec aux = + function + 0,ty -> [],ty + | n,Cic.Prod (Cic.Name name,s,t) -> + let leftparams,ty = aux (n - 1,t) in + (name,s)::leftparams,ty + | _,_ -> assert false + in + aux (paramsno,ty) + in + let fields = + let rec aux = + function + Cic.MutInd _, [] + | Cic.Appl _, [] -> [] + | Cic.Prod (_,s,t), name::tl -> (name,s)::aux (t,tl) + | _,_ -> assert false + in + aux ((CicSubstitution.lift 1 ty),field_names) + in + let rec aux i = + function + Cic.MutInd _, [] + | Cic.Appl _, [] -> [] + | Cic.Prod (_,s,t), name::tl -> + let p = generate_one_proj uri leftparams paramsno fields s i in + let puri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in + (puri,name,p) :: + aux (i - 1) + (CicSubstitution.subst + (Cic.Appl + (Cic.Const (puri,[]) :: + CicUtil.mk_rels paramsno 2 @ [Cic.Rel 1]) + ) t, tl) + | _,_ -> assert false + in + aux (List.length fields) (CicSubstitution.lift 2 ty,field_names) + | _ -> assert false diff --git a/helm/software/components/library/cicRecord.mli b/helm/software/components/library/cicRecord.mli new file mode 100644 index 000000000..b966f317c --- /dev/null +++ b/helm/software/components/library/cicRecord.mli @@ -0,0 +1,28 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** projections_of [uri] returns uri * name * term *) +val projections_of: + UriManager.uri -> string list -> (UriManager.uri * string * Cic.term) list diff --git a/helm/software/components/library/coercDb.ml b/helm/software/components/library/coercDb.ml new file mode 100644 index 000000000..8e2c62f31 --- /dev/null +++ b/helm/software/components/library/coercDb.ml @@ -0,0 +1,96 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +type coerc_carr = Uri of UriManager.uri | Sort of Cic.sort | Term of Cic.term +exception EqCarrNotImplemented of string Lazy.t +exception EqCarrOnNonMetaClosed + +let db = ref [] + +let coerc_carr_of_term t = + try + Uri (CicUtil.uri_of_term t) + with Invalid_argument _ -> + match t with + | Cic.Sort s -> Sort s + | Cic.Appl ((Cic.Const (uri, _))::_) + | Cic.Appl ((Cic.MutInd (uri, _, _))::_) + | Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_) -> Uri uri + | t -> Term t +;; + +let name_of_carr = function + | Uri u -> UriManager.name_of_uri u + | Sort s -> CicPp.ppsort s + | Term (Cic.Appl ((Cic.Const (uri, _))::_)) + | Term (Cic.Appl ((Cic.MutInd (uri, _, _))::_)) + | Term (Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_)) -> + UriManager.name_of_uri uri + | Term t -> (* CicPp.ppterm t *) assert false + +let eq_carr src tgt = + match src, tgt with + | Uri src, Uri tgt -> UriManager.eq src tgt + | Sort (Cic.Type _), Sort (Cic.Type _) -> true + | Sort src, Sort tgt when src = tgt -> true + | Term t1, Term t2 -> + if CicUtil.is_meta_closed t1 && CicUtil.is_meta_closed t2 then + raise + (EqCarrNotImplemented + (lazy ("Unsupported carr for coercions: " ^ + CicPp.ppterm t1 ^ " or " ^ CicPp.ppterm t2))) + else raise EqCarrOnNonMetaClosed + | _, _ -> false + +let to_list () = + !db + +let add_coercion c = + db := c :: !db + +let remove_coercion p = + db := List.filter (fun u -> not(p u)) !db + +let find_coercion f = + List.map (fun (_,_,x) -> x) (List.filter (fun (s,t,_) -> f (s,t)) !db) + +let is_a_coercion u = + List.exists (fun (_,_,x) -> UriManager.eq x u) !db + +let get_carr uri = + try + let src, tgt, _ = List.find (fun (_,_,x) -> UriManager.eq x uri) !db in + src, tgt + with Not_found -> assert false (* uri must be a coercion *) + +let term_of_carr = function + | Uri u -> CicUtil.term_of_uri u + | Sort s -> Cic.Sort s + | Term _ -> assert false + + + diff --git a/helm/software/components/library/coercDb.mli b/helm/software/components/library/coercDb.mli new file mode 100644 index 000000000..9e8bf5e9c --- /dev/null +++ b/helm/software/components/library/coercDb.mli @@ -0,0 +1,58 @@ +(* 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/. + *) + + + (** THIS MODULE SHOULD BE USED ONLY BY CoercGraph/CicCoercion/librarySync + * + * and may be merged with CicCoercion... + * + * **) + + + (** XXX WARNING: non-reentrant *) +type coerc_carr = Uri of UriManager.uri | Sort of Cic.sort | Term of Cic.term +exception EqCarrNotImplemented of string Lazy.t +exception EqCarrOnNonMetaClosed +val eq_carr: coerc_carr -> coerc_carr -> bool +val coerc_carr_of_term: Cic.term -> coerc_carr +val name_of_carr: coerc_carr -> string + +val to_list: + unit -> + (coerc_carr * coerc_carr * UriManager.uri) list + +val add_coercion: + coerc_carr * coerc_carr * UriManager.uri -> unit + +val remove_coercion: + (coerc_carr * coerc_carr * UriManager.uri -> bool) -> unit + +val find_coercion: + (coerc_carr * coerc_carr -> bool) -> UriManager.uri list + +val is_a_coercion: UriManager.uri -> bool +val get_carr: UriManager.uri -> coerc_carr * coerc_carr + +val term_of_carr: coerc_carr -> Cic.term diff --git a/helm/software/components/library/coercGraph.ml b/helm/software/components/library/coercGraph.ml new file mode 100644 index 000000000..cd958a8f6 --- /dev/null +++ b/helm/software/components/library/coercGraph.ml @@ -0,0 +1,97 @@ +(* 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/. + *) + +(* $Id$ *) + +open Printf;; + +type coercion_search_result = + | SomeCoercion of Cic.term + | NoCoercion + | NotMetaClosed + | NotHandled of string Lazy.t + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) else () + +(* searches a coercion fron src to tgt in the !coercions list *) +let look_for_coercion src tgt = + try + let l = + CoercDb.find_coercion + (fun (s,t) -> CoercDb.eq_carr s src && CoercDb.eq_carr t tgt) + in + match l with + | [] -> + debug_print + (lazy + (sprintf ":-( coercion non trovata da %s a %s" + (CoercDb.name_of_carr src) + (CoercDb.name_of_carr tgt))); + NoCoercion + | [u] -> + debug_print (lazy ( + sprintf ":-) TROVATA 1 coercion da %s a %s: %s" + (CoercDb.name_of_carr src) + (CoercDb.name_of_carr tgt) + (UriManager.name_of_uri u))); + SomeCoercion (CicUtil.term_of_uri u) + | u::_ -> + debug_print (lazy ( + sprintf ":-/ TROVATE %d coercion(s) da %s a %s, prendo la prima: %s" + (List.length l) + (CoercDb.name_of_carr src) + (CoercDb.name_of_carr tgt) + (UriManager.name_of_uri u))); + SomeCoercion (CicUtil.term_of_uri u) + with + | CoercDb.EqCarrNotImplemented s -> NotHandled s + | CoercDb.EqCarrOnNonMetaClosed -> NotMetaClosed +;; + +let look_for_coercion src tgt = + let src_uri = CoercDb.coerc_carr_of_term src in + let tgt_uri = CoercDb.coerc_carr_of_term tgt in + look_for_coercion src_uri tgt_uri + +let is_a_coercion t = + try + let uri = CicUtil.uri_of_term t in + CoercDb.is_a_coercion uri + with Invalid_argument _ -> false + +let source_of t = + try + let uri = CicUtil.uri_of_term t in + CoercDb.term_of_carr (fst (CoercDb.get_carr uri)) + with Invalid_argument _ -> assert false (* t must be a coercion *) + +let target_of t = + try + let uri = CicUtil.uri_of_term t in + CoercDb.term_of_carr (snd (CoercDb.get_carr uri)) + with Invalid_argument _ -> assert false (* t must be a coercion *) + +(* EOF *) diff --git a/helm/software/components/library/coercGraph.mli b/helm/software/components/library/coercGraph.mli new file mode 100644 index 000000000..1923a964a --- /dev/null +++ b/helm/software/components/library/coercGraph.mli @@ -0,0 +1,40 @@ +(* 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/. + *) + +(* This module implements the Query interface to the Coercion Graph *) + +type coercion_search_result = + | SomeCoercion of Cic.term + | NoCoercion + | NotMetaClosed + | NotHandled of string Lazy.t + +val look_for_coercion : + Cic.term -> Cic.term -> coercion_search_result + +val is_a_coercion: Cic.term -> bool +val source_of: Cic.term -> Cic.term +val target_of: Cic.term -> Cic.term + diff --git a/helm/software/components/library/libraryClean.ml b/helm/software/components/library/libraryClean.ml new file mode 100644 index 000000000..6f72ff495 --- /dev/null +++ b/helm/software/components/library/libraryClean.ml @@ -0,0 +1,238 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let debug = false +let debug_prerr = if debug then prerr_endline else ignore + +module HGT = Http_getter_types;; +module HG = Http_getter;; +module UM = UriManager;; + +let cache_of_processed_baseuri = Hashtbl.create 1024 + +let one_step_depend suri = + let buri = + try + UM.buri_of_uri (UM.uri_of_string suri) + with UM.IllFormedUri _ -> suri + in + if Hashtbl.mem cache_of_processed_baseuri buri then + [] + else + begin + Hashtbl.add cache_of_processed_baseuri buri true; + let query = + let buri = buri ^ "/" in + let buri = HMysql.escape buri in + let obj_tbl = MetadataTypes.obj_tbl () in + sprintf + ("SELECT source, h_occurrence FROM %s WHERE " ^^ + "h_occurrence REGEXP '^%s[^/]*$'") + obj_tbl buri + in + try + let rc = HMysql.exec (LibraryDb.instance ()) query in + let l = ref [] in + HMysql.iter rc ( + fun row -> + match row.(0), row.(1) with + | Some uri, Some occ when Filename.dirname occ = buri -> + l := uri :: !l + | _ -> ()); + let l = List.sort Pervasives.compare !l in + HExtlib.list_uniq l + with + exn -> raise exn (* no errors should be accepted *) + end + +let safe_buri_of_suri suri = + try + UM.buri_of_uri (UM.uri_of_string suri) + with + UM.IllFormedUri _ -> suri + +let close_uri_list uri_to_remove = + (* to remove an uri you have to remove the whole script *) + let buri_to_remove = + HExtlib.list_uniq + (List.fast_sort Pervasives.compare + (List.map safe_buri_of_suri uri_to_remove)) + in + (* cleand the already visided baseuris *) + let buri_to_remove = + List.filter + (fun buri -> + if Hashtbl.mem cache_of_processed_baseuri buri then false + else true) + buri_to_remove + in + (* now calculate the list of objects that belong to these baseuris *) + let uri_to_remove = + try + List.fold_left + (fun acc buri -> + let inhabitants = HG.ls (buri ^ "/") in + let inhabitants = List.filter + (function HGT.Ls_object _ -> true | _ -> false) + inhabitants + in + let inhabitants = List.map + (function + | HGT.Ls_object e -> buri ^ "/" ^ e.HGT.uri + | _ -> assert false) + inhabitants + in + inhabitants @ acc) + [] buri_to_remove + with HGT.Invalid_URI u -> + HLog.error ("We were listing an invalid buri: " ^ u); + exit 1 + in + (* now we want the list of all uri that depend on them *) + let depend = + List.fold_left + (fun acc u -> one_step_depend u @ acc) [] uri_to_remove + in + let depend = + HExtlib.list_uniq (List.fast_sort Pervasives.compare depend) + in + uri_to_remove, depend + +let rec close_db uris next = + match next with + | [] -> uris + | l -> let uris, next = close_uri_list l in close_db uris next @ uris + +let cleaned_no = ref 0;; + + (** TODO repellent code ... *) +let moo_root_dir = lazy ( + let url = + List.assoc "cic:/matita/" + (List.map + (fun pair -> + match + Str.split (Str.regexp "[ \t\r\n]+") (HExtlib.trim_blanks pair) + with + | a::b::_ -> a, b + | _ -> assert false) + (Helm_registry.get_list Helm_registry.string "getter.prefix")) + in + String.sub url 7 (String.length url - 7) (* remove heading "file:///" *) +) + +let close_nodb ~basedir buris = + let rev_deps = Hashtbl.create 97 in + let all_metadata = + HExtlib.find ~test:(fun name -> Filename.check_suffix name ".metadata") + (Lazy.force moo_root_dir) + in + List.iter + (fun path -> + let metadata = LibraryNoDb.load_metadata ~fname:path in + let baseuri_of_current_metadata = + let dirname = Filename.dirname path in + let basedirlen = String.length basedir in + assert (String.sub dirname 0 basedirlen = basedir); + "cic:" ^ + String.sub dirname basedirlen (String.length dirname - basedirlen) ^ + Filename.basename path + in + let deps = + HExtlib.filter_map + (function LibraryNoDb.Dependency buri -> Some buri) + metadata + in + List.iter + (fun buri -> Hashtbl.add rev_deps buri baseuri_of_current_metadata) deps) + all_metadata; + let buris_to_remove = + HExtlib.list_uniq + (List.fast_sort Pervasives.compare + (List.flatten (List.map (Hashtbl.find_all rev_deps) buris))) + in + let objects_to_remove = + let objs_of_buri buri = + HExtlib.filter_map + (function + | Http_getter_types.Ls_object o -> + Some (buri ^ "/" ^ o.Http_getter_types.uri) + | _ -> None) + (Http_getter.ls buri) + in + List.flatten (List.map objs_of_buri (buris @ buris_to_remove)) + in + objects_to_remove + +let clean_baseuris ?(verbose=true) ~basedir buris = + Hashtbl.clear cache_of_processed_baseuri; + let buris = List.map Http_getter_misc.strip_trailing_slash buris in + debug_prerr "clean_baseuris called on:"; + if debug then + List.iter debug_prerr buris; + let l = + if Helm_registry.get_bool "db.nodb" then + close_nodb ~basedir buris + else + close_db [] buris + in + let l = HExtlib.list_uniq (List.fast_sort Pervasives.compare l) in + let l = List.map UriManager.uri_of_string l in + debug_prerr "clean_baseuri will remove:"; + if debug then + List.iter (fun u -> debug_prerr (UriManager.string_of_uri u)) l; + List.iter + (fun buri -> + HExtlib.safe_remove (LibraryMisc.obj_file_of_baseuri basedir buri); + HExtlib.safe_remove (LibraryMisc.metadata_file_of_baseuri basedir buri); + HExtlib.safe_remove (LibraryMisc.lexicon_file_of_baseuri basedir buri)) + (HExtlib.list_uniq (List.fast_sort Pervasives.compare + (List.map (UriManager.buri_of_uri) l))); + List.iter + (let last_baseuri = ref "" in + fun uri -> + let buri = UriManager.buri_of_uri uri in + if buri <> !last_baseuri then + begin + HLog.message ("Removing: " ^ buri ^ "/*"); + last_baseuri := buri + end; + LibrarySync.remove_obj uri + ) l; + cleaned_no := !cleaned_no + List.length l; + if !cleaned_no > 30 then + begin + cleaned_no := 0; + List.iter + (function table -> + ignore (HMysql.exec (LibraryDb.instance ()) ("OPTIMIZE TABLE " ^ table))) + [MetadataTypes.name_tbl (); MetadataTypes.rel_tbl (); + MetadataTypes.sort_tbl (); MetadataTypes.obj_tbl(); + MetadataTypes.count_tbl()] + end diff --git a/helm/software/components/library/libraryClean.mli b/helm/software/components/library/libraryClean.mli new file mode 100644 index 000000000..deca8f4a7 --- /dev/null +++ b/helm/software/components/library/libraryClean.mli @@ -0,0 +1,26 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val clean_baseuris : ?verbose:bool -> basedir:string -> string list -> unit diff --git a/helm/software/components/library/libraryDb.ml b/helm/software/components/library/libraryDb.ml new file mode 100644 index 000000000..8c11f591f --- /dev/null +++ b/helm/software/components/library/libraryDb.ml @@ -0,0 +1,167 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf ;; + +let instance = + let dbd = lazy ( + HMysql.quick_connect + ~host:(Helm_registry.get "db.host") + ~user:(Helm_registry.get "db.user") + ~database:(Helm_registry.get "db.database") + ()) + in + fun () -> Lazy.force dbd + + +let xpointer_RE = Pcre.regexp "#.*$" +let file_scheme_RE = Pcre.regexp "^file://" + +let clean_owner_environment () = + let dbd = instance () in + let obj_tbl = MetadataTypes.obj_tbl () in + let sort_tbl = MetadataTypes.sort_tbl () in + let rel_tbl = MetadataTypes.rel_tbl () in + let name_tbl = MetadataTypes.name_tbl () in + let count_tbl = MetadataTypes.count_tbl () in + let tbls = [ + (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; + (name_tbl,`ObjectName) ; (count_tbl,`Count) ] + in + let statements = + (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls) + in + let owned_uris = + try + MetadataDb.clean ~dbd + with Mysql.Error _ as exn -> + match HMysql.errno dbd with + | Mysql.No_such_table -> [] + | _ -> raise exn + in + List.iter + (fun uri -> + let uri = Pcre.replace ~rex:xpointer_RE ~templ:"" uri in + List.iter + (fun suffix -> + try + HExtlib.safe_remove (Http_getter.resolve (uri ^ suffix)) + with Http_getter_types.Key_not_found _ -> ()) + [""; ".body"; ".types"]) + owned_uris; + List.iter (fun statement -> + try + ignore (HMysql.exec dbd statement) + with Mysql.Error _ as exn -> + match HMysql.errno dbd with + | Mysql.Bad_table_error + | Mysql.No_such_index | Mysql.No_such_table -> () + | _ -> raise exn + ) statements; +;; + +let create_owner_environment () = + let dbd = instance () in + let obj_tbl = MetadataTypes.obj_tbl () in + let sort_tbl = MetadataTypes.sort_tbl () in + let rel_tbl = MetadataTypes.rel_tbl () in + let name_tbl = MetadataTypes.name_tbl () in + let count_tbl = MetadataTypes.count_tbl () in + let tbls = [ + (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; + (name_tbl,`ObjectName) ; (count_tbl,`Count) ] + in + let statements = + (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls) + in + List.iter (fun statement -> + try + ignore (HMysql.exec dbd statement) + with + exn -> + let status = HMysql.status dbd in + match status with + | Mysql.StatusError Mysql.Table_exists_error -> () + | Mysql.StatusError Mysql.Dup_keyname -> () + | Mysql.StatusError _ -> raise exn + | _ -> () + ) statements +;; + +(* removes uri from the ownerized tables, and returns the list of other objects + * (theyr uris) that ref the one removed. + * AFAIK there is no need to return it, since the MatitaTypes.staus should + * contain all defined objects. but to double check we do not garbage the + * metadata... + *) +let remove_uri uri = + let obj_tbl = MetadataTypes.obj_tbl () in + let sort_tbl = MetadataTypes.sort_tbl () in + let rel_tbl = MetadataTypes.rel_tbl () in + let name_tbl = MetadataTypes.name_tbl () in + (*let conclno_tbl = MetadataTypes.conclno_tbl () in + let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in*) + let count_tbl = MetadataTypes.count_tbl () in + + let dbd = instance () in + let suri = UriManager.string_of_uri uri in + let query table suri = sprintf + "DELETE FROM %s WHERE source LIKE '%s%%'" table (HMysql.escape suri) + in + List.iter (fun t -> + try + ignore (HMysql.exec dbd (query t suri)) + with + exn -> raise exn (* no errors should be accepted *) + ) + [obj_tbl;sort_tbl;rel_tbl;name_tbl;(*conclno_tbl;conclno_hyp_tbl*)count_tbl]; + (* and now the debug job *) + let dbg_q = + sprintf "SELECT source FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl + (HMysql.escape suri) + in + try + let rc = HMysql.exec dbd dbg_q in + let l = ref [] in + HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); + let l = List.sort Pervasives.compare !l in + HExtlib.list_uniq l + with + exn -> raise exn (* no errors should be accepted *) + +let xpointers_of_ind uri = + let dbd = instance () in + let name_tbl = MetadataTypes.name_tbl () in + let query = sprintf + "SELECT source FROM %s WHERE source LIKE '%s#xpointer%%'" name_tbl + (HMysql.escape (UriManager.string_of_uri uri)) + in + let rc = HMysql.exec dbd query in + let l = ref [] in + HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); + List.map UriManager.uri_of_string !l + diff --git a/helm/software/components/library/libraryDb.mli b/helm/software/components/library/libraryDb.mli new file mode 100644 index 000000000..39aa7c079 --- /dev/null +++ b/helm/software/components/library/libraryDb.mli @@ -0,0 +1,34 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val instance: unit -> HMysql.dbd + +val create_owner_environment: unit -> unit +val clean_owner_environment: unit -> unit + +(* returns a list of uri thet must be removed sice they reference uri, + * but this is used only for debugging purposes *) +val remove_uri: UriManager.uri -> string list +val xpointers_of_ind: UriManager.uri -> UriManager.uri list diff --git a/helm/software/components/library/libraryMisc.ml b/helm/software/components/library/libraryMisc.ml new file mode 100644 index 000000000..3f1931e42 --- /dev/null +++ b/helm/software/components/library/libraryMisc.ml @@ -0,0 +1,38 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let obj_file_of_baseuri ~basedir ~baseuri = + let path = basedir ^ "/xml" ^ Pcre.replace ~pat:"^cic:" ~templ:"" baseuri in + path ^ ".moo" + +let lexicon_file_of_baseuri ~basedir ~baseuri = + let path = basedir ^ "/xml" ^ Pcre.replace ~pat:"^cic:" ~templ:"" baseuri in + path ^ ".lexicon" + +let metadata_file_of_baseuri ~basedir ~baseuri = + let path = basedir ^ "/xml" ^ Pcre.replace ~pat:"^cic:" ~templ:"" baseuri in + path ^ ".metadata" diff --git a/helm/software/components/library/libraryMisc.mli b/helm/software/components/library/libraryMisc.mli new file mode 100644 index 000000000..e4d07faf7 --- /dev/null +++ b/helm/software/components/library/libraryMisc.mli @@ -0,0 +1,28 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val obj_file_of_baseuri: basedir:string -> baseuri:string -> string +val lexicon_file_of_baseuri: basedir:string -> baseuri:string -> string +val metadata_file_of_baseuri: basedir:string -> baseuri:string -> string diff --git a/helm/software/components/library/libraryNoDb.ml b/helm/software/components/library/libraryNoDb.ml new file mode 100644 index 000000000..9ac42a5ea --- /dev/null +++ b/helm/software/components/library/libraryNoDb.ml @@ -0,0 +1,51 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +exception Checksum_failure of string +exception Corrupt_metadata of string +exception Version_mismatch of string + +let magic = 1 +let format_name = "metadata" + +type metadata = + | Dependency of string (* baseuri without trailing slash *) + +let eq_metadata (m1:metadata) (m2:metadata) = m1 = m2 + +let save_metadata_to_file ~fname metadata = + HMarshal.save ~fmt:format_name ~version:magic ~fname metadata + +let load_metadata_from_file ~fname = + let raw = HMarshal.load ~fmt:format_name ~version:magic ~fname in + (raw: metadata list) + +let save_metadata ~fname metadata = save_metadata_to_file ~fname metadata +let load_metadata ~fname = load_metadata_from_file ~fname + diff --git a/helm/software/components/library/libraryNoDb.mli b/helm/software/components/library/libraryNoDb.mli new file mode 100644 index 000000000..1521f456f --- /dev/null +++ b/helm/software/components/library/libraryNoDb.mli @@ -0,0 +1,35 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* TODO the strings below should be UriManager.uri, but UriManager ATM does not + * support their format *) +type metadata = + | Dependency of string (* baseuri without trailing slash *) + +val eq_metadata: metadata -> metadata -> bool + +val save_metadata: fname:string -> metadata list -> unit +val load_metadata: fname:string -> metadata list + diff --git a/helm/software/components/library/librarySync.ml b/helm/software/components/library/librarySync.ml new file mode 100644 index 000000000..7363697d5 --- /dev/null +++ b/helm/software/components/library/librarySync.ml @@ -0,0 +1,427 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception AlreadyDefined of UriManager.uri + +let auxiliary_lemmas_hashtbl = UriManager.UriHashtbl.create 29 + +(* uri |--> (derived_coercions_in_the_coercion_DB, derived_coercions_in_lib) + * + * in case of remove_coercion uri, the first component is removed from the + * coercion DB, while the second is passed to remove_obj (and is not [] only if + * add_coercion is called with add_composites + * *) +let coercion_hashtbl = UriManager.UriHashtbl.create 3 + +let rec merge_coercions = + let module C = Cic in + let aux = (fun (u,t) -> u,merge_coercions t) in + function + C.Rel _ | C.Sort _ | C.Implicit _ as t -> t + | C.Meta (n,subst) -> + let subst' = + List.map + (function None -> None | Some t -> Some (merge_coercions t)) subst + in + C.Meta (n,subst') + | C.Cast (te,ty) -> C.Cast (merge_coercions te, merge_coercions ty) + | C.Prod (name,so,dest) -> + C.Prod (name, merge_coercions so, merge_coercions dest) + | C.Lambda (name,so,dest) -> + C.Lambda (name, merge_coercions so, merge_coercions dest) + | C.LetIn (name,so,dest) -> + C.LetIn (name, merge_coercions so, merge_coercions dest) + | Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ] when + CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 -> + let source_carr = CoercGraph.source_of c2 in + let tgt_carr = CoercGraph.target_of c1 in + (match CoercGraph.look_for_coercion source_carr tgt_carr + with + | CoercGraph.SomeCoercion c -> Cic.Appl [ c ; head ] + | _ -> assert false) (* the composite coercion must exist *) + | C.Appl l -> C.Appl (List.map merge_coercions l) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst = List.map aux exp_named_subst in + C.Var (uri, exp_named_subst) + | C.Const (uri,exp_named_subst) -> + let exp_named_subst = List.map aux exp_named_subst in + C.Const (uri, exp_named_subst) + | C.MutInd (uri,tyno,exp_named_subst) -> + let exp_named_subst = List.map aux 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 aux exp_named_subst in + C.MutConstruct (uri,tyno,consno,exp_named_subst) + | C.MutCase (uri,tyno,out,te,pl) -> + let pl = List.map merge_coercions pl in + C.MutCase (uri,tyno,merge_coercions out,merge_coercions te,pl) + | C.Fix (fno, fl) -> + let fl = List.map (fun (name,idx,ty,bo)->(name,idx,merge_coercions ty,merge_coercions bo)) fl in + C.Fix (fno, fl) + | C.CoFix (fno, fl) -> + let fl = List.map (fun (name,ty,bo) -> (name, merge_coercions ty, merge_coercions bo)) fl in + C.CoFix (fno, fl) + +let merge_coercions_in_obj obj = + let module C = Cic in + match obj with + | C.Constant (id, body, ty, params, attrs) -> + let body = + match body with + | None -> None + | Some body -> Some (merge_coercions body) + in + let ty = merge_coercions ty in + C.Constant (id, body, ty, params, attrs) + | C.Variable (name, body, ty, params, attrs) -> + let body = + match body with + | None -> None + | Some body -> Some (merge_coercions body) + in + let ty = merge_coercions ty in + C.Variable (name, body, ty, params, attrs) + | C.CurrentProof (_name, _conjectures, _body, _ty, _params, _attrs) -> + assert false + | C.InductiveDefinition (indtys, params, leftno, attrs) -> + let indtys = + List.map + (fun (name, ind, arity, cl) -> + let arity = merge_coercions arity in + let cl = List.map (fun (name, ty) -> (name,merge_coercions ty)) cl in + (name, ind, arity, cl)) + indtys + in + C.InductiveDefinition (indtys, params, leftno, attrs) + +let uris_of_obj uri = + let innertypesuri = UriManager.innertypesuri_of_uri uri in + let bodyuri = UriManager.bodyuri_of_uri uri in + let univgraphuri = UriManager.univgraphuri_of_uri uri in + innertypesuri,bodyuri,univgraphuri + +let paths_and_uris_of_obj uri ~basedir = + let basedir = basedir ^ "/xml" in + let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in + let innertypesfilename = Str.replace_first (Str.regexp "^cic:") "" + (UriManager.string_of_uri innertypesuri) ^ ".xml.gz" in + let innertypespath = basedir ^ "/" ^ innertypesfilename in + let xmlfilename = Str.replace_first (Str.regexp "^cic:/") "" + (UriManager.string_of_uri uri) ^ ".xml.gz" in + let xmlpath = basedir ^ "/" ^ xmlfilename in + let xmlbodyfilename = Str.replace_first (Str.regexp "^cic:/") "" + (UriManager.string_of_uri uri) ^ ".body.xml.gz" in + let xmlbodypath = basedir ^ "/" ^ xmlbodyfilename in + let xmlunivgraphfilename = Str.replace_first (Str.regexp "^cic:/") "" + (UriManager.string_of_uri univgraphuri) ^ ".xml.gz" in + let xmlunivgraphpath = basedir ^ "/" ^ xmlunivgraphfilename in + xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri, + xmlunivgraphpath, univgraphuri + +let save_object_to_disk ~basedir uri obj ugraph univlist = + let ensure_path_exists path = + let dir = Filename.dirname path in + HExtlib.mkdir dir + in + (* generate annobj, ids_to_inner_sorts and ids_to_inner_types *) + let annobj = Cic2acic.plain_acic_object_of_cic_object obj in + (* prepare XML *) + let xml, bodyxml = + Cic2Xml.print_object + uri ?ids_to_inner_sorts:None ~ask_dtd_to_the_getter:false annobj + in + let xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri, + xmlunivgraphpath, univgraphuri = + paths_and_uris_of_obj uri basedir + in + List.iter HExtlib.mkdir (List.map Filename.dirname [xmlpath]); + (* now write to disk *) + ensure_path_exists xmlpath; + Xml.pp ~gzip:true xml (Some xmlpath); + CicUniv.write_xml_of_ugraph xmlunivgraphpath ugraph univlist; + (* we return a list of uri,path we registered/created *) + (uri,xmlpath) :: + (univgraphuri,xmlunivgraphpath) :: + (* now the optional body, both write and register *) + (match bodyxml,bodyuri with + None,None -> [] + | Some bodyxml,Some bodyuri-> + ensure_path_exists xmlbodypath; + Xml.pp ~gzip:true bodyxml (Some xmlbodypath); + [bodyuri, xmlbodypath] + | _-> assert false) + + +let typecheck_obj = + let profiler = HExtlib.profile "add_obj.typecheck_obj" in + fun uri obj -> profiler.HExtlib.profile (CicTypeChecker.typecheck_obj uri) obj + +let index_obj = + let profiler = HExtlib.profile "add_obj.index_obj" in + fun ~dbd ~uri -> + profiler.HExtlib.profile (fun uri -> MetadataDb.index_obj ~dbd ~uri) uri + +let add_single_obj uri obj ~basedir = + let obj = + if (*List.mem `Generated (CicUtil.attributes_of_obj obj) &&*) + not (CoercGraph.is_a_coercion (Cic.Const (uri, []))) + then + merge_coercions_in_obj obj + else + obj + in + let dbd = LibraryDb.instance () in + if CicEnvironment.in_library uri then + raise (AlreadyDefined uri) + else begin + (*CicUniv.reset_spent_time (); + let before = Unix.gettimeofday () in*) + typecheck_obj uri obj; (* 1 *) + (*let after = Unix.gettimeofday () in + let univ_time = CicUniv.get_spent_time () in + let total_time = after -. before in + prerr_endline + (Printf.sprintf "QED: %%univ = %2.5f, total = %2.5f, univ = %2.5f, %s\n" + (univ_time *. 100. /. total_time) (total_time) (univ_time) + (UriManager.name_of_uri uri));*) + let _, ugraph, univlist = + CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph uri in + try + index_obj ~dbd ~uri; (* 2 must be in the env *) + try + (*3*) + let new_stuff = save_object_to_disk ~basedir uri obj ugraph univlist in + try + HLog.message + (Printf.sprintf "%s defined" (UriManager.string_of_uri uri)) + with exc -> + List.iter HExtlib.safe_remove (List.map snd new_stuff); (* -3 *) + raise exc + with exc -> + ignore(LibraryDb.remove_uri uri); (* -2 *) + raise exc + with exc -> + CicEnvironment.remove_obj uri; (* -1 *) + raise exc + end + +let remove_single_obj uri = + let derived_uris_of_uri uri = + let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in + innertypesuri::univgraphuri::(match bodyuri with None -> [] | Some u -> [u]) + in + let to_remove = + uri :: + (if UriManager.uri_is_ind uri then LibraryDb.xpointers_of_ind uri else []) @ + derived_uris_of_uri uri + in + List.iter + (fun uri -> + (try + let file = Http_getter.resolve' uri in + HExtlib.safe_remove file; + HExtlib.rmdir_descend (Filename.dirname file) + with Http_getter_types.Key_not_found _ -> ()); + ignore (LibraryDb.remove_uri uri); + (*CoercGraph.remove_coercion uri;*) + CicEnvironment.remove_obj uri) + to_remove + +(*** GENERATION OF AUXILIARY LEMMAS ***) + +let generate_elimination_principles ~basedir uri = + let uris = ref [] in + let elim sort = + try + let uri,obj = CicElim.elim_of ~sort uri 0 in + add_single_obj uri obj ~basedir; + uris := uri :: !uris + with CicElim.Can_t_eliminate -> () + in + try + List.iter elim [ Cic.Prop; Cic.Set; (Cic.Type (CicUniv.fresh ())) ]; + !uris + with exn -> + List.iter remove_single_obj !uris; + raise exn + +(* COERCIONS ***********************************************************) + +let remove_all_coercions () = + UriManager.UriHashtbl.clear coercion_hashtbl; + CoercDb.remove_coercion (fun (_,_,u1) -> true) + +let add_coercion ~basedir ~add_composites uri = + let coer_ty,_ = + let coer = CicUtil.term_of_uri uri in + CicTypeChecker.type_of_aux' [] [] coer CicUniv.empty_ugraph + in + (* we have to get the source and the tgt type uri + * in Coq syntax we have already their names, but + * since we don't support Funclass and similar I think + * all the coercion should be of the form + * (A:?)(B:?)T1->T2 + * So we should be able to extract them from the coercion type + * + * Currently only (_:T1)T2 is supported. + * should we saturate it with metas in case we insert it? + * + *) + let extract_last_two_p ty = + let rec aux = function + | Cic.Prod( _, src, Cic.Prod (n,t1,t2)) -> + assert false + (* not implemented: aux (Cic.Prod(n,t1,t2)) *) + | Cic.Prod( _, src, tgt) -> src, tgt + | _ -> assert false + in + aux ty + in + let ty_src, ty_tgt = extract_last_two_p coer_ty in + let src_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_src) in + let tgt_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_tgt) in + let new_coercions = CicCoercion.close_coercion_graph src_uri tgt_uri uri in + let composite_uris = List.map (fun (_,_,uri,_) -> uri) new_coercions in + (* update the DB *) + List.iter + (fun (src,tgt,uri,_) -> CoercDb.add_coercion (src,tgt,uri)) + new_coercions; + CoercDb.add_coercion (src_uri, tgt_uri, uri); + (* add the composites obj and they eventual lemmas *) + let lemmas = + if add_composites then + List.fold_left + (fun acc (_,_,uri,obj) -> + add_single_obj ~basedir uri obj; + uri::acc) + composite_uris new_coercions + else + [] + in + (* store that composite_uris are related to uri. the first component is the + * stuff in the DB while the second is stuff for remove_obj *) + prerr_endline ("aggiungo: " ^ string_of_bool add_composites ^ UriManager.string_of_uri uri); + List.iter (fun u -> prerr_endline (UriManager.string_of_uri u)) + composite_uris; + UriManager.UriHashtbl.add coercion_hashtbl uri + (composite_uris,if add_composites then composite_uris else []); + lemmas + +let remove_coercion uri = + try + let (composites_in_db, composites_in_lib) = + UriManager.UriHashtbl.find coercion_hashtbl uri + in + prerr_endline ("removing: " ^UriManager.string_of_uri uri); + List.iter (fun u -> prerr_endline (UriManager.string_of_uri u)) + composites_in_db; + UriManager.UriHashtbl.remove coercion_hashtbl uri; + CoercDb.remove_coercion (fun (_,_,u) -> UriManager.eq uri u); + (* remove from the DB *) + List.iter + (fun u -> CoercDb.remove_coercion (fun (_,_,u1) -> UriManager.eq u u1)) + composites_in_db; + (* remove composites from the lib *) + List.iter remove_single_obj composites_in_lib + with + Not_found -> () (* mhh..... *) + + +let generate_projections ~basedir uri fields = + let uris = ref [] in + let projections = CicRecord.projections_of uri (List.map fst fields) in + try + List.iter2 + (fun (uri, name, bo) (_name, coercion) -> + try + let ty, ugraph = + CicTypeChecker.type_of_aux' [] [] bo CicUniv.empty_ugraph in + let attrs = [`Class `Projection; `Generated] in + let obj = Cic.Constant (name,Some bo,ty,[],attrs) in + add_single_obj ~basedir uri obj; + let composites = + if coercion then + add_coercion ~basedir ~add_composites:true uri + else + [] + in + uris := uri :: composites @ !uris + with + CicTypeChecker.TypeCheckerFailure s -> + HLog.message + ("Unable to create projection " ^ name ^ " cause: " ^ Lazy.force s); + | CicEnvironment.Object_not_found uri -> + let depend = UriManager.name_of_uri uri in + HLog.message + ("Unable to create projection " ^ name ^ " because it requires " ^ + depend) + ) projections fields; + !uris + with exn -> + List.iter remove_single_obj !uris; + raise exn + + +let add_obj uri obj ~basedir = + add_single_obj uri obj ~basedir; + let uris = ref [] in + try + begin + match obj with + | Cic.Constant _ -> () + | Cic.InductiveDefinition (_,_,_,attrs) -> + uris := !uris @ generate_elimination_principles ~basedir uri; + let rec get_record_attrs = + function + | [] -> None + | (`Class (`Record fields))::_ -> Some fields + | _::tl -> get_record_attrs tl + in + (match get_record_attrs attrs with + | None -> () (* not a record *) + | Some fields -> + uris := !uris @ (generate_projections ~basedir uri fields)) + | Cic.CurrentProof _ + | Cic.Variable _ -> assert false + end; + UriManager.UriHashtbl.add auxiliary_lemmas_hashtbl uri !uris; + !uris + with exn -> + List.iter remove_single_obj !uris; + raise exn + +let remove_obj uri = + let uris = + try + let res = UriManager.UriHashtbl.find auxiliary_lemmas_hashtbl uri in + UriManager.UriHashtbl.remove auxiliary_lemmas_hashtbl uri; + res + with + Not_found -> [] (*assert false*) + in + List.iter remove_single_obj (uri::uris) + diff --git a/helm/software/components/library/librarySync.mli b/helm/software/components/library/librarySync.mli new file mode 100644 index 000000000..d063b3282 --- /dev/null +++ b/helm/software/components/library/librarySync.mli @@ -0,0 +1,54 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +exception AlreadyDefined of UriManager.uri + +val merge_coercions: Cic.term -> Cic.term + +(* adds an object to the library together with all auxiliary lemmas on it *) +(* (e.g. elimination principles, projections, etc.) *) +(* it returns the list of the uris of the auxiliary lemmas generated *) +val add_obj: UriManager.uri -> Cic.obj -> basedir:string -> UriManager.uri list + +(* inverse of add_obj; *) +(* Warning: it does not remove the dependencies on the object and on its *) +(* auxiliary lemmas! *) +val remove_obj: UriManager.uri -> unit + +(* Informs the library that [uri] is a coercion. *) +(* This can generate some composite coercions that, if [add_composites] *) +(* is true are added to the library. *) +(* The list of added objects is returned. *) +val add_coercion: + basedir:string -> add_composites:bool -> UriManager.uri -> + UriManager.uri list + +(* inverse of add_coercion, removes both the eventually created composite *) +(* coercions and the information that [uri] and the composites are coercion *) +val remove_coercion: UriManager.uri -> unit + +(* mh... *) +val remove_all_coercions: unit -> unit + diff --git a/helm/software/components/license b/helm/software/components/license new file mode 100644 index 000000000..c67e1fc29 --- /dev/null +++ b/helm/software/components/license @@ -0,0 +1,25 @@ +(* Copyright (C) 2006, 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://helm.cs.unibo.it/ + *) + diff --git a/helm/software/components/logger/.depend b/helm/software/components/logger/.depend new file mode 100644 index 000000000..28268d29e --- /dev/null +++ b/helm/software/components/logger/.depend @@ -0,0 +1,2 @@ +helmLogger.cmo: helmLogger.cmi +helmLogger.cmx: helmLogger.cmi diff --git a/helm/software/components/logger/Makefile b/helm/software/components/logger/Makefile new file mode 100644 index 000000000..39d690084 --- /dev/null +++ b/helm/software/components/logger/Makefile @@ -0,0 +1,10 @@ + +PACKAGE = logger +INTERFACE_FILES = \ + helmLogger.mli +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common + diff --git a/helm/software/components/logger/helmLogger.ml b/helm/software/components/logger/helmLogger.ml new file mode 100644 index 000000000..c41674754 --- /dev/null +++ b/helm/software/components/logger/helmLogger.ml @@ -0,0 +1,62 @@ +(* $Id$ *) + +open Printf + +(* HTML simulator (first in its kind) *) + +type html_tag = + [ `T of string + | `L of html_tag list + | `BR + | `DIV of int * string option * html_tag + ] + +type html_msg = [ `Error of html_tag | `Msg of html_tag ] + +type logger_fun = ?append_NL:bool -> html_msg -> unit + +let rec string_of_html_tag = + let rec aux indent = + let indent_str = String.make indent ' ' in + function + | `T s -> s + | `L msgs -> + String.concat ("\n" ^ indent_str) (List.map (aux indent) msgs) + | `BR -> "\n" ^ indent_str + | `DIV (local_indent, _, tag) -> + "\n" ^ indent_str ^ aux (indent + local_indent) tag + in + aux 0 + +let string_of_html_msg = function + | `Error tag -> "Error: " ^ string_of_html_tag tag + | `Msg tag -> string_of_html_tag tag + +let rec html_of_html_tag = function + | `T s -> s + | `L msgs -> + sprintf "
      \n%s\n
    " + (String.concat "\n" + (List.map + (fun msg -> sprintf "
  • %s
    • " (html_of_html_tag msg)) + msgs)) + | `BR -> "
    \n" + | `DIV (indent, color, tag) -> + sprintf "
    \n%s\n
    " + (match color with None -> "" | Some color -> "color: " ^ color ^ "; ") + (float_of_int indent *. 0.5) + (html_of_html_tag tag) + +let html_of_html_msg = + function + | `Error tag -> "Error: " ^ html_of_html_tag tag ^ "" + | `Msg tag -> html_of_html_tag tag + +let log_callbacks = ref [] + +let register_log_callback logger_fun = + log_callbacks := !log_callbacks @ [ logger_fun ] + +let log ?append_NL html_msg = + List.iter (fun logger_fun -> logger_fun ?append_NL html_msg) !log_callbacks + diff --git a/helm/software/components/logger/helmLogger.mli b/helm/software/components/logger/helmLogger.mli new file mode 100644 index 000000000..633b5c3ec --- /dev/null +++ b/helm/software/components/logger/helmLogger.mli @@ -0,0 +1,27 @@ + +type html_tag = + [ `BR + | `L of html_tag list + | `T of string + | `DIV of int * string option * html_tag (* indentation, color, tag *) + ] +type html_msg = [ `Error of html_tag | `Msg of html_tag ] + + (** html_msg to plain text converter *) +val string_of_html_msg: html_msg -> string + + (** html_tag to plain text converter *) +val string_of_html_tag: html_tag -> string + + (** html_msg to html text converter *) +val html_of_html_msg: html_msg -> string + + (** html_tag to html text converter *) +val html_of_html_tag: html_tag -> string + +type logger_fun = ?append_NL:bool -> html_msg -> unit + +val register_log_callback: logger_fun -> unit + +val log: logger_fun + diff --git a/helm/software/components/metadata/.depend b/helm/software/components/metadata/.depend new file mode 100644 index 000000000..04197957b --- /dev/null +++ b/helm/software/components/metadata/.depend @@ -0,0 +1,20 @@ +metadataExtractor.cmi: metadataTypes.cmi +metadataPp.cmi: metadataTypes.cmi +metadataConstraints.cmi: metadataTypes.cmi +metadataDb.cmi: metadataTypes.cmi +sqlStatements.cmo: sqlStatements.cmi +sqlStatements.cmx: sqlStatements.cmi +metadataTypes.cmo: metadataTypes.cmi +metadataTypes.cmx: metadataTypes.cmi +metadataExtractor.cmo: metadataTypes.cmi metadataExtractor.cmi +metadataExtractor.cmx: metadataTypes.cmx metadataExtractor.cmi +metadataPp.cmo: metadataTypes.cmi metadataPp.cmi +metadataPp.cmx: metadataTypes.cmx metadataPp.cmi +metadataConstraints.cmo: metadataTypes.cmi metadataPp.cmi \ + metadataConstraints.cmi +metadataConstraints.cmx: metadataTypes.cmx metadataPp.cmx \ + metadataConstraints.cmi +metadataDb.cmo: metadataTypes.cmi metadataPp.cmi metadataExtractor.cmi \ + metadataConstraints.cmi metadataDb.cmi +metadataDb.cmx: metadataTypes.cmx metadataPp.cmx metadataExtractor.cmx \ + metadataConstraints.cmx metadataDb.cmi diff --git a/helm/software/components/metadata/Makefile b/helm/software/components/metadata/Makefile new file mode 100644 index 000000000..d02d021a5 --- /dev/null +++ b/helm/software/components/metadata/Makefile @@ -0,0 +1,40 @@ +PACKAGE = metadata +PREDICATES = + +INTERFACE_FILES = \ + sqlStatements.mli \ + metadataTypes.mli \ + metadataExtractor.mli \ + metadataPp.mli \ + metadataConstraints.mli \ + metadataDb.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common + +all: all_table_creator all_extractor +opt: opt_table_creator opt_extractor + +all_table_creator: + @make -C table_creator/ all +opt_table_creator: + @make -C table_creator/ opt + +all_extractor: + @make -C extractor/ all +opt_extractor: + @make -C extractor/ opt + +clean: clean_table_creator clean_extractor + +clean_table_creator: + @echo " cleaning: table_creator" + @make -C table_creator/ clean + +clean_extractor: + @echo " cleaning: extractor" + @make -C extractor/ clean + diff --git a/helm/software/components/metadata/dump_db/dump.sh b/helm/software/components/metadata/dump_db/dump.sh new file mode 100755 index 000000000..e7b43666e --- /dev/null +++ b/helm/software/components/metadata/dump_db/dump.sh @@ -0,0 +1,20 @@ +ALL_TABLES=`../table_creator/table_creator list all` + +if [ -z "$1" ]; then + echo "Dumps to stdout some tables of a given db on mowgli." + echo "If no tables are given the dump will contain:" + echo " $ALL_TABLES" + echo "" + echo "usage: dump.sh dbname [tables...]" + echo "" + exit 1 +fi +DB=$1 +shift +if [ -z "$1" ]; then + TABLES=$ALL_TABLES +else + TABLES=$@ +fi + +mysqldump -e --add-drop-table -u helm -h mowgli.cs.unibo.it $DB $TABLES diff --git a/helm/software/components/metadata/extractor/.depend b/helm/software/components/metadata/extractor/.depend new file mode 100644 index 000000000..e69de29bb diff --git a/helm/software/components/metadata/extractor/Makefile b/helm/software/components/metadata/extractor/Makefile new file mode 100644 index 000000000..579a5655f --- /dev/null +++ b/helm/software/components/metadata/extractor/Makefile @@ -0,0 +1,36 @@ + +all: extractor extractor_manager + @echo -n +opt: extractor.opt extractor_manager.opt + @echo -n + +clean: + rm -f *.cm[ixo] *.[ao] extractor extractor.opt *.err *.out extractor_manager extractor_manager.opt + +extractor: extractor.ml + @echo " OCAMLC $<" + @$(OCAMLFIND) ocamlc \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +extractor.opt: extractor.ml + @echo " OCAMLOPT $<" + @$(OCAMLFIND) ocamlopt \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +extractor_manager: extractor_manager.ml + @echo " OCAMLC $<" + @$(OCAMLFIND) ocamlc \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +extractor_manager.opt: extractor_manager.ml + @echo " OCAMLOPT $<" + @$(OCAMLFIND) ocamlopt \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +export: extractor.opt extractor_manager.opt + nice -n 20 \ + time \ + ./extractor_manager.opt 1>export.out 2>export.err + +include .depend +include ../../../Makefile.defs diff --git a/helm/software/components/metadata/extractor/extractor.conf.xml b/helm/software/components/metadata/extractor/extractor.conf.xml new file mode 100644 index 000000000..8dbc9a935 --- /dev/null +++ b/helm/software/components/metadata/extractor/extractor.conf.xml @@ -0,0 +1,19 @@ + + +
    + .tmp/ +
    +
    + localhost + helm + mowgli +
    +
    + + file:///projects/helm/library/coq_contribs + + $(tmp.dir)/cache + $(tmp.dir)/maps + /projects/helm/xml/dtd +
    +     diff --git a/helm/software/components/metadata/extractor/extractor.ml b/helm/software/components/metadata/extractor/extractor.ml new file mode 100644 index 000000000..418d5ff7c --- /dev/null +++ b/helm/software/components/metadata/extractor/extractor.ml @@ -0,0 +1,78 @@ +let _ = Helm_registry.load_from "extractor.conf.xml" + +let usage () = + prerr_endline " + +!! This binary should not be called by hand, use the extractor_manager. !! + +usage: ./extractor[.opt] path owner + +path: the path for the getter maps +owner: the owner of the tables to update + +" + +let _ = + try + let _ = Sys.argv.(2), Sys.argv.(1) in + if Sys.argv.(1) = "-h"||Sys.argv.(1) = "-help"||Sys.argv.(1) = "--help" then + begin + usage (); + exit 1 + end + with + Invalid_argument _ -> usage (); exit 1 + +let owner = Sys.argv.(2) +let path = Sys.argv.(1) + +let main () = + print_endline (Printf.sprintf "%d alive on path:%s owner:%s" + (Unix.getpid()) path owner); + Helm_registry.set "tmp.dir" path; + Http_getter.init (); + let dbd = + HMysql.quick_connect + ~host:(Helm_registry.get "db.host") + ~user:(Helm_registry.get "db.user") + ~database:(Helm_registry.get "db.database") () + in + MetadataTypes.ownerize_tables owner; + let uris = + let ic = open_in (path ^ "/todo") in + let acc = ref [] in + (try + while true do + let l = input_line ic in + acc := l :: !acc + done + with + End_of_file -> ()); + close_in ic; + !acc + in + let len = float_of_int (List.length uris) in + let i = ref 0 in + let magic = 45 in + List.iter (fun u -> + incr i; + let perc = ((float_of_int !i) /. len *. 100.0) in + let l = String.length u in + let short = + if l < magic then + u ^ String.make (magic + 3 - l) ' ' + else + "..." ^ String.sub u (l - magic) magic + in + Printf.printf "%d (%d of %.0f = %3.1f%%): %s\n" + (Unix.getpid ()) !i len perc short; + flush stdout; + let uri = UriManager.uri_of_string u in + MetadataDb.index_obj ~dbd ~uri; + CicEnvironment.empty ()) + uris; + print_string "END "; Unix.system "date" +;; + +main () + diff --git a/helm/software/components/metadata/extractor/extractor_manager.ml b/helm/software/components/metadata/extractor/extractor_manager.ml new file mode 100644 index 000000000..05393b63e --- /dev/null +++ b/helm/software/components/metadata/extractor/extractor_manager.ml @@ -0,0 +1,306 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* HELPERS *) + +let create_all dbd = + let obj_tbl = MetadataTypes.obj_tbl () in + let sort_tbl = MetadataTypes.sort_tbl () in + let rel_tbl = MetadataTypes.rel_tbl () in + let name_tbl = MetadataTypes.name_tbl () in + let count_tbl = MetadataTypes.count_tbl () in + let tbls = [ + (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; + (name_tbl,`ObjectName) ; (count_tbl,`Count) ] + in + let statements = + (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls) + in + List.iter (fun statement -> + try + ignore (Mysql.exec dbd statement) + with + exn -> + let status = Mysql.status dbd in + match status with + | Mysql.StatusError Mysql.Table_exists_error -> () + | Mysql.StatusError _ -> raise exn + | _ -> () + ) statements + +let drop_all dbd = + let obj_tbl = MetadataTypes.obj_tbl () in + let sort_tbl = MetadataTypes.sort_tbl () in + let rel_tbl = MetadataTypes.rel_tbl () in + let name_tbl = MetadataTypes.name_tbl () in + let count_tbl = MetadataTypes.count_tbl () in + let tbls = [ + (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; + (name_tbl,`ObjectName) ; (count_tbl,`Count) ] + in + let statements = + (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls) + in + List.iter (fun statement -> + try + ignore (Mysql.exec dbd statement) + with Mysql.Error _ as exn -> + match Mysql.errno dbd with + | Mysql.Bad_table_error + | Mysql.No_such_index | Mysql.No_such_table -> () + | _ -> raise exn + ) statements + +let slash_RE = Str.regexp "/" + +let partition l = + let l = List.fast_sort Pervasives.compare l in + let matches s1 s2 = + let l1,l2 = Str.split slash_RE s1, Str.split slash_RE s2 in + match l1,l2 with + | _::x::_,_::y::_ -> x = y + | _ -> false + in + let rec chunk l = + match l with + | [] -> [],[] + | h::(h1::tl as rest) when matches h h1 -> + let ch,todo = chunk rest in + (h::ch),todo + | h::(h1::tl as rest)-> [h],rest + | h::_ -> [h],[] + in + let rec split l = + let ch, todo = chunk l in + match todo with + | [] -> [ch] + | _ -> ch :: split todo + in + split l + + +(* ARGV PARSING *) + +let _ = + try + if Sys.argv.(1) = "-h"||Sys.argv.(1) = "-help"||Sys.argv.(1) = "--help" then + begin + prerr_endline " +usage: ./extractor_manager[.opt] [processes] [owner] + +defaults: + processes = 2 + owner = NEW + +"; + exit 1 + end + with Invalid_argument _ -> () + +let processes = + try + int_of_string (Sys.argv.(1)) + with + Invalid_argument _ -> 2 + +let owner = + try + Sys.argv.(2) + with Invalid_argument _ -> "NEW" + +let create_peons i = + let rec aux = function + | 0 -> [] + | n -> (n,0) :: aux (n-1) + in + ref (aux i) + +let is_a_peon_idle peons = + List.exists (fun (_,x) -> x = 0) !peons + +let get_ide_peon peons = + let p = fst(List.find (fun (_,x) -> x = 0) !peons) in + peons := List.filter (fun (x,_) -> x <> p) !peons; + p + +let assign_peon peon pid peons = + peons := (peon,pid) :: !peons + +let wait_a_peon peons = + let pid,status = Unix.wait () in + (match status with + | Unix.WEXITED 0 -> () + | Unix.WEXITED s -> + prerr_endline (Printf.sprintf "PEON %d EXIT STATUS %d" pid s) + | Unix.WSIGNALED s -> + prerr_endline + (Printf.sprintf "PEON %d HAD A PROBLEM, KILLED BY SIGNAL %d" pid s) + | Unix.WSTOPPED s -> + prerr_endline + (Printf.sprintf "PEON %d HAD A PROBLEM, STOPPED BY %d" pid s)); + let p = fst(List.find (fun (_,x) -> x = pid) !peons) in + peons := List.filter (fun (x,_) -> x <> p) !peons; + peons := (p,0) :: !peons + +let is_a_peon_busy peons = + List.exists (fun (_,x) -> x <> 0) !peons + +(* MAIN *) +let main () = + Helm_registry.load_from "extractor.conf.xml"; + Http_getter.init (); + print_endline "Updating the getter...."; + let base = (Helm_registry.get "tmp.dir") ^ "/maps" in + let formats i = + (Helm_registry.get "tmp.dir") ^ "/"^(string_of_int i)^"/maps" + in + for i = 1 to processes do + let fmt = formats i in + ignore(Unix.system ("rm -rf " ^ fmt)); + ignore(Unix.system ("mkdir -p " ^ fmt)); + ignore(Unix.system ("cp -r " ^ base ^ " " ^ fmt ^ "/../")); + done; + let dbd = + Mysql.quick_connect + ~host:(Helm_registry.get "db.host") + ~user:(Helm_registry.get "db.user") + ~database:(Helm_registry.get "db.database") () + in + MetadataTypes.ownerize_tables owner; + let uri_RE = Str.regexp ".*\\(ind\\|var\\|con\\)$" in + drop_all dbd; + create_all dbd; + let uris = Http_getter.getalluris () in + let uris = List.filter (fun u -> Str.string_match uri_RE u 0) uris in + let todo = partition uris in + let cur = ref 0 in + let tot = List.length todo in + let peons = create_peons processes in + print_string "START "; flush stdout; + ignore(Unix.system "date"); + while !cur < tot do + if is_a_peon_idle peons then + let peon = get_ide_peon peons in + let fmt = formats peon in + let oc = open_out (fmt ^ "/../todo") in + List.iter (fun s -> output_string oc (s^"\n")) (List.nth todo !cur); + close_out oc; + let pid = Unix.fork () in + if pid = 0 then + Unix.execv + "./extractor.opt" [| "./extractor.opt" ; fmt ^ "/../" ; owner|] + else + begin + assign_peon peon pid peons; + incr cur + end + else + wait_a_peon peons + done; + while is_a_peon_busy peons do wait_a_peon peons done; + print_string "END "; flush stdout; + ignore(Unix.system "date"); + (* and now the rename table stuff *) + let obj_tbl = MetadataTypes.library_obj_tbl in + let sort_tbl = MetadataTypes.library_sort_tbl in + let rel_tbl = MetadataTypes.library_rel_tbl in + let name_tbl = MetadataTypes.library_name_tbl in + let count_tbl = MetadataTypes.library_count_tbl in + let hits_tbl = MetadataTypes.library_hits_tbl in + let obj_tbl_b = obj_tbl ^ "_BACKUP" in + let sort_tbl_b = sort_tbl ^ "_BACKUP" in + let rel_tbl_b = rel_tbl ^ "_BACKUP" in + let name_tbl_b = name_tbl ^ "_BACKUP" in + let count_tbl_b = count_tbl ^ "_BACKUP" in + let obj_tbl_c = MetadataTypes.obj_tbl () in + let sort_tbl_c = MetadataTypes.sort_tbl () in + let rel_tbl_c = MetadataTypes.rel_tbl () in + let name_tbl_c = MetadataTypes.name_tbl () in + let count_tbl_c = MetadataTypes.count_tbl () in + let stats = + SqlStatements.drop_tables [ + (obj_tbl_b,`RefObj); + (sort_tbl_b,`RefSort); + (rel_tbl_b,`RefRel); + (name_tbl_b,`ObjectName); + (count_tbl_b,`Count); + (hits_tbl,`Hits) ] @ + SqlStatements.drop_indexes [ + (obj_tbl,`RefObj); + (sort_tbl,`RefSort); + (rel_tbl,`RefRel); + (name_tbl,`ObjectName); + (count_tbl,`Count); + (obj_tbl_c,`RefObj); + (sort_tbl_c,`RefSort); + (rel_tbl_c,`RefRel); + (name_tbl_c,`ObjectName); + (count_tbl_c,`Count); + (hits_tbl,`Hits) ] @ + SqlStatements.rename_tables [ + (obj_tbl,obj_tbl_b); + (sort_tbl,sort_tbl_b); + (rel_tbl,rel_tbl_b); + (name_tbl,name_tbl_b); + (count_tbl,count_tbl_b) ] @ + SqlStatements.rename_tables [ + (obj_tbl_c,obj_tbl); + (sort_tbl_c,sort_tbl); + (rel_tbl_c,rel_tbl); + (name_tbl_c,name_tbl); + (count_tbl_c,count_tbl) ] @ + SqlStatements.create_tables [ + (hits_tbl,`Hits) ] @ + SqlStatements.fill_hits obj_tbl hits_tbl @ + SqlStatements.create_indexes [ + (obj_tbl,`RefObj); + (sort_tbl,`RefSort); + (rel_tbl,`RefRel); + (name_tbl,`ObjectName); + (count_tbl,`Count); + (hits_tbl,`Hits) ] + in + List.iter (fun statement -> + try +(* prerr_endline statement;*) + ignore (Mysql.exec dbd statement) + with exn -> + let status = Mysql.status dbd in + match status with + | Mysql.StatusError Mysql.Table_exists_error + | Mysql.StatusError Mysql.Bad_table_error + | Mysql.StatusError Mysql.Cant_drop_field_or_key + | Mysql.StatusError Mysql.Unknown_table -> () + | Mysql.StatusError status -> +(* prerr_endline (string_of_int (Obj.magic status));*) + prerr_endline (Printexc.to_string exn); + raise exn + | _ -> + prerr_endline (Printexc.to_string exn); + ()) + stats +;; + +main () diff --git a/helm/software/components/metadata/metadataConstraints.ml b/helm/software/components/metadata/metadataConstraints.ml new file mode 100644 index 000000000..07fcc738b --- /dev/null +++ b/helm/software/components/metadata/metadataConstraints.ml @@ -0,0 +1,649 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf +open MetadataTypes + +let critical_value = 7 +let just_factor = 3 + +module UriManagerSet = UriManager.UriSet +module SetSet = Set.Make (UriManagerSet) + +type term_signature = (UriManager.uri * UriManager.uri list) option * UriManagerSet.t + +type cardinality_condition = + | Eq of int + | Gt of int + | Lt of int + +type rating_criterion = + [ `Hits (** order by number of hits, most used objects first *) + ] + +let default_tables = + (library_obj_tbl,library_rel_tbl,library_sort_tbl,library_count_tbl) + +let current_tables () = + (obj_tbl (),rel_tbl (),sort_tbl (), count_tbl ()) + +let tbln n = "table" ^ string_of_int n + +(* +let add_depth_constr depth_opt cur_tbl where = + match depth_opt with + | None -> where + | Some depth -> (sprintf "%s.h_depth = %d" cur_tbl depth) :: where +*) + +let mk_positions positions cur_tbl = + "(" ^ + String.concat " or " + (List.map + (fun pos -> + let pos_str = MetadataPp.pp_position_tag pos in + match pos with + | `InBody + | `InConclusion + | `InHypothesis + | `MainConclusion None + | `MainHypothesis None -> + sprintf "%s.h_position = \"%s\"" cur_tbl pos_str + | `MainConclusion (Some r) + | `MainHypothesis (Some r) -> + let depth = MetadataPp.pp_relation r in + sprintf "(%s.h_position = \"%s\" and %s.h_depth %s)" + cur_tbl pos_str cur_tbl depth) + (positions :> MetadataTypes.position list)) ^ + ")" + +let explode_card_constr = function + | Eq card -> "=", card + | Gt card -> ">", card + | Lt card -> "<", card + +let add_card_constr tbl col where = function + | None -> where + | Some constr -> + let op, card = explode_card_constr constr in + (* count(_utente).hypothesis = 3 *) + (sprintf "%s.%s %s %d" tbl col op card :: where) + +let add_diff_constr tbl where = function + | None -> where + | Some constr -> + let op, card = explode_card_constr constr in + (sprintf "%s.hypothesis - %s.conclusion %s %d" tbl tbl op card :: where) + +let add_all_constr ?(tbl=library_count_tbl) (n,from,where) concl full diff = + match (concl, full, diff) with + | None, None, None -> (n,from,where) + | _ -> + let cur_tbl = tbln n in + let from = (sprintf "%s as %s" tbl cur_tbl) :: from in + let where = add_card_constr cur_tbl "conclusion" where concl in + let where = add_card_constr cur_tbl "statement" where full in + let where = add_diff_constr cur_tbl where diff in + (n+2,from, + (if n > 0 then + sprintf "table0.source = %s.source" cur_tbl :: where + else + where)) + + +let add_constraint ?(start=0) ?(tables=default_tables) (n,from,where) metadata = + let obj_tbl,rel_tbl,sort_tbl,count_tbl = tables + in + let cur_tbl = tbln n in + let start_table = tbln start in + match metadata with + | `Obj (uri, positions) -> + let from = (sprintf "%s as %s" obj_tbl cur_tbl) :: from in + let where = + (sprintf "(%s.h_occurrence = \"%s\")" cur_tbl (UriManager.string_of_uri uri)) :: + mk_positions positions cur_tbl :: + (if n=start then [] + else [sprintf "%s.source = %s.source" start_table cur_tbl]) @ + where + in + ((n+2), from, where) + | `Rel positions -> + let from = (sprintf "%s as %s" rel_tbl cur_tbl) :: from in + let where = + mk_positions positions cur_tbl :: + (if n=start then [] + else [sprintf "%s.source = %s.source" start_table cur_tbl]) @ + where + in + ((n+2), from, where) + | `Sort (sort, positions) -> + let sort_str = CicPp.ppsort sort in + let from = (sprintf "%s as %s" sort_tbl cur_tbl) :: from in + let where = + (sprintf "%s.h_sort = \"%s\"" cur_tbl sort_str ) :: + mk_positions positions cur_tbl :: + (if n=start then + [] + else + [sprintf "%s.source = %s.source" start_table cur_tbl ]) @ where + in + ((n+2), from, where) + +let exec ~(dbd:HMysql.dbd) ?rating (n,from,where) = + let from = String.concat ", " from in + let where = String.concat " and " where in + let query = + match rating with + | None -> sprintf "select distinct table0.source from %s where %s" from where + | Some `Hits -> + sprintf + ("select distinct table0.source from %s, hits where %s + and table0.source = hits.source order by hits.no desc") + from where + in + (* prerr_endline query; *) + let result = HMysql.exec dbd query in + HMysql.map result + (fun row -> match row.(0) with Some s -> UriManager.uri_of_string s | _ -> assert false) + + +let at_least ~(dbd:HMysql.dbd) ?concl_card ?full_card ?diff ?rating tables + (metadata: MetadataTypes.constr list) += + let obj_tbl,rel_tbl,sort_tbl, count_tbl = tables + in + if (metadata = []) && concl_card = None && full_card = None then + failwith "MetadataQuery.at_least: no constraints given"; + let (n,from,where) = + List.fold_left (add_constraint ~tables) (0,[],[]) metadata + in + let (n,from,where) = + add_all_constr ~tbl:count_tbl (n,from,where) concl_card full_card diff + in + exec ~dbd ?rating (n,from,where) + +let at_least + ~(dbd:HMysql.dbd) ?concl_card ?full_card ?diff ?rating + (metadata: MetadataTypes.constr list) += + if are_tables_ownerized () then + (at_least + ~dbd ?concl_card ?full_card ?diff ?rating default_tables metadata) @ + (at_least + ~dbd ?concl_card ?full_card ?diff ?rating (current_tables ()) metadata) + else + at_least + ~dbd ?concl_card ?full_card ?diff ?rating default_tables metadata + + + (** Prefix handling *) + +let filter_by_card n = + SetSet.filter (fun t -> (UriManagerSet.cardinal t) <= n) + +let merge n a b = + let init = SetSet.union a b in + let merge_single_set s1 b = + SetSet.fold + (fun s2 res -> SetSet.add (UriManagerSet.union s1 s2) res) + b SetSet.empty in + let res = + SetSet.fold (fun s1 res -> SetSet.union (merge_single_set s1 b) res) a init + in + filter_by_card n res + +let rec inspect_children n childs = + List.fold_left + (fun res term -> merge n (inspect_conclusion n term) res) + SetSet.empty childs + +and add_root n root childs = + let childunion = inspect_children n childs in + let addroot = UriManagerSet.add root in + SetSet.fold + (fun child newsets -> SetSet.add (addroot child) newsets) + childunion + (SetSet.singleton (UriManagerSet.singleton root)) + +and inspect_conclusion n t = + if n = 0 then SetSet.empty + else match t with + Cic.Rel _ + | Cic.Meta _ + | Cic.Sort _ + | Cic.Implicit _ -> SetSet.empty + | Cic.Var (u,exp_named_subst) -> SetSet.empty + | Cic.Const (u,exp_named_subst) -> + SetSet.singleton (UriManagerSet.singleton u) + | Cic.MutInd (u, t, exp_named_subst) -> + SetSet.singleton (UriManagerSet.singleton + (UriManager.uri_of_uriref u t None)) + | Cic.MutConstruct (u, t, c, exp_named_subst) -> + SetSet.singleton (UriManagerSet.singleton + (UriManager.uri_of_uriref u t (Some c))) + | Cic.Cast (t, _) -> inspect_conclusion n t + | Cic.Prod (_, s, t) -> + merge n (inspect_conclusion n s) (inspect_conclusion n t) + | Cic.Lambda (_, s, t) -> + merge n (inspect_conclusion n s) (inspect_conclusion n t) + | Cic.LetIn (_, s, t) -> + merge n (inspect_conclusion n s) (inspect_conclusion n t) + | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> + add_root (n-1) u l + | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> + let uri = UriManager.uri_of_uriref u t None in + add_root (n-1) uri l + | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> + let suri = UriManager.uri_of_uriref u t (Some c) in + add_root (n-1) suri l + | Cic.Appl l -> + SetSet.empty + | Cic.MutCase (u, t, tt, uu, m) -> + SetSet.empty + | Cic.Fix (_, m) -> + SetSet.empty + | Cic.CoFix (_, m) -> + SetSet.empty + +let rec inspect_term n t = + if n = 0 then + assert false + else + match t with + Cic.Rel _ + | Cic.Meta _ + | Cic.Sort _ + | Cic.Implicit _ -> None, SetSet.empty + | Cic.Var (u,exp_named_subst) -> None, SetSet.empty + | Cic.Const (u,exp_named_subst) -> + Some u, SetSet.empty + | Cic.MutInd (u, t, exp_named_subst) -> + let uri = UriManager.uri_of_uriref u t None in + Some uri, SetSet.empty + | Cic.MutConstruct (u, t, c, exp_named_subst) -> + let uri = UriManager.uri_of_uriref u t (Some c) in + Some uri, SetSet.empty + | Cic.Cast (t, _) -> inspect_term n t + | Cic.Prod (_, _, t) -> inspect_term n t + | Cic.LetIn (_, _, t) -> inspect_term n t + | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> + let childunion = inspect_children (n-1) l in + Some u, childunion + | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> + let suri = UriManager.uri_of_uriref u t None in + if u = HelmLibraryObjects.Logic.eq_URI && n>1 then + (* equality is handled in a special way: in particular, + the type, if defined, is always added to the prefix, + and n is not decremented - it should have been n-2 *) + match l with + Cic.Const (u1,exp_named_subst1)::l1 -> + let inconcl = add_root (n-1) u1 l1 in + Some suri, inconcl + | Cic.MutInd (u1, t1, exp_named_subst1)::l1 -> + let suri1 = UriManager.uri_of_uriref u1 t1 None in + let inconcl = add_root (n-1) suri1 l1 in + Some suri, inconcl + | Cic.MutConstruct (u1, t1, c1, exp_named_subst1)::l1 -> + let suri1 = UriManager.uri_of_uriref u1 t1 (Some c1) in + let inconcl = add_root (n-1) suri1 l1 in + Some suri, inconcl + | _ :: _ -> Some suri, SetSet.empty + | _ -> assert false (* args number must be > 0 *) + else + let childunion = inspect_children (n-1) l in + Some suri, childunion + | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> + let suri = UriManager.uri_of_uriref u t(Some c) in + let childunion = inspect_children (n-1) l in + Some suri, childunion + | _ -> None, SetSet.empty + +let add_cardinality s = + let l = SetSet.elements s in + let res = + List.map + (fun set -> + let el = UriManagerSet.elements set in + (List.length el, el)) l in + (* ordered by descending cardinality *) + List.sort (fun (n,_) (m,_) -> m - n) ((0,[])::res) + +let prefixes n t = + match inspect_term n t with + Some a, set -> Some a, add_cardinality set + | None, set when (SetSet.is_empty set) -> None, [] + | _, _ -> assert false + + +let rec add children = + List.fold_left + (fun acc t -> UriManagerSet.union (signature_concl t) acc) + (UriManagerSet.empty) children + +(* this function creates the set of all different constants appearing in + the conclusion of the term *) +and signature_concl = + function + Cic.Rel _ + | Cic.Meta _ + | Cic.Sort _ + | Cic.Implicit _ -> UriManagerSet.empty + | Cic.Var (u,exp_named_subst) -> + (*CSC: TODO if the var has a body it must be processed *) + UriManagerSet.empty + | Cic.Const (u,exp_named_subst) -> + UriManagerSet.singleton u + | Cic.MutInd (u, t, exp_named_subst) -> + let uri = UriManager.uri_of_uriref u t None in + UriManagerSet.singleton uri + | Cic.MutConstruct (u, t, c, exp_named_subst) -> + let uri = UriManager.uri_of_uriref u t (Some c) in + UriManagerSet.singleton uri + | Cic.Cast (t, _) -> signature_concl t + | Cic.Prod (_, s, t) -> + UriManagerSet.union (signature_concl s) (signature_concl t) + | Cic.Lambda (_, s, t) -> + UriManagerSet.union (signature_concl s) (signature_concl t) + | Cic.LetIn (_, s, t) -> + UriManagerSet.union (signature_concl s) (signature_concl t) + | Cic.Appl l -> add l + | Cic.MutCase _ + | Cic.Fix _ + | Cic.CoFix _ -> + UriManagerSet.empty + +let rec signature_of = function + | Cic.Cast (t, _) -> signature_of t + | Cic.Prod (_, _, t) -> signature_of t + | Cic.LetIn (_, _, t) -> signature_of t + | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> + Some (u, []), add l + | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> + let suri = UriManager.uri_of_uriref u t None in + if u = HelmLibraryObjects.Logic.eq_URI then + (* equality is handled in a special way: in particular, + the type, if defined, is always added to the prefix, + and n is not decremented - it should have been n-2 *) + match l with + Cic.Const (u1,exp_named_subst1)::l1 -> + let inconcl = UriManagerSet.remove u1 (add l1) in + Some (suri, [u1]), inconcl + | Cic.MutInd (u1, t1, exp_named_subst1)::l1 -> + let suri1 = UriManager.uri_of_uriref u1 t1 None in + let inconcl = UriManagerSet.remove suri1 (add l1) in + Some (suri, [suri1]), inconcl + | Cic.MutConstruct (u1, t1, c1, exp_named_subst1)::l1 -> + let suri1 = UriManager.uri_of_uriref u1 t1 (Some c1) in + let inconcl = UriManagerSet.remove suri1 (add l1) in + Some (suri, [suri1]), inconcl + | _ :: _ -> Some (suri, []), UriManagerSet.empty + | _ -> assert false (* args number must be > 0 *) + else + Some (suri, []), add l + | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> + let suri = UriManager.uri_of_uriref u t (Some c) in + Some (suri, []), add l + | t -> None, signature_concl t + +(* takes a list of lists and returns the list of all elements + without repetitions *) +let union l = + let rec drop_repetitions = function + [] -> [] + | [a] -> [a] + | u1::u2::l when u1 = u2 -> drop_repetitions (u2::l) + | u::l -> u::(drop_repetitions l) in + drop_repetitions (List.sort Pervasives.compare (List.concat l)) + +let must_of_prefix ?(where = `Conclusion) m s = + let positions = + match where with + | `Conclusion -> [`InConclusion] + | `Statement -> [`InConclusion; `InHypothesis; `MainHypothesis None] + in + let positions = + if m = None then `MainConclusion None :: positions else positions in + let s' = List.map (fun (u:UriManager.uri) -> `Obj (u, positions)) s in + match m with + None -> s' + | Some m -> `Obj (m, [`MainConclusion None]) :: s' + +let escape = Str.global_replace (Str.regexp_string "\'") "\\'" + +let get_constants (dbd:HMysql.dbd) ~where uri = + let uri = escape (UriManager.string_of_uri uri) in + let positions = + match where with + | `Conclusion -> [ MetadataTypes.mainconcl_pos; MetadataTypes.inconcl_pos ] + | `Statement -> + [ MetadataTypes.mainconcl_pos; MetadataTypes.inconcl_pos; + MetadataTypes.inhyp_pos; MetadataTypes.mainhyp_pos ] + in + let query = + let pos_predicate = + String.concat " OR " + (List.map (fun pos -> sprintf "(h_position = \"%s\")" pos) positions) + in + sprintf ("SELECT h_occurrence FROM %s WHERE source=\"%s\" AND (%s) UNION "^^ + "SELECT h_occurrence FROM %s WHERE source=\"%s\" AND (%s)") + (MetadataTypes.obj_tbl ()) uri pos_predicate + MetadataTypes.library_obj_tbl uri pos_predicate + + in + let result = HMysql.exec dbd query in + let set = ref UriManagerSet.empty in + HMysql.iter result + (fun col -> + match col.(0) with + | Some uri -> set := UriManagerSet.add (UriManager.uri_of_string uri) !set + | _ -> assert false); + !set + +let at_most ~(dbd:HMysql.dbd) ?(where = `Conclusion) only u = + let inconcl = get_constants dbd ~where u in + UriManagerSet.subset inconcl only + + (* Special handling of equality. The problem is filtering out theorems just + * containing variables (e.g. all the theorems in cic:/Coq/Ring/). Really + * ad-hoc, no better solution found at the moment *) +let myspeciallist_of_facts = + [0,UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"] +let myspeciallist = + [0,UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; + (* 0,"cic:/Coq/Init/Logic/sym_eq.con"; *) + 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"; + 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"; + 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal2.con"; + 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal3.con"] + + +let compute_exactly ~(dbd:HMysql.dbd) ?(facts=false) ~where main prefixes = + List.concat + (List.map + (fun (m,s) -> + let is_eq,card = + match main with + None -> false,m + | Some main -> + (m = 0 && + UriManager.eq main + (UriManager.uri_of_string (HelmLibraryObjects.Logic.eq_XURI))), + m+1 + in + if m = 0 && is_eq then + (if facts then myspeciallist_of_facts + else myspeciallist) + else + let res = + (* this gets rid of the ~750 objects of type Set/Prop/Type *) + if card = 0 then [] + else + let must = must_of_prefix ~where main s in + match where with + | `Conclusion -> at_least ~dbd ~concl_card:(Eq card) must + | `Statement -> at_least ~dbd ~full_card:(Eq card) must + in + List.map (fun uri -> (card, uri)) res) + prefixes) + + (* critical value reached, fallback to "only" constraints *) + +let compute_with_only ~(dbd:HMysql.dbd) ?(facts=false) ?(where = `Conclusion) + main prefixes constants += + let max_prefix_length = + match prefixes with + | [] -> assert false + | (max,_)::_ -> max in + let maximal_prefixes = + let rec filter res = function + [] -> res + | (n,s)::l when n = max_prefix_length -> filter ((n,s)::res) l + | _::_-> res in + filter [] prefixes in + let greater_than = + let all = + union + (List.map + (fun (m,s) -> + let card = if main = None then m else m + 1 in + let must = must_of_prefix ~where main s in + (let res = + match where with + | `Conclusion -> at_least ~dbd ~concl_card:(Gt card) must + | `Statement -> at_least ~dbd ~full_card:(Gt card) must + in + (* we tag the uri with m+1, for sorting purposes *) + List.map (fun uri -> (card, uri)) res)) + maximal_prefixes) + in + Printf.fprintf stderr "all: %d\n" (List.length all);flush_all (); + List.filter (function (_,uri) -> at_most ~dbd ~where constants uri) all in + let equal_to = compute_exactly ~dbd ~facts ~where main prefixes in + greater_than @ equal_to + + (* real match query implementation *) + +let cmatch ~(dbd:HMysql.dbd) ?(facts=false) t = + let (main, constants) = signature_of t in + match main with + | None -> [] + | Some (main, types) -> + (* the type of eq is not counted in constants_no *) + let types_no = List.length types in + let constants_no = UriManagerSet.cardinal constants in + if (constants_no > critical_value) then + let prefixes = prefixes just_factor t in + (match prefixes with + | Some main, all_concl -> + let all_constants = + List.fold_right UriManagerSet.add types (UriManagerSet.add main constants) + in + compute_with_only ~dbd ~facts (Some main) all_concl all_constants + | _, _ -> []) + else + (* in this case we compute all prefixes, and we do not need + to apply the only constraints *) + let prefixes = + if constants_no = 0 then + (if types_no = 0 then + Some main, [0, []] + else + Some main, [0, []; types_no, types]) + else + prefixes (constants_no+types_no+1) t + in + (match prefixes with + Some main, all_concl -> + compute_exactly ~dbd ~facts ~where:`Conclusion (Some main) all_concl + | _, _ -> []) + +let power_upto upto consts = + let l = UriManagerSet.elements consts in + List.sort (fun (n,_) (m,_) -> m - n) + (List.fold_left + (fun res a -> + let res' = + List.filter (function (n,l) -> n <= upto) + (List.map (function (n,l) -> (n+1,a::l)) res) in + res@res') + [(0,[])] l) + +let power consts = + let l = UriManagerSet.elements consts in + List.sort (fun (n,_) (m,_) -> m - n) + (List.fold_left + (fun res a -> res@(List.map (function (n,l) -> (n+1,a::l)) res)) + [(0,[])] l) + +type where = [ `Conclusion | `Statement ] + +let sigmatch ~(dbd:HMysql.dbd) ?(facts=false) ?(where = `Conclusion) + (main, constants) += + let main,types = + match main with + None -> None,[] + | Some (main, types) -> Some main,types + in + let constants_no = UriManagerSet.cardinal constants in + (* prerr_endline (("constants_no: ")^(string_of_int constants_no)); *) + if (constants_no > critical_value) then + let subsets = + let subsets = power_upto just_factor constants in + (* let _ = prerr_endline (("subsets: ")^ + (string_of_int (List.length subsets))) in *) + let types_no = List.length types in + List.map (function (n,l) -> (n+types_no,types@l)) subsets + in + let all_constants = + let all = match main with None -> types | Some m -> m::types in + List.fold_right UriManagerSet.add all constants + in + compute_with_only ~dbd ~where main subsets all_constants + else + let subsets = + let subsets = power constants in + let types_no = List.length types in + if types_no > 0 then + (0,[]) :: List.map (function (n,l) -> (n+types_no,types@l)) subsets + else subsets + in + compute_exactly ~dbd ~facts ~where main subsets + + (* match query wrappers *) + +let cmatch'= cmatch + +let cmatch ~dbd ?(facts=false) term = + List.map snd + (List.sort + (fun x y -> Pervasives.compare (fst y) (fst x)) + (cmatch' ~dbd ~facts term)) + +let constants_of = signature_concl + diff --git a/helm/software/components/metadata/metadataConstraints.mli b/helm/software/components/metadata/metadataConstraints.mli new file mode 100644 index 000000000..63757ae47 --- /dev/null +++ b/helm/software/components/metadata/metadataConstraints.mli @@ -0,0 +1,111 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +module UriManagerSet : Set.S with type elt = UriManager.uri + + + (** @return + * main: constant in main position and, for polymorphic constants, type + * instantitation + * constants: constants appearing in term *) +type term_signature = (UriManager.uri * UriManager.uri list) option * UriManagerSet.t + +(** {2 Candidates filtering} *) + + (** @return sorted list of theorem URIs, first URIs in the least have higher + * relevance *) +val cmatch: dbd:HMysql.dbd -> ?facts:bool -> Cic.term -> UriManager.uri list + + (** as cmatch, but returned list is not sorted but rather tagged with + * relevance information: higher the tag, higher the relevance *) +val cmatch': dbd:HMysql.dbd -> ?facts:bool -> Cic.term -> (int * UriManager.uri) list + +type where = [ `Conclusion | `Statement ] (** signature matching extent *) + + (** @param where defaults to `Conclusion *) +val sigmatch: + dbd:HMysql.dbd -> + ?facts:bool -> + ?where:where -> + term_signature -> + (int * UriManager.uri) list + +(** {2 Constraint engine} *) + + (** constraing on the number of distinct constants *) +type cardinality_condition = + | Eq of int + | Gt of int + | Lt of int + +type rating_criterion = + [ `Hits (** order by number of hits, most used objects first *) + ] + +val add_constraint: + ?start:int -> + ?tables:string * string * string * string -> + int * string list * string list -> + MetadataTypes.constr -> + int * string list * string list + + (** @param concl_card cardinality condition on conclusion only + * @param full_card cardinality condition on the whole statement + * @param diff required difference between the number of different constants in + * hypothesis and the number of different constants in body + * @return list of URI satisfying given constraints *) + +val at_least: + dbd:HMysql.dbd -> + ?concl_card:cardinality_condition -> + ?full_card:cardinality_condition -> + ?diff:cardinality_condition -> + ?rating:rating_criterion -> + MetadataTypes.constr list -> + UriManager.uri list + + (** @param where defaults to `Conclusion *) +val at_most: + dbd:HMysql.dbd -> + ?where:where -> UriManagerSet.t -> + (UriManager.uri -> bool) + +val add_all_constr: + ?tbl:string -> + int * string list * string list -> + cardinality_condition option -> + cardinality_condition option -> + cardinality_condition option -> + int * string list * string list + +val exec: + dbd:HMysql.dbd -> + ?rating:[ `Hits ] -> + int * string list * string list -> + UriManager.uri list + +val signature_of: Cic.term -> term_signature +val constants_of: Cic.term -> UriManagerSet.t + diff --git a/helm/software/components/metadata/metadataDb.ml b/helm/software/components/metadata/metadataDb.ml new file mode 100644 index 000000000..457545dee --- /dev/null +++ b/helm/software/components/metadata/metadataDb.ml @@ -0,0 +1,193 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open MetadataTypes + +open Printf + +let execute_insert dbd uri (sort_cols, rel_cols, obj_cols) = + let sort_tuples = + List.fold_left (fun s l -> match l with + | [`String a; `String b; `Int c; `String d] -> + sprintf "(\"%s\", \"%s\", %d, \"%s\")" a b c d :: s + | _ -> assert false ) + [] sort_cols + in + let rel_tuples = + List.fold_left (fun s l -> match l with + | [`String a; `String b; `Int c] -> + sprintf "(\"%s\", \"%s\", %d)" a b c :: s + | _ -> assert false) + [] rel_cols + in + let obj_tuples = List.fold_left (fun s l -> match l with + | [`String a; `String b; `String c; `Int d] -> + sprintf "(\"%s\", \"%s\", \"%s\", %d)" a b c d :: s + | [`String a; `String b; `String c; `Null] -> + sprintf "(\"%s\", \"%s\", \"%s\", %s)" a b c "NULL" :: s + | _ -> assert false) + [] obj_cols + in + if sort_tuples <> [] then + begin + let query_sort = + sprintf "INSERT %s VALUES %s;" (sort_tbl ()) (String.concat "," sort_tuples) + in + ignore (HMysql.exec dbd query_sort) + end; + if rel_tuples <> [] then + begin + let query_rel = + sprintf "INSERT %s VALUES %s;" (rel_tbl ()) (String.concat "," rel_tuples) + in + ignore (HMysql.exec dbd query_rel) + end; + if obj_tuples <> [] then + begin + let query_obj = + sprintf "INSERT %s VALUES %s;" (obj_tbl ()) (String.concat "," obj_tuples) + in + ignore (HMysql.exec dbd query_obj) + end + + +let count_distinct position l = + MetadataConstraints.UriManagerSet.cardinal + (List.fold_left (fun acc d -> + match position with + | `Conclusion -> + (match d with + | `Obj (name,`InConclusion) + | `Obj (name,`MainConclusion _ ) -> + MetadataConstraints.UriManagerSet.add name acc + | _ -> acc) + | `Hypothesis -> + (match d with + | `Obj (name,`InHypothesis) + | `Obj (name,`MainHypothesis _) -> + MetadataConstraints.UriManagerSet.add name acc + | _ -> acc) + | `Statement -> + (match d with + | `Obj (name,`InBody) -> acc + | `Obj (name,_) -> MetadataConstraints.UriManagerSet.add name acc + | _ -> acc) + ) MetadataConstraints.UriManagerSet.empty l) + +let insert_const_no ~dbd l = + let data = + List.fold_left + (fun acc (uri,_,metadata) -> + let no_concl = count_distinct `Conclusion metadata in + let no_hyp = count_distinct `Hypothesis metadata in + let no_full = count_distinct `Statement metadata in + (sprintf "(\"%s\", %d, %d, %d)" + (UriManager.string_of_uri uri) no_concl no_hyp no_full) :: acc + ) [] l in + let insert = + sprintf "INSERT INTO %s VALUES %s" (count_tbl ()) (String.concat "," data) + in + ignore (HMysql.exec dbd insert) + +let insert_name ~dbd l = + let data = + List.fold_left + (fun acc (uri,name,_) -> + (sprintf "(\"%s\", \"%s\")" (UriManager.string_of_uri uri) name) :: acc + ) [] l in + let insert = + sprintf "INSERT INTO %s VALUES %s" (name_tbl ()) (String.concat "," data) + in + ignore (HMysql.exec dbd insert) + +type columns = + MetadataPp.t list list * MetadataPp.t list list * MetadataPp.t list list + + (* TODO ZACK: verify if an object has already been indexed *) +let already_indexed _ = false + +(***** TENTATIVE HACK FOR THE DB SLOWDOWN - BEGIN *******) +let analyze_index = ref 0 +let eventually_analyze dbd = + incr analyze_index; + if !analyze_index > 30 then + begin + let analyze t = "OPTIMIZE TABLE " ^ t ^ ";" in + List.iter + (fun table -> ignore (HMysql.exec dbd (analyze table))) + [name_tbl (); rel_tbl (); sort_tbl (); obj_tbl(); count_tbl()] + end + +(***** TENTATIVE HACK FOR THE DB SLOWDOWN - END *******) + +let index_obj ~dbd ~uri = + if not (already_indexed uri) then begin + eventually_analyze dbd; + let metadata = MetadataExtractor.compute_obj uri in + let uri = UriManager.string_of_uri uri in + let columns = MetadataPp.columns_of_metadata metadata in + execute_insert dbd uri (columns :> columns); + insert_const_no ~dbd metadata; + insert_name ~dbd metadata + end + + +let tables_to_clean = + [sort_tbl; rel_tbl; obj_tbl; name_tbl; count_tbl] + +let clean ~(dbd:HMysql.dbd) = + let owned_uris = (* list of uris in list-of-columns format *) + let query = sprintf "SELECT source FROM %s" (name_tbl ()) in + let result = HMysql.exec dbd query in + let uris = HMysql.map result (fun cols -> + match cols.(0) with + | Some src -> src + | None -> assert false) in + (* and now some stuff to remove #xpointers and duplicates *) + uris + in + let del_from tbl = + let query s = + sprintf "DELETE FROM %s WHERE source LIKE \"%s%%\"" (tbl ()) s + in + List.iter + (fun source_col -> ignore (HMysql.exec dbd (query source_col))) + owned_uris + in + List.iter del_from tables_to_clean; + owned_uris + +let unindex ~dbd ~uri = + let uri = UriManager.string_of_uri uri in + let del_from tbl = + let query tbl = + sprintf "DELETE FROM %s WHERE source LIKE \"%s%%\"" (tbl ()) uri + in + ignore (HMysql.exec dbd (query tbl)) + in + List.iter del_from tables_to_clean + diff --git a/helm/software/components/metadata/metadataDb.mli b/helm/software/components/metadata/metadataDb.mli new file mode 100644 index 000000000..86820aafb --- /dev/null +++ b/helm/software/components/metadata/metadataDb.mli @@ -0,0 +1,41 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + + + +val index_obj: dbd:HMysql.dbd -> uri:UriManager.uri -> unit + +(* TODO Zack indexing of variables and (perhaps?) incomplete proofs *) + + (** remove from the db all metadata pertaining to a given owner + * @return list of uris removed from the db *) +val clean: dbd:HMysql.dbd -> string list + +val unindex: dbd:HMysql.dbd -> uri:UriManager.uri -> unit + +val count_distinct: + [`Conclusion | `Hypothesis | `Statement ] -> + MetadataTypes.metadata list -> + int diff --git a/helm/software/components/metadata/metadataExtractor.ml b/helm/software/components/metadata/metadataExtractor.ml new file mode 100644 index 000000000..4fbae1ba7 --- /dev/null +++ b/helm/software/components/metadata/metadataExtractor.ml @@ -0,0 +1,350 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open MetadataTypes + +let is_main_pos = function + | `MainConclusion _ + | `MainHypothesis _ -> true + | _ -> false + +let main_pos (pos: position): main_position = + match pos with + | `MainConclusion depth -> `MainConclusion depth + | `MainHypothesis depth -> `MainHypothesis depth + | _ -> assert false + +let next_pos = function + | `MainConclusion _ -> `InConclusion + | `MainHypothesis _ -> `InHypothesis + | pos -> pos + +let string_of_uri = UriManager.string_of_uri + +module OrderedMetadata = + struct + type t = MetadataTypes.metadata + let compare m1 m2 = (* ignore universes in Cic.Type sort *) + match (m1, m2) with + | `Sort (Cic.Type _, pos1), `Sort (Cic.Type _, pos2) -> + Pervasives.compare pos1 pos2 + | _ -> Pervasives.compare m1 m2 + end + +module MetadataSet = Set.Make (OrderedMetadata) +module UriManagerSet = UriManager.UriSet + +module S = MetadataSet + +let unopt = function Some x -> x | None -> assert false + +let incr_depth = function + | `MainConclusion (Some (Eq depth)) -> `MainConclusion (Some (Eq (depth + 1))) + | `MainHypothesis (Some (Eq depth)) -> `MainHypothesis (Some (Eq (depth + 1))) + | _ -> assert false + +let var_has_body uri = + match CicEnvironment.get_obj CicUniv.empty_ugraph uri with + | Cic.Variable (_, Some body, _, _, _), _ -> true + | _ -> false + +let compute_term pos term = + let rec aux (pos: position) set = function + | Cic.Var (uri, subst) when var_has_body uri -> + (* handles variables with body as constants *) + aux pos set (Cic.Const (uri, subst)) + | Cic.Rel _ + | Cic.Var _ -> + if is_main_pos pos then + S.add (`Rel (main_pos pos)) set + else + set + | Cic.Meta (_, local_context) -> + List.fold_left + (fun set context -> + match context with + | None -> set + | Some term -> aux (next_pos pos) set term) + set + local_context + | Cic.Sort sort -> + if is_main_pos pos then + S.add (`Sort (sort, main_pos pos)) set + else + set + | Cic.Implicit _ -> assert false + | Cic.Cast (term, ty) -> + (* TODO consider also ty? *) + aux pos set term + | Cic.Prod (_, source, target) -> + (match pos with + | `MainConclusion _ -> + let set = aux (`MainHypothesis (Some (Eq 0))) set source in + aux (incr_depth pos) set target + | `MainHypothesis _ -> + let set = aux `InHypothesis set source in + aux (incr_depth pos) set target + | `InConclusion + | `InHypothesis + | `InBody -> + let set = aux pos set source in + aux pos set target) + | Cic.Lambda (_, source, target) -> + (*assert (not (is_main_pos pos));*) + let set = aux (next_pos pos) set source in + aux (next_pos pos) set target + | Cic.LetIn (_, term, target) -> + if is_main_pos pos then + aux pos set (CicSubstitution.subst term target) + else + let set = aux pos set term in + aux pos set target + | Cic.Appl [] -> assert false + | Cic.Appl (hd :: tl) -> + let set = aux pos set hd in + List.fold_left + (fun set term -> aux (next_pos pos) set term) + set tl + | Cic.Const (uri, subst) -> + let set = S.add (`Obj (uri, pos)) set in + List.fold_left + (fun set (_, term) -> aux (next_pos pos) set term) + set subst + | Cic.MutInd (uri, typeno, subst) -> + let uri = UriManager.uri_of_uriref uri typeno None in + let set = S.add (`Obj (uri, pos)) set in + List.fold_left (fun set (_, term) -> aux (next_pos pos) set term) + set subst + | Cic.MutConstruct (uri, typeno, consno, subst) -> + let uri = UriManager.uri_of_uriref uri typeno (Some consno) in + let set = S.add (`Obj (uri, pos)) set in + List.fold_left (fun set (_, term) -> aux (next_pos pos) set term) + set subst + | Cic.MutCase (uri, _, outtype, term, pats) -> + let pos = next_pos pos in + let set = aux pos set term in + let set = aux pos set outtype in + List.fold_left (fun set term -> aux pos set term) set pats + | Cic.Fix (_, funs) -> + let pos = next_pos pos in + List.fold_left + (fun set (_, _, ty, body) -> + let set = aux pos set ty in + aux pos set body) + set funs + | Cic.CoFix (_, funs) -> + let pos = next_pos pos in + List.fold_left + (fun set (_, ty, body) -> + let set = aux pos set ty in + aux pos set body) + set funs + in + aux pos S.empty term + +module OrderedInt = +struct + type t = int + let compare = Pervasives.compare +end + +module IntSet = Set.Make (OrderedInt) + +let compute_metas term = + let rec aux in_hyp ((concl_metas, hyp_metas) as acc) cic = + match cic with + | Cic.Rel _ + | Cic.Sort _ + | Cic.Var _ -> acc + | Cic.Meta (no, local_context) -> + let acc = + if in_hyp then + (concl_metas, IntSet.add no hyp_metas) + else + (IntSet.add no concl_metas, hyp_metas) + in + List.fold_left + (fun set context -> + match context with + | None -> set + | Some term -> aux in_hyp set term) + acc + local_context + | Cic.Implicit _ -> assert false + | Cic.Cast (term, ty) -> + (* TODO consider also ty? *) + aux in_hyp acc term + | Cic.Prod (_, source, target) -> + if in_hyp then + let acc = aux in_hyp acc source in + aux in_hyp acc target + else + let acc = aux true acc source in + aux in_hyp acc target + | Cic.Lambda (_, source, target) -> + let acc = aux in_hyp acc source in + aux in_hyp acc target + | Cic.LetIn (_, term, target) -> + aux in_hyp acc (CicSubstitution.subst term target) + | Cic.Appl [] -> assert false + | Cic.Appl (hd :: tl) -> + let acc = aux in_hyp acc hd in + List.fold_left (fun acc term -> aux in_hyp acc term) acc tl + | Cic.Const (_, subst) + | Cic.MutInd (_, _, subst) + | Cic.MutConstruct (_, _, _, subst) -> + List.fold_left (fun acc (_, term) -> aux in_hyp acc term) acc subst + | Cic.MutCase (uri, _, outtype, term, pats) -> + let acc = aux in_hyp acc term in + let acc = aux in_hyp acc outtype in + List.fold_left (fun acc term -> aux in_hyp acc term) acc pats + | Cic.Fix (_, funs) -> + List.fold_left + (fun acc (_, _, ty, body) -> + let acc = aux in_hyp acc ty in + aux in_hyp acc body) + acc funs + | Cic.CoFix (_, funs) -> + List.fold_left + (fun acc (_, ty, body) -> + let acc = aux in_hyp acc ty in + aux in_hyp acc body) + acc funs + in + aux false (IntSet.empty, IntSet.empty) term + + (** type of inductiveType *) +let compute_type pos uri typeno (name, _, ty, constructors) = + let consno = ref 0 in + let type_metadata = + (UriManager.uri_of_uriref uri typeno None, name, (compute_term pos ty)) + in + let constructors_metadata = + List.map + (fun (name, term) -> + incr consno; + let uri = UriManager.uri_of_uriref uri typeno (Some !consno) in + (uri, name, (compute_term pos term))) + constructors + in + type_metadata :: constructors_metadata + +let compute_ind pos ~uri ~types = + let idx = ref ~-1 in + List.map (fun ty -> incr idx; compute_type pos uri !idx ty) types + +let compute (pos:position) ~body ~ty = + let type_metadata = compute_term pos ty in + let body_metadata = + match body with + | None -> S.empty + | Some body -> compute_term `InBody body + in + let uris = + S.fold + (fun metadata uris -> + match metadata with + | `Obj (uri, _) -> UriManagerSet.add uri uris + | _ -> uris) + type_metadata UriManagerSet.empty + in + S.union + (S.filter + (function + | `Obj (uri, _) when UriManagerSet.mem uri uris -> false + | _ -> true) + body_metadata) + type_metadata + +let depth_offset params = + let non p x = not (p x) in + List.length (List.filter (non var_has_body) params) + +let rec compute_var pos uri = + let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + | Cic.Variable (_, Some _, _, _, _) -> S.empty + | Cic.Variable (_, None, ty, params, _) -> + let var_metadata = + List.fold_left + (fun metadata uri -> + S.union metadata (compute_var (next_pos pos) uri)) + S.empty + params + in + (match pos with + | `MainHypothesis (Some (Eq 0)) -> + let pos = `MainHypothesis (Some (Eq (depth_offset params))) in + let ty_metadata = compute_term pos ty in + S.union ty_metadata var_metadata + | `InHypothesis -> + let ty_metadata = compute_term pos ty in + S.union ty_metadata var_metadata + | _ -> assert false) + | _ -> assert false + +let compute_obj uri = + let o, _ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + | Cic.Variable (_, body, ty, params, _) + | Cic.Constant (_, body, ty, params, _) -> + let pos = `MainConclusion (Some (Eq (depth_offset params))) in + let metadata = compute pos ~body ~ty in + let var_metadata = + List.fold_left + (fun metadata uri -> + S.union metadata (compute_var (`MainHypothesis (Some (Eq 0))) uri)) + S.empty + params + in + [ uri, + UriManager.name_of_uri uri, + S.union metadata var_metadata ] + | Cic.InductiveDefinition (types, params, _, _) -> + let pos = `MainConclusion(Some (Eq (depth_offset params))) in + let metadata = compute_ind pos ~uri ~types in + let var_metadata = + List.fold_left + (fun metadata uri -> + S.union metadata (compute_var (`MainHypothesis (Some (Eq 0))) uri)) + S.empty params + in + List.fold_left + (fun acc m -> + (List.map (fun (uri,name,md) -> (uri,name,S.union md var_metadata)) m) + @ acc) + [] metadata + | Cic.CurrentProof _ -> assert false + +let compute_obj uri = + List.map (fun (u, n, md) -> (u, n, S.elements md)) (compute_obj uri) + +let compute ~body ~ty = + S.elements (compute (`MainConclusion (Some (Eq 0))) ~body ~ty) + diff --git a/helm/software/components/metadata/metadataExtractor.mli b/helm/software/components/metadata/metadataExtractor.mli new file mode 100644 index 000000000..68af269a9 --- /dev/null +++ b/helm/software/components/metadata/metadataExtractor.mli @@ -0,0 +1,42 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +val compute: + body:Cic.term option -> + ty:Cic.term -> + MetadataTypes.metadata list + + (** @return tuples *) +val compute_obj: + UriManager.uri -> + (UriManager.uri * string * MetadataTypes.metadata list) list + +module IntSet: Set.S with type elt = int + + (** given a term, returns a pair of sets corresponding respectively to the set + * of meta numbers occurring in term's conclusion and the set of meta numbers + * occurring in term's hypotheses *) +val compute_metas: Cic.term -> IntSet.t * IntSet.t + diff --git a/helm/software/components/metadata/metadataPp.ml b/helm/software/components/metadata/metadataPp.ml new file mode 100644 index 000000000..373ec540f --- /dev/null +++ b/helm/software/components/metadata/metadataPp.ml @@ -0,0 +1,117 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open MetadataTypes + +let pp_relation r = + match r with + | Eq i -> sprintf "= %d" i + | Ge i -> sprintf ">= %d" i + | Gt i -> sprintf "> %d" i + | Le i -> sprintf "<= %d" i + | Lt i -> sprintf "< %d" i + +let pp_position = function + | `MainConclusion (Some d) -> sprintf "MainConclusion(%s)" (pp_relation d) + | `MainConclusion None -> sprintf "MainConclusion" + | `MainHypothesis (Some d) -> sprintf "MainHypothesis(%s)" (pp_relation d) + | `MainHypothesis None -> "MainHypothesis" + | `InConclusion -> "InConclusion" + | `InHypothesis -> "InHypothesis" + | `InBody -> "InBody" + +let pp_position_tag = function + | `MainConclusion _ -> mainconcl_pos + | `MainHypothesis _ -> mainhyp_pos + | `InConclusion -> inconcl_pos + | `InHypothesis -> inhyp_pos + | `InBody -> inbody_pos + +let columns_of_position pos = + match pos with + | `MainConclusion (Some (Eq d)) -> `String mainconcl_pos, `Int d + | `MainConclusion None -> `String mainconcl_pos, `Null + | `MainHypothesis (Some (Eq d)) -> `String mainhyp_pos, `Int d + | `MainHypothesis None -> `String mainhyp_pos, `Null + | `InConclusion -> `String inconcl_pos, `Null + | `InHypothesis -> `String inhyp_pos, `Null + | `InBody -> `String inbody_pos, `Null + | _ -> assert false + +(* +let metadata_ns = "http://www.cs.unibo.it/helm/schemas/schema-helm" +let uri_of_pos pos = String.concat "#" [metadata_ns; pp_position pos] +*) + +type t = [ `Int of int | `String of string | `Null ] + +let columns_of_metadata_aux ~about metadata = + let sort s = `String (CicPp.ppsort s) in + let source = `String (UriManager.string_of_uri about) in + let occurrence u = `String (UriManager.string_of_uri u) in + List.fold_left + (fun (sort_cols, rel_cols, obj_cols) metadata -> + match metadata with + | `Sort (s, p) -> + let (p, d) = columns_of_position (p :> position) in + [source; p; d; sort s] :: sort_cols, rel_cols, obj_cols + | `Rel p -> + let (p, d) = columns_of_position (p :> position) in + sort_cols, [source; p; d] :: rel_cols, obj_cols + | `Obj (o, p) -> + let (p, d) = columns_of_position p in + sort_cols, rel_cols, + [source; occurrence o; p; d] :: obj_cols) + ([], [], []) metadata + +let columns_of_metadata metadata = + List.fold_left + (fun (sort_cols, rel_cols, obj_cols) (uri, _, metadata) -> + let (s, r, o) = columns_of_metadata_aux ~about:uri metadata in + (List.append sort_cols s, List.append rel_cols r, List.append obj_cols o)) + ([], [], []) metadata + +let pp_constr = + function + | `Sort (sort, p) -> + sprintf "Sort %s; [%s]" + (CicPp.ppsort sort) (String.concat ";" (List.map pp_position p)) + | `Rel p -> sprintf "Rel [%s]" (String.concat ";" (List.map pp_position p)) + | `Obj (uri, p) -> sprintf "Obj %s; [%s]" + (UriManager.string_of_uri uri) (String.concat ";" (List.map pp_position p)) + +(* +let pp_columns ?(sep = "\n") (sort_cols, rel_cols, obj_cols) = + String.concat sep + ([ "Sort" ] @ List.map Dbi.sdebug (sort_cols :> Dbi.sql_t list list) @ + [ "Rel" ] @ List.map Dbi.sdebug (rel_cols :> Dbi.sql_t list list) @ + [ "Obj" ] @ List.map Dbi.sdebug (obj_cols :> Dbi.sql_t list list)) +*) + + diff --git a/helm/software/components/metadata/metadataPp.mli b/helm/software/components/metadata/metadataPp.mli new file mode 100644 index 000000000..cffb24c48 --- /dev/null +++ b/helm/software/components/metadata/metadataPp.mli @@ -0,0 +1,49 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(** metadata -> string *) + +val pp_position: MetadataTypes.position -> string +val pp_position_tag: MetadataTypes.position -> string +val pp_constr: MetadataTypes.constr -> string + +(** Pretty printer and OCamlDBI friendly interface *) + +type t = + [ `Int of int + | `String of string + | `Null ] + + (** @return columns for Sort, Rel, and Obj respectively *) +val columns_of_metadata: + (UriManager.uri * string * MetadataTypes.metadata list) list -> + t list list * t list list * t list list + +(* +val pp_columns: ?sep:string -> t list list * t list list * t list list -> string +*) + +val pp_relation: MetadataTypes.relation -> string + diff --git a/helm/software/components/metadata/metadataTypes.ml b/helm/software/components/metadata/metadataTypes.ml new file mode 100644 index 000000000..e186b377a --- /dev/null +++ b/helm/software/components/metadata/metadataTypes.ml @@ -0,0 +1,115 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let position_prefix = "http://www.cs.unibo.it/helm/schemas/schema-helm#" +(* let position_prefix = "" *) + +let inconcl_pos = position_prefix ^ "InConclusion" +let mainconcl_pos = position_prefix ^ "MainConclusion" +let mainhyp_pos = position_prefix ^ "MainHypothesis" +let inhyp_pos = position_prefix ^ "InHypothesis" +let inbody_pos = position_prefix ^ "InBody" + +type relation = + | Eq of int + | Le of int + | Lt of int + | Ge of int + | Gt of int + +type main_position = + [ `MainConclusion of relation option (* Pi depth *) + | `MainHypothesis of relation option (* Pi depth *) + ] + +type position = + [ main_position + | `InConclusion + | `InHypothesis + | `InBody + ] + +type pi_depth = int + +type metadata = + [ `Sort of Cic.sort * main_position + | `Rel of main_position + | `Obj of UriManager.uri * position + ] + +type constr = + [ `Sort of Cic.sort * main_position list + | `Rel of main_position list + | `Obj of UriManager.uri * position list + ] + +let constr_of_metadata: metadata -> constr = function + | `Sort (sort, pos) -> `Sort (sort, [pos]) + | `Rel pos -> `Rel [pos] + | `Obj (uri, pos) -> `Obj (uri, [pos]) + + (** the name of the tables in the DB *) +let sort_tbl_original = "refSort" +let rel_tbl_original = "refRel" +let obj_tbl_original = "refObj" +let name_tbl_original = "objectName" +let count_tbl_original = "count" +let hits_tbl_original = "hits" + + (** the names currently used *) +let sort_tbl_real = ref sort_tbl_original +let rel_tbl_real = ref rel_tbl_original +let obj_tbl_real = ref obj_tbl_original +let name_tbl_real = ref name_tbl_original +let count_tbl_real = ref count_tbl_original + + (** the exported symbols *) +let sort_tbl () = ! sort_tbl_real ;; +let rel_tbl () = ! rel_tbl_real ;; +let obj_tbl () = ! obj_tbl_real ;; +let name_tbl () = ! name_tbl_real ;; +let count_tbl () = ! count_tbl_real ;; + + (** to use the owned tables *) +let ownerize_tables owner = + sort_tbl_real := ( sort_tbl_original ^ "_" ^ owner) ; + rel_tbl_real := ( rel_tbl_original ^ "_" ^ owner) ; + obj_tbl_real := ( obj_tbl_original ^ "_" ^ owner) ; + name_tbl_real := ( name_tbl_original ^ "_" ^ owner); + count_tbl_real := ( count_tbl_original ^ "_" ^ owner) +;; + +let library_sort_tbl = sort_tbl_original +let library_rel_tbl = rel_tbl_original +let library_obj_tbl = obj_tbl_original +let library_name_tbl = name_tbl_original +let library_count_tbl = count_tbl_original +let library_hits_tbl = hits_tbl_original + +let are_tables_ownerized () = + sort_tbl () <> library_sort_tbl + diff --git a/helm/software/components/metadata/metadataTypes.mli b/helm/software/components/metadata/metadataTypes.mli new file mode 100644 index 000000000..f86ff84f5 --- /dev/null +++ b/helm/software/components/metadata/metadataTypes.mli @@ -0,0 +1,84 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +val inconcl_pos : string +val mainconcl_pos : string +val mainhyp_pos : string +val inhyp_pos : string +val inbody_pos : string + +type relation = + | Eq of int + | Le of int + | Lt of int + | Ge of int + | Gt of int + +type main_position = + [ `MainConclusion of relation option (* Pi depth *) + | `MainHypothesis of relation option (* Pi depth *) + ] + +type position = + [ main_position + | `InConclusion + | `InHypothesis + | `InBody + ] + +type pi_depth = int + +type metadata = + [ `Sort of Cic.sort * main_position + | `Rel of main_position + | `Obj of UriManager.uri * position + ] + +type constr = + [ `Sort of Cic.sort * main_position list + | `Rel of main_position list + | `Obj of UriManager.uri * position list + ] + +val constr_of_metadata: metadata -> constr + + (** invoke this function to set the current owner. Afterwards the functions + * below will return the name of the table of the set owner *) +val ownerize_tables : string -> unit +val are_tables_ownerized : unit -> bool + +val sort_tbl: unit -> string +val rel_tbl: unit -> string +val obj_tbl: unit -> string +val name_tbl: unit -> string +val count_tbl: unit -> string + +val library_sort_tbl: string +val library_rel_tbl: string +val library_obj_tbl: string +val library_name_tbl: string +val library_count_tbl: string +val library_hits_tbl: string + diff --git a/helm/software/components/metadata/sqlStatements.ml b/helm/software/components/metadata/sqlStatements.ml new file mode 100644 index 000000000..a08073965 --- /dev/null +++ b/helm/software/components/metadata/sqlStatements.ml @@ -0,0 +1,200 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf;; +type tbl = [ `RefObj| `RefSort| `RefRel| `ObjectName| `Hits| `Count] + +(* TABLES *) + +let sprintf_refObj_format name = [ +sprintf "CREATE TABLE %s ( + source varchar(255) binary not null, + h_occurrence varchar(255) binary not null, + h_position varchar(62) binary not null, + h_depth integer +);" name] + +let sprintf_refSort_format name = [ +sprintf "CREATE TABLE %s ( + source varchar(255) binary not null, + h_position varchar(62) binary not null, + h_depth integer not null, + h_sort varchar(5) binary not null +);" name] + +let sprintf_refRel_format name = [ +sprintf "CREATE TABLE %s ( + source varchar(255) binary not null, + h_position varchar(62) binary not null, + h_depth integer not null +);" name] + +let sprintf_objectName_format name = [ +sprintf "CREATE TABLE %s ( + source varchar(255) binary not null, + value varchar(255) binary not null +);" name] + +let sprintf_hits_format name = [ +sprintf "CREATE TABLE %s ( + source varchar(255) binary not null, + no integer not null +);" name] + +let sprintf_count_format name = [ +sprintf "CREATE TABLE %s ( + source varchar(255) binary unique not null, + conclusion smallint(6) not null, + hypothesis smallint(6) not null, + statement smallint(6) not null +);" name] + +let sprintf_refObj_drop name = [sprintf "DROP TABLE %s;" name] + +let sprintf_refSort_drop name = [sprintf "DROP TABLE %s;" name] + +let sprintf_refRel_drop name = [sprintf "DROP TABLE %s;" name] + +let sprintf_objectName_drop name = [sprintf "DROP TABLE %s;" name] + +let sprintf_hits_drop name = [sprintf "DROP TABLE %s;" name] + +let sprintf_count_drop name = [sprintf "DROP TABLE %s;" name] + +(* INDEXES *) + +let sprintf_refObj_index name = [ +sprintf "CREATE INDEX %s_index ON %s (source(219),h_occurrence(219),h_position);" name name; +sprintf "CREATE INDEX %s_occurrence ON %s (h_occurrence);" name name ] + +let sprintf_refSort_index name = [ +sprintf "CREATE INDEX %s_index ON %s (source,h_sort,h_position,h_depth);" name name] + +let sprintf_objectName_index name = [ +sprintf "CREATE INDEX %s_value ON %s (value);" name name] + +let sprintf_hits_index name = [ +sprintf "CREATE INDEX %s_source ON %s (source);" name name ; +sprintf "CREATE INDEX %s_no ON %s (no);" name name] + +let sprintf_count_index name = [ +sprintf "CREATE INDEX %s_conclusion ON %s (conclusion);" name name; +sprintf "CREATE INDEX %s_hypothesis ON %s (hypothesis);" name name; +sprintf "CREATE INDEX %s_statement ON %s (statement);" name name] + +let sprintf_refRel_index name = [ +sprintf "CREATE INDEX %s_index ON %s (source,h_position,h_depth);" name name] + +let sprintf_refObj_index_drop name = [ +sprintf "DROP INDEX %s_index ON %s;" name name ] + +let sprintf_refSort_index_drop name = [ +sprintf "DROP INDEX %s_index ON %s;" name name ] + +let sprintf_objectName_index_drop name = [ +sprintf "DROP INDEX %s_value ON %s;" name name] + +let sprintf_hits_index_drop name = [ +sprintf "DROP INDEX %s_source ON %s;" name name ; +sprintf "DROP INDEX %s_no ON %s;" name name] + +let sprintf_count_index_drop name = [ +sprintf "DROP INDEX %s_source ON %s;" name name; +sprintf "DROP INDEX %s_conclusion ON %s;" name name; +sprintf "DROP INDEX %s_hypothesis ON %s;" name name; +sprintf "DROP INDEX %s_statement ON %s;" name name] + +let sprintf_refRel_index_drop name = [ +sprintf "DROP INDEX %s_index ON %s;" name name] + +let sprintf_rename_table oldname newname = [ +sprintf "RENAME TABLE %s TO %s;" oldname newname +] + + +(* FUNCTIONS *) + +let get_table_format t named = + match t with + | `RefObj -> sprintf_refObj_format named + | `RefSort -> sprintf_refSort_format named + | `RefRel -> sprintf_refRel_format named + | `ObjectName -> sprintf_objectName_format named + | `Hits -> sprintf_hits_format named + | `Count -> sprintf_count_format named + +let get_index_format t named = + match t with + | `RefObj -> sprintf_refObj_index named + | `RefSort -> sprintf_refSort_index named + | `RefRel -> sprintf_refRel_index named + | `ObjectName -> sprintf_objectName_index named + | `Hits -> sprintf_hits_index named + | `Count -> sprintf_count_index named + +let get_table_drop t named = + match t with + | `RefObj -> sprintf_refObj_drop named + | `RefSort -> sprintf_refSort_drop named + | `RefRel -> sprintf_refRel_drop named + | `ObjectName -> sprintf_objectName_drop named + | `Hits -> sprintf_hits_drop named + | `Count -> sprintf_count_drop named + +let get_index_drop t named = + match t with + | `RefObj -> sprintf_refObj_index_drop named + | `RefSort -> sprintf_refSort_index_drop named + | `RefRel -> sprintf_refRel_index_drop named + | `ObjectName -> sprintf_objectName_index_drop named + | `Hits -> sprintf_hits_index_drop named + | `Count -> sprintf_count_index_drop named + +let create_tables l = + List.fold_left (fun s (name,table) -> s @ get_table_format table name) [] l + +let create_indexes l = + List.fold_left (fun s (name,table) -> s @ get_index_format table name) [] l + +let drop_tables l = + List.fold_left (fun s (name,table) -> s @ get_table_drop table name) [] l + +let drop_indexes l = + List.fold_left (fun s (name,table) -> s @ get_index_drop table name) [] l + +let rename_tables l = + List.fold_left (fun s (o,n) -> s @ sprintf_rename_table o n) [] l + +let fill_hits refObj hits = + [ sprintf + "INSERT INTO %s + SELECT h_occurrence, COUNT(source) + FROM %s + GROUP BY h_occurrence;" + hits refObj ] + + diff --git a/helm/software/components/metadata/sqlStatements.mli b/helm/software/components/metadata/sqlStatements.mli new file mode 100644 index 000000000..9f9af55ef --- /dev/null +++ b/helm/software/components/metadata/sqlStatements.mli @@ -0,0 +1,45 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** table shape kinds *) +type tbl = [ `RefObj| `RefSort| `RefRel| `ObjectName| `Hits| `Count] + +(** all functions below return either an SQL statement or a list of SQL + * statements. + * For functions taking as argument (string * tbl) list, the meaning is a list + * of pairs
    ; where the type specify the desired kind of + * table and name the desired name (e.g. create a `RefObj like table name + * refObj_NEW) *) + +val create_tables: (string * tbl) list -> string list +val create_indexes: (string * tbl) list -> string list +val drop_tables: (string * tbl) list -> string list +val drop_indexes: (string * tbl) list -> string list +val rename_tables: (string * string) list -> string list + +(** @param refObj name of the refObj table + * @param hits name of the hits table *) +val fill_hits: string -> string -> string list + diff --git a/helm/software/components/metadata/table_creator/.depend b/helm/software/components/metadata/table_creator/.depend new file mode 100644 index 000000000..1cf113d91 --- /dev/null +++ b/helm/software/components/metadata/table_creator/.depend @@ -0,0 +1,4 @@ +sql.cmo: sql.cmi +sql.cmx: sql.cmi +table_creator.cmo: sql.cmi +table_creator.cmx: sql.cmx diff --git a/helm/software/components/metadata/table_creator/Makefile b/helm/software/components/metadata/table_creator/Makefile new file mode 100644 index 000000000..c54e52d4a --- /dev/null +++ b/helm/software/components/metadata/table_creator/Makefile @@ -0,0 +1,35 @@ +REQUIRES = mysql helm-metadata + +INTERFACE_FILES = +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = \ + table_creator table_creator.opt table_destructor table_destructor.opt + +all: table_creator table_destructor + @echo -n +opt: table_creator.opt table_destructor.opt + @echo -n + +table_creator: table_creator.ml ../metadata.cma + @echo " OCAMLC $<" + @$(OCAMLFIND) ocamlc \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +table_destructor: table_creator + @ln -f $< $@ + +table_creator.opt: table_creator.ml ../metadata.cmxa + @echo " OCAMLOPT $<" + @$(OCAMLFIND) ocamlopt \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +table_destructor.opt: table_creator.opt + @ln -f $< $@ + +clean: + rm -f *.cm[iox] *.a *.o + rm -f table_creator table_creator.opt table_destructor table_destructor.opt + +include .depend +include ../../../Makefile.defs diff --git a/helm/software/components/metadata/table_creator/sync_db.sh b/helm/software/components/metadata/table_creator/sync_db.sh new file mode 100755 index 000000000..7b201382a --- /dev/null +++ b/helm/software/components/metadata/table_creator/sync_db.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +# sync metadata from a source database (usually "mowgli") to a target one +# (usually "matita") +# Created: Fri, 13 May 2005 13:50:16 +0200 zacchiro +# Last-Modified: Fri, 13 May 2005 13:50:16 +0200 zacchiro + +SOURCE_DB="mowgli" +TARGET_DB="matita" +MYSQL_FLAGS="-u helm -h localhost" + +MYSQL="mysql $MYSQL_FLAGS -f" +MYSQLDUMP="mysqldump $MYSQL_FLAGS" +MYSQLRESTORE="mysqlrestore $MYSQL_FLAGS" +TABLES=`./table_creator list all` +DUMP="${SOURCE_DB}_dump.gz" + +echo "Dumping source db $SOURCE_DB ..." +$MYSQLDUMP $SOURCE_DB $TABLES | gzip -c > $DUMP +echo "Destroying old tables in target db $TARGET_DB ..." +./table_destructor table all | $MYSQL $TARGET_DB +echo "Creating table structure in target db $TARGET_DB ..." +echo "Filling target db $TARGET_DB ..." +zcat $DUMP | $MYSQL $TARGET_DB +./table_creator index all | $MYSQL $TARGET_DB +rm $DUMP +echo "Done." + diff --git a/helm/software/components/metadata/table_creator/table_creator.ml b/helm/software/components/metadata/table_creator/table_creator.ml new file mode 100644 index 000000000..423edfb27 --- /dev/null +++ b/helm/software/components/metadata/table_creator/table_creator.ml @@ -0,0 +1,83 @@ + +open Printf + +let map = + (MetadataTypes.library_obj_tbl,`RefObj) :: + (MetadataTypes.library_sort_tbl,`RefSort) :: + (MetadataTypes.library_rel_tbl,`RefRel) :: + (MetadataTypes.library_name_tbl,`ObjectName) :: + (MetadataTypes.library_hits_tbl,`Hits) :: + (MetadataTypes.library_count_tbl,`Count) :: [] + +let usage argv_o = + prerr_string "\nusage:"; + prerr_string ("\t" ^ argv_o ^ " what tablename[=rename]\n"); + prerr_string ("\t" ^ argv_o ^ " what all\n\n"); + prerr_endline "what:"; + prerr_endline "\tlist\tlist table names"; + prerr_endline "\ttable\toutput SQL regarding tables"; + prerr_endline "\tindex\toutput SQL regarding indexes"; + prerr_endline "\tfill\toutput SQL filling tables (only \"hits\" supported)\n"; + prerr_string "known tables:\n\t"; + List.iter (fun (n,_) -> prerr_string (" " ^ n)) map; + prerr_endline "\n" + +let eq_RE = Str.regexp "=" + +let parse_args l = + List.map (fun s -> + let parts = Str.split eq_RE s in + let len = List.length parts in + assert (len = 1 || len = 2); + if len = 1 then (s,s) else (List.nth parts 0, List.nth parts 1)) + l + +let destructor_RE = Str.regexp "table_destructor\\(\\|\\.opt\\)$" + +let am_i_destructor () = + try + let _ = Str.search_forward destructor_RE Sys.argv.(0) 0 in true + with Not_found -> false + +let main () = + let len = Array.length Sys.argv in + if len < 3 then + begin + usage Sys.argv.(0); + exit 1 + end + else + begin + let tab,idx,fill = + if am_i_destructor () then + (SqlStatements.drop_tables,SqlStatements.drop_indexes, + fun _ t -> [sprintf "DELETE * FROM %s;" t]) + else + (SqlStatements.create_tables,SqlStatements.create_indexes, + SqlStatements.fill_hits) + in + let from = 2 in + let what = + match Sys.argv.(1) with + | "list" -> `List + | "index" -> `Index + | "table" -> `Table + | "fill" -> `Fill + | _ -> failwith "what must be one of \"index\", \"table\", \"fill\"" + in + let todo = Array.to_list (Array.sub Sys.argv from (len - from)) in + let todo = match todo with ["all"] -> List.map fst map | todo -> todo in + let todo = parse_args todo in + let todo = List.map (fun (x,name) -> name, (List.assoc x map)) todo in + match what with + | `Index -> print_endline (String.concat "\n" (idx todo)) + | `Table -> print_endline (String.concat "\n" (tab todo)) + | `Fill -> + print_endline (String.concat "\n" + (fill MetadataTypes.library_obj_tbl MetadataTypes.library_hits_tbl)) + | `List -> print_endline (String.concat " " (List.map fst map)) + end + +let _ = main () + + diff --git a/helm/software/components/registry/.depend b/helm/software/components/registry/.depend new file mode 100644 index 000000000..cf4f36b68 --- /dev/null +++ b/helm/software/components/registry/.depend @@ -0,0 +1,2 @@ +helm_registry.cmo: helm_registry.cmi +helm_registry.cmx: helm_registry.cmi diff --git a/helm/software/components/registry/.ocamlinit b/helm/software/components/registry/.ocamlinit new file mode 100644 index 000000000..b08e0ebfc --- /dev/null +++ b/helm/software/components/registry/.ocamlinit @@ -0,0 +1,4 @@ +#use "topfind";; +#require "helm-registry";; +open Helm_registry;; +load_from "tests/sample.xml";; diff --git a/helm/software/components/registry/Makefile b/helm/software/components/registry/Makefile new file mode 100644 index 000000000..bb9715ab4 --- /dev/null +++ b/helm/software/components/registry/Makefile @@ -0,0 +1,8 @@ + +PACKAGE = registry +INTERFACE_FILES = helm_registry.mli +IMPLEMENTATION_FILES = helm_registry.ml + +include ../../Makefile.defs +include ../Makefile.common + diff --git a/helm/software/components/registry/helm_registry.ml b/helm/software/components/registry/helm_registry.ml new file mode 100644 index 000000000..b7b3de11d --- /dev/null +++ b/helm/software/components/registry/helm_registry.ml @@ -0,0 +1,425 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let debug = false +let debug_print s = + if debug then prerr_endline ("Helm_registry debugging: " ^ (Lazy.force s)) + + (** *) + +let list_uniq l = + let rec aux last_element = function + | [] -> [] + | hd :: tl -> + (match last_element with + | Some elt when elt = hd -> aux last_element tl + | _ -> hd :: aux (Some hd) tl) + in + aux None l + +let starts_with prefix = +(* + let rex = Str.regexp (Str.quote prefix) in + fun s -> Str.string_match rex s 0 +*) + let prefix_len = String.length prefix in + fun s -> + try + String.sub s 0 prefix_len = prefix + with Invalid_argument _ -> false + +let hashtbl_keys tbl = Hashtbl.fold (fun k _ acc -> k :: acc) tbl [] +let hashtbl_pairs tbl = Hashtbl.fold (fun k v acc -> (k,v) :: acc) tbl [] + + (** *) + +exception Malformed_key of string +exception Key_not_found of string +exception Cyclic_definition of string +exception Type_error of string (* expected type, value, msg *) +exception Parse_error of string * int * int * string (* file, line, col, msg *) + + (* root XML tag: used by save_to, ignored by load_from *) +let root_tag = "helm_registry" + +let magic_size = 127 + +let backup_registry registry = Hashtbl.copy registry +let restore_registry backup registry = + Hashtbl.clear registry; + Hashtbl.iter (fun key value -> Hashtbl.add registry key value) backup + + (* as \\w but: + * - no sequences of '_' longer than 1 are permitted + *) +let valid_step_rex_raw = "[a-zA-Z0-9]+\\(_[a-z0A-Z-9]+\\)*" +let valid_key_rex_raw = + sprintf "%s\\(\\.%s\\)*" valid_step_rex_raw valid_step_rex_raw +let valid_key_rex = Str.regexp ("^" ^ valid_key_rex_raw ^ "$") +let interpolated_key_rex = Str.regexp ("\\$(" ^ valid_key_rex_raw ^ ")") +let dot_rex = Str.regexp "\\." +let spaces_rex = Str.regexp "[ \t\n\r]+" +let heading_spaces_rex = Str.regexp "^[ \t\n\r]+" +let margin_blanks_rex = + Str.regexp "^\\([ \t\n\r]*\\)\\([^ \t\n\r]*\\)\\([ \t\n\r]*\\)$" + +let strip_blanks s = Str.global_replace margin_blanks_rex "\\2" s + +let split s = + (* trailing blanks are removed per default by split *) + Str.split spaces_rex (Str.global_replace heading_spaces_rex "" s) +let merge l = String.concat " " l + +let handle_type_error f x = + try f x with exn -> raise (Type_error (Printexc.to_string exn)) + + (** marshallers/unmarshallers *) +let string x = x +let int = handle_type_error int_of_string +let float = handle_type_error float_of_string +let bool = handle_type_error bool_of_string +let of_string x = x +let of_int = handle_type_error string_of_int +let of_float = handle_type_error string_of_float +let of_bool = handle_type_error string_of_bool + + (* escapes for xml configuration file *) +let (escape, unescape) = + let (in_enc, out_enc) = (`Enc_utf8, `Enc_utf8) in + (Netencoding.Html.encode ~in_enc ~out_enc (), + Netencoding.Html.decode ~in_enc ~out_enc ~entity_base:`Xml ()) + +let key_is_valid key = + if not (Str.string_match valid_key_rex key 0) then + raise (Malformed_key key) + +let set' ?(replace=false) registry ~key ~value = + debug_print (lazy(sprintf "Setting (replace: %b) %s = %s" replace key value)); + key_is_valid key; + let add_fun = if replace then Hashtbl.replace else Hashtbl.add in + add_fun registry key value + +let unset registry = Hashtbl.remove registry + +let env_var_of_key = Str.global_replace dot_rex "__" + +let singleton = function + | [] -> + raise (Type_error ("empty list value found where singleton was expected")) + | hd :: _ -> hd + +let get registry key = + let rec aux stack key = + key_is_valid key; + if List.mem key stack then begin + let msg = (String.concat " -> " (List.rev stack)) ^ " -> " ^ key in + raise (Cyclic_definition msg) + end; + (* internal value *) + let registry_values = List.rev (Hashtbl.find_all registry key) in + let env_value = (* environment value *) + try + Some (Sys.getenv (env_var_of_key key)) + with Not_found -> None + in + let values = (* resulting value *) + match registry_values, env_value with + | _, Some env -> [env] + | [], None -> + (try + [ Sys.getenv key ] + with Not_found -> raise (Key_not_found key)) + | values, None -> values + in + List.map (interpolate (key :: stack)) values + and interpolate stack value = + Str.global_substitute interpolated_key_rex + (fun s -> + let matched = Str.matched_string s in + (* "$(var)" -> "var" *) + let key = String.sub matched 2 (String.length matched - 3) in + singleton (aux stack key)) + value + in + List.map strip_blanks (aux [] key) + +let has registry key = Hashtbl.mem registry key + +let get_typed registry unmarshaller key = + let value = singleton (get registry key) in + unmarshaller value + +let set_typed registry marshaller ~key ~value = + set' ~replace:true registry ~key ~value:(marshaller value) + +let get_opt registry unmarshaller key = + try + Some (unmarshaller (singleton (get registry key))) + with Key_not_found _ -> None + +let get_opt_default registry unmarshaller ~default key = + match get_opt registry unmarshaller key with + | None -> default + | Some v -> v + +let set_opt registry marshaller ~key ~value = + match value with + | None -> unset registry key + | Some value -> set' ~replace:true registry ~key ~value:(marshaller value) + +let get_list registry unmarshaller key = + try + List.map unmarshaller (get registry key) + with Key_not_found _ -> [] + +let get_pair registry fst_unmarshaller snd_unmarshaller key = + let v = singleton (get registry key) in + match Str.split spaces_rex v with + | [fst; snd] -> fst_unmarshaller fst, snd_unmarshaller snd + | _ -> raise (Type_error "not a pair") + +let set_list registry marshaller ~key ~value = + Hashtbl.remove registry key; + List.iter + (fun v -> set' ~replace:false registry ~key ~value:(marshaller v)) + value + +type xml_tree = + | Cdata of string + | Element of string * (string * string) list * xml_tree list + +let dot_RE = Str.regexp "\\." + +let xml_tree_of_registry registry = + let has_child name elements = + List.exists + (function + | Element (_, ["name", name'], _) when name = name' -> true + | _ -> false) + elements + in + let rec get_child name = function + | [] -> assert false + | (Element (_, ["name", name'], _) as child) :: tl when name = name' -> + child, tl + | hd :: tl -> + let child, rest = get_child name tl in + child, hd :: rest + in + let rec add_key path value tree = + match path, tree with + | [key], Element (name, attrs, children) -> + Element (name, attrs, + Element ("key", ["name", key], + [Cdata (strip_blanks value)]) :: children) + | dir :: path, Element (name, attrs, children) -> + if has_child dir children then + let child, rest = get_child dir children in + Element (name, attrs, add_key path value child :: rest) + else + Element (name, attrs, + ((add_key path value (Element ("section", ["name", dir], []))) + :: children)) + | _ -> assert false + in + Hashtbl.fold + (fun k v tree -> add_key ((Str.split dot_RE k)) v tree) + registry + (Element (root_tag, [], [])) + +let rec stream_of_xml_tree = function + | Cdata s -> Xml.xml_cdata s + | Element (name, attrs, children) -> + Xml.xml_nempty name + (List.map (fun (n, v) -> (None, n, v)) attrs) + (stream_of_xml_trees children) +and stream_of_xml_trees = function + | [] -> [< >] + | hd :: tl -> [< stream_of_xml_tree hd; stream_of_xml_trees tl >] + +let save_to registry fname = + let token_stream = stream_of_xml_tree (xml_tree_of_registry registry) in + let oc = open_out fname in + Xml.pp_to_outchan token_stream oc; + close_out oc + +let rec load_from_absolute ?path registry fname = + let _path = ref (match path with None -> [] | Some p -> p)in + (*
    elements entered so far *) + let in_key = ref false in (* have we entered a element? *) + let cdata = ref "" in (* collected cdata (inside *) + let push_path name = _path := name :: !_path in + let pop_path () = _path := List.tl !_path in + let start_element tag attrs = + match tag, attrs with + | "section", ["name", name] -> push_path name + | "key", ["name", name] -> in_key := true; push_path name + | "helm_registry", _ -> () + | "include", ["href", fname] -> + debug_print (lazy ("including file " ^ fname)); + load_from_absolute ~path:!_path registry fname + | tag, _ -> + raise (Parse_error (fname, ~-1, ~-1, + (sprintf "unexpected element <%s> or wrong attribute set" tag))) + in + let end_element tag = + match tag with + | "section" -> pop_path () + | "key" -> + let key = String.concat "." (List.rev !_path) in + set' registry ~key ~value:!cdata; + cdata := ""; + in_key := false; + pop_path () + | "include" | "helm_registry" -> () + | _ -> assert false + in + let character_data text = + if !in_key then cdata := !cdata ^ text + in + let callbacks = { + XmlPushParser.default_callbacks with + XmlPushParser.start_element = Some start_element; + XmlPushParser.end_element = Some end_element; + XmlPushParser.character_data = Some character_data; + } in + let xml_parser = XmlPushParser.create_parser callbacks in + let backup = backup_registry registry in +(* if path = None then Hashtbl.clear registry; *) + try + XmlPushParser.parse xml_parser (`File fname) + with exn -> + restore_registry backup registry; + raise exn + +let load_from registry ?path fname = + if Filename.is_relative fname then begin + let no_file_found = ref true in + let path = + match path with + | Some path -> path (* path given as argument *) + | None -> [ Sys.getcwd () ] (* no path given, try with cwd *) + in + List.iter + (fun dir -> + let conffile = dir ^ "/" ^ fname in + if Sys.file_exists conffile then begin + no_file_found := false; + load_from_absolute registry conffile + end) + path; + if !no_file_found then + failwith (sprintf + "Helm_registry.init: no configuration file named %s in [ %s ]" + fname (String.concat "; " path)) + end else + load_from_absolute registry fname + +let fold registry ?prefix ?(interpolate = true) f init = + let value_of k v = + if interpolate then singleton (get registry k) else strip_blanks v + in + match prefix with + | None -> Hashtbl.fold (fun k v acc -> f acc k (value_of k v)) registry init + | Some s -> + let key_matches = starts_with (s ^ ".") in + let rec fold_filter acc = function + | [] -> acc + | (k,v) :: tl when key_matches k -> + fold_filter (f acc k (value_of k v)) tl + | _ :: tl -> fold_filter acc tl + in + fold_filter init (hashtbl_pairs registry) + +let iter registry ?prefix ?interpolate f = + fold registry ?prefix ?interpolate (fun _ k v -> f k v) () +let to_list registry ?prefix ?interpolate () = + fold registry ?prefix ?interpolate (fun acc k v -> (k, v) :: acc) [] + +let ls registry prefix = + let prefix = prefix ^ "." in + let prefix_len = String.length prefix in + let key_matches = starts_with prefix in + let matching_keys = (* collect matching keys' _postfixes_ *) + fold registry + (fun acc key _ -> + if key_matches key then + String.sub key prefix_len (String.length key - prefix_len) :: acc + else + acc) + [] + in + let (sections, keys) = + List.fold_left + (fun (sections, keys) postfix -> + match Str.split dot_rex postfix with + | [key] -> (sections, key :: keys) + | hd_key :: _ -> (* length > 1 => nested section found *) + (hd_key :: sections, keys) + | _ -> assert false) + ([], []) matching_keys + in + (list_uniq (List.sort Pervasives.compare sections), keys) + +(** {2 API implementation} + * functional methods above are wrapped so that they work on a default + * (imperative) registry*) + +let default_registry = Hashtbl.create magic_size + +let get key = singleton (get default_registry key) +let set = set' ~replace:true default_registry +let has = has default_registry +let fold ?prefix ?interpolate f init = + fold default_registry ?prefix ?interpolate f init +let iter = iter default_registry +let to_list = to_list default_registry +let ls = ls default_registry +let get_typed unmarshaller = get_typed default_registry unmarshaller +let get_opt unmarshaller = get_opt default_registry unmarshaller +let get_opt_default unmarshaller = get_opt_default default_registry unmarshaller +let get_list unmarshaller = get_list default_registry unmarshaller +let get_pair unmarshaller = get_pair default_registry unmarshaller +let set_typed marshaller = set_typed default_registry marshaller +let set_opt unmarshaller = set_opt default_registry unmarshaller +let set_list marshaller = set_list default_registry marshaller +let unset = unset default_registry +let save_to = save_to default_registry +let load_from = load_from default_registry +let clear () = Hashtbl.clear default_registry + +let get_string = get_typed string +let get_int = get_typed int +let get_float = get_typed float +let get_bool = get_typed bool +let set_string = set_typed of_string +let set_int = set_typed of_int +let set_float = set_typed of_float +let set_bool = set_typed of_bool + diff --git a/helm/software/components/registry/helm_registry.mli b/helm/software/components/registry/helm_registry.mli new file mode 100644 index 000000000..1ef1aa3b7 --- /dev/null +++ b/helm/software/components/registry/helm_registry.mli @@ -0,0 +1,199 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** Configuration repository for HELM applications. + * + * ++ Keys format ++ + * + * key ::= path + * path ::= component ( '.' component )* + * component ::= ( alpha | num | '_' )+ + * # with the only exception that sequences of '_' longer than 1 aren't valid + * # components + * + * Suggested usage .: + * e.g. gTopLevel.prooffile, http_getter.port, ... + * + * ++ Configuration file example ++ + * + * gTopLevel.prooffile = "/home/zack/prooffile" + * http_getter.port = "58080" + * + * ++ Environment variable override ++ + * + * each key has an associated environment variable name. At runtime (i.e. when + * "get" requests are performed) a variable with this name will be looked for, + * if it's defined it will override the value present (or absent) in the + * registry. + * Environment variables are _not_ considered when saving the configuration to + * a configuration file (via "save_to" function below) . + * + * Mapping between keys and environment variables is as follows: + * - each "." is converted to "__" + * E.g.: my.Foo_iSH.Application -> my__Foo_iSH__Application + * + * ++ Variable interpolation ++ + * + * Interpolation is supported with the following syntax: + * + * foo.bar = "quux" + * foo.baz = $(foo.bar)/baz + *) + + (** raised when a looked up key can't be found + * @param key looked up key *) +exception Key_not_found of string + + (** raised when a cyclic definitions is found, e.g. after + * Helm_registry.set "a" "$b" + * Helm_registry.set "b" "$a" + * @param msg brief description of the definition cycle *) +exception Cyclic_definition of string + + (** raised when a looked up key doesn't have the required type, parameter is + * an error message *) +exception Type_error of string + + (** raised when a malformed key is encountered + * @param key malformed key *) +exception Malformed_key of string + + (** raised when an error is encountered while parsing a configuration file + * @param fname file name + * @param line line number + * @param col column number + * @param msg error description + *) +exception Parse_error of string * int * int * string + +(** {2 Generic untyped interface} + * Using the functions below this module could be used as a repository of + * key/value pairs *) + + (** lookup key in registry with environment variable override *) +val get: string -> string +val set: key:string -> value:string -> unit +val has: string -> bool + + (** remove a key from the current environment, next get over this key will + * raise Key_not_found until the key will be redefined *) +val unset: string -> unit + + (** @param interpolate defaults to true *) +val fold: + ?prefix:string -> ?interpolate:bool -> + ('a -> string -> string -> 'a) -> 'a -> 'a + + (** @param interpolate defaults to true *) +val iter: + ?prefix:string -> ?interpolate:bool -> + (string -> string -> unit) -> unit + + (** @param interpolate defaults to true *) +val to_list: + ?prefix:string -> ?interpolate:bool -> + unit -> (string * string) list + + (** @param prefix key representing the section whose contents should be listed + * @return section list * key list *) +val ls: string -> string list * string list + +(** {2 Typed interface} + * Three basic types are supported: strings, int and strings list. Strings + * correspond literally to what is written inside double quotes; int to the + * parsing of an integer number from ; strings list to the splitting at blanks + * of it (heading and trailing blanks are removed before splitting) *) + +(** {3 Unmarshallers} *) + +val string: string -> string +val int: string -> int +val float: string -> float +val bool: string -> bool + +(** {3 Typed getters} *) + + (** like get, with an additional unmarshaller + * @param unmarshaller conversion function from string to the desired type. + * Use one of the above unmarshallers *) +val get_typed: (string -> 'a) -> string -> 'a + +val get_opt: (string -> 'a) -> string -> 'a option +val get_opt_default: (string -> 'a) -> default:'a -> string -> 'a + + (** never fails with Key_not_found, instead return the empty list *) +val get_list: (string -> 'a) -> string -> 'a list + + (** decode values which are blank separated list of values, of length 2 *) +val get_pair: (string -> 'a) -> (string -> 'b) -> string -> 'a * 'b + +(** {4 Shorthands} *) + +val get_string: string -> string +val get_int: string -> int +val get_float: string -> float +val get_bool: string -> bool + +(** {3 Marshallers} *) + +val of_string: string -> string +val of_int: int -> string +val of_float: float -> string +val of_bool: bool -> string + +(** {3 Typed setters} *) + + (** like set, with an additional marshaller + * @param marshaller conversion function to string. + * Use one of the above marshallers *) +val set_typed: ('a -> string) -> key:string -> value:'a -> unit + +val set_opt: ('a -> string) -> key:string -> value:'a option -> unit +val set_list: ('a -> string) -> key:string -> value:'a list -> unit + +(** {4 Shorthands} *) + +val set_string: key:string -> value:string -> unit +val set_int: key:string -> value:int -> unit +val set_float: key:string -> value:float -> unit +val set_bool: key:string -> value:bool -> unit + +(** {2 Persistent configuration} *) + + (** @param fname file to which save current configuration *) +val save_to: string -> unit + + (** @param fname file from which load new configuration. If it's an absolute + * file name "path" argument is ignored. + * Otherwise given file name is looked up in each directory member of the + * given path. Each matching file is loaded overriding previous settings. If + * no path is given a default path composed of just the current working + * directory is used. + *) +val load_from: ?path:string list -> string -> unit + + (** removes all keys *) +val clear: unit -> unit + diff --git a/helm/software/components/registry/test.ml b/helm/software/components/registry/test.ml new file mode 100644 index 000000000..d0b91a28c --- /dev/null +++ b/helm/software/components/registry/test.ml @@ -0,0 +1,32 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf;; +Helm_registry.load_from Sys.argv.(1); +Helm_registry.iter ~interpolate:false (fun k v -> printf "%s = %s\n" k v); +Helm_registry.save_to Sys.argv.(2) + diff --git a/helm/software/components/registry/tests/sample.xml b/helm/software/components/registry/tests/sample.xml new file mode 100644 index 000000000..b0edbdae0 --- /dev/null +++ b/helm/software/components/registry/tests/sample.xml @@ -0,0 +1,34 @@ + + +
    + file:///home/zack/miohelm/objects + file:///home/zack/miohelm/objects +
    +
    + remote + http://localhost:58081 +
    +
    + yes +
    +
    + +
    +
    + yes +
    +
    + debian + 1 + false + 2.5 + 11 + 13 + 17 + 19 + 19 23.2 +
    +
    + http://localhost:58080/ +
    +     diff --git a/helm/software/components/registry/tests/sample_include.xml b/helm/software/components/registry/tests/sample_include.xml new file mode 100644 index 000000000..8a6851998 --- /dev/null +++ b/helm/software/components/registry/tests/sample_include.xml @@ -0,0 +1,15 @@ + +
    + aaa + bbb +
    +
    + quux +
    + /public/helm_library + $(triciclo.basedir)/constanttype + $(triciclo.basedir)/environment + $(triciclo.basedir)/innertypes + $(triciclo.basedir)/currentproof + $(triciclo.basedir)/currentprooftype +     diff --git a/helm/software/components/tactics/.depend b/helm/software/components/tactics/.depend new file mode 100644 index 000000000..4769431a4 --- /dev/null +++ b/helm/software/components/tactics/.depend @@ -0,0 +1,164 @@ +proofEngineHelpers.cmi: proofEngineTypes.cmi +continuationals.cmi: proofEngineTypes.cmi +tacticals.cmi: proofEngineTypes.cmi continuationals.cmi +reductionTactics.cmi: proofEngineTypes.cmi +proofEngineStructuralRules.cmi: proofEngineTypes.cmi +primitiveTactics.cmi: proofEngineTypes.cmi +metadataQuery.cmi: proofEngineTypes.cmi +paramodulation/inference.cmi: paramodulation/utils.cmi proofEngineTypes.cmi +paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \ + paramodulation/inference.cmi +paramodulation/indexing.cmi: paramodulation/utils.cmi \ + paramodulation/inference.cmi paramodulation/equality_indexing.cmi +paramodulation/saturation.cmi: proofEngineTypes.cmi +variousTactics.cmi: proofEngineTypes.cmi +autoTactic.cmi: proofEngineTypes.cmi +introductionTactics.cmi: proofEngineTypes.cmi +eliminationTactics.cmi: proofEngineTypes.cmi +negationTactics.cmi: proofEngineTypes.cmi +equalityTactics.cmi: proofEngineTypes.cmi +discriminationTactics.cmi: proofEngineTypes.cmi +inversion.cmi: proofEngineTypes.cmi +ring.cmi: proofEngineTypes.cmi +fourierR.cmi: proofEngineTypes.cmi +fwdSimplTactic.cmi: proofEngineTypes.cmi +statefulProofEngine.cmi: proofEngineTypes.cmi +tactics.cmi: proofEngineTypes.cmi +proofEngineTypes.cmo: proofEngineTypes.cmi +proofEngineTypes.cmx: proofEngineTypes.cmi +proofEngineHelpers.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi +proofEngineHelpers.cmx: proofEngineTypes.cmx proofEngineHelpers.cmi +proofEngineReduction.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi \ + proofEngineReduction.cmi +proofEngineReduction.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \ + proofEngineReduction.cmi +continuationals.cmo: proofEngineTypes.cmi continuationals.cmi +continuationals.cmx: proofEngineTypes.cmx continuationals.cmi +tacticals.cmo: proofEngineTypes.cmi continuationals.cmi tacticals.cmi +tacticals.cmx: proofEngineTypes.cmx continuationals.cmx tacticals.cmi +reductionTactics.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \ + proofEngineHelpers.cmi reductionTactics.cmi +reductionTactics.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \ + proofEngineHelpers.cmx reductionTactics.cmi +proofEngineStructuralRules.cmo: proofEngineTypes.cmi \ + proofEngineStructuralRules.cmi +proofEngineStructuralRules.cmx: proofEngineTypes.cmx \ + proofEngineStructuralRules.cmi +primitiveTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ + proofEngineHelpers.cmi primitiveTactics.cmi +primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ + proofEngineHelpers.cmx primitiveTactics.cmi +hashtbl_equiv.cmo: hashtbl_equiv.cmi +hashtbl_equiv.cmx: hashtbl_equiv.cmi +metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ + hashtbl_equiv.cmi metadataQuery.cmi +metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ + hashtbl_equiv.cmx metadataQuery.cmi +paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi +paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi +paramodulation/inference.cmo: paramodulation/utils.cmi \ + proofEngineReduction.cmi proofEngineHelpers.cmi metadataQuery.cmi \ + paramodulation/inference.cmi +paramodulation/inference.cmx: paramodulation/utils.cmx \ + proofEngineReduction.cmx proofEngineHelpers.cmx metadataQuery.cmx \ + paramodulation/inference.cmi +paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \ + paramodulation/inference.cmi paramodulation/equality_indexing.cmi +paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \ + paramodulation/inference.cmx paramodulation/equality_indexing.cmi +paramodulation/indexing.cmo: paramodulation/utils.cmi \ + paramodulation/inference.cmi paramodulation/equality_indexing.cmi \ + paramodulation/indexing.cmi +paramodulation/indexing.cmx: paramodulation/utils.cmx \ + paramodulation/inference.cmx paramodulation/equality_indexing.cmx \ + paramodulation/indexing.cmi +paramodulation/saturation.cmo: paramodulation/utils.cmi reductionTactics.cmi \ + proofEngineTypes.cmi proofEngineReduction.cmi primitiveTactics.cmi \ + paramodulation/inference.cmi paramodulation/indexing.cmi \ + paramodulation/saturation.cmi +paramodulation/saturation.cmx: paramodulation/utils.cmx reductionTactics.cmx \ + proofEngineTypes.cmx proofEngineReduction.cmx primitiveTactics.cmx \ + paramodulation/inference.cmx paramodulation/indexing.cmx \ + paramodulation/saturation.cmi +variousTactics.cmo: tacticals.cmi proofEngineTypes.cmi \ + proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ + variousTactics.cmi +variousTactics.cmx: tacticals.cmx proofEngineTypes.cmx \ + proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ + variousTactics.cmi +autoTactic.cmo: paramodulation/saturation.cmi proofEngineTypes.cmi \ + proofEngineHelpers.cmi primitiveTactics.cmi metadataQuery.cmi \ + paramodulation/inference.cmi autoTactic.cmi +autoTactic.cmx: paramodulation/saturation.cmx proofEngineTypes.cmx \ + proofEngineHelpers.cmx primitiveTactics.cmx metadataQuery.cmx \ + paramodulation/inference.cmx autoTactic.cmi +introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ + introductionTactics.cmi +introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ + introductionTactics.cmi +eliminationTactics.cmo: tacticals.cmi proofEngineTypes.cmi \ + proofEngineStructuralRules.cmi proofEngineHelpers.cmi \ + primitiveTactics.cmi eliminationTactics.cmi +eliminationTactics.cmx: tacticals.cmx proofEngineTypes.cmx \ + proofEngineStructuralRules.cmx proofEngineHelpers.cmx \ + primitiveTactics.cmx eliminationTactics.cmi +negationTactics.cmo: variousTactics.cmi tacticals.cmi proofEngineTypes.cmi \ + primitiveTactics.cmi eliminationTactics.cmi negationTactics.cmi +negationTactics.cmx: variousTactics.cmx tacticals.cmx proofEngineTypes.cmx \ + primitiveTactics.cmx eliminationTactics.cmx negationTactics.cmi +equalityTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ + proofEngineStructuralRules.cmi proofEngineReduction.cmi \ + proofEngineHelpers.cmi primitiveTactics.cmi introductionTactics.cmi \ + equalityTactics.cmi +equalityTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ + proofEngineStructuralRules.cmx proofEngineReduction.cmx \ + proofEngineHelpers.cmx primitiveTactics.cmx introductionTactics.cmx \ + equalityTactics.cmi +discriminationTactics.cmo: tacticals.cmi reductionTactics.cmi \ + proofEngineTypes.cmi primitiveTactics.cmi introductionTactics.cmi \ + equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi +discriminationTactics.cmx: tacticals.cmx reductionTactics.cmx \ + proofEngineTypes.cmx primitiveTactics.cmx introductionTactics.cmx \ + equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmi +inversion.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineReduction.cmi \ + proofEngineHelpers.cmi primitiveTactics.cmi equalityTactics.cmi \ + inversion.cmi +inversion.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineReduction.cmx \ + proofEngineHelpers.cmx primitiveTactics.cmx equalityTactics.cmx \ + inversion.cmi +ring.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineStructuralRules.cmi \ + primitiveTactics.cmi equalityTactics.cmi eliminationTactics.cmi ring.cmi +ring.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineStructuralRules.cmx \ + primitiveTactics.cmx equalityTactics.cmx eliminationTactics.cmx ring.cmi +fourier.cmo: fourier.cmi +fourier.cmx: fourier.cmi +fourierR.cmo: tacticals.cmi ring.cmi reductionTactics.cmi \ + proofEngineTypes.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ + fourier.cmi equalityTactics.cmi fourierR.cmi +fourierR.cmx: tacticals.cmx ring.cmx reductionTactics.cmx \ + proofEngineTypes.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ + fourier.cmx equalityTactics.cmx fourierR.cmi +fwdSimplTactic.cmo: tacticals.cmi proofEngineTypes.cmi \ + proofEngineStructuralRules.cmi proofEngineHelpers.cmi \ + primitiveTactics.cmi fwdSimplTactic.cmi +fwdSimplTactic.cmx: tacticals.cmx proofEngineTypes.cmx \ + proofEngineStructuralRules.cmx proofEngineHelpers.cmx \ + primitiveTactics.cmx fwdSimplTactic.cmi +history.cmo: history.cmi +history.cmx: history.cmi +statefulProofEngine.cmo: proofEngineTypes.cmi history.cmi \ + statefulProofEngine.cmi +statefulProofEngine.cmx: proofEngineTypes.cmx history.cmx \ + statefulProofEngine.cmi +tactics.cmo: variousTactics.cmi tacticals.cmi paramodulation/saturation.cmi \ + ring.cmi reductionTactics.cmi proofEngineStructuralRules.cmi \ + primitiveTactics.cmi negationTactics.cmi inversion.cmi \ + introductionTactics.cmi fwdSimplTactic.cmi fourierR.cmi \ + equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi \ + autoTactic.cmi tactics.cmi +tactics.cmx: variousTactics.cmx tacticals.cmx paramodulation/saturation.cmx \ + ring.cmx reductionTactics.cmx proofEngineStructuralRules.cmx \ + primitiveTactics.cmx negationTactics.cmx inversion.cmx \ + introductionTactics.cmx fwdSimplTactic.cmx fourierR.cmx \ + equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmx \ + autoTactic.cmx tactics.cmi diff --git a/helm/software/components/tactics/Makefile b/helm/software/components/tactics/Makefile new file mode 100644 index 000000000..0b8f4fb69 --- /dev/null +++ b/helm/software/components/tactics/Makefile @@ -0,0 +1,36 @@ +PACKAGE = tactics + +INTERFACE_FILES = \ + proofEngineTypes.mli \ + proofEngineHelpers.mli proofEngineReduction.mli \ + continuationals.mli \ + tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \ + primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \ + paramodulation/utils.mli \ + paramodulation/inference.mli\ + paramodulation/equality_indexing.mli\ + paramodulation/indexing.mli \ + paramodulation/saturation.mli \ + variousTactics.mli autoTactic.mli \ + introductionTactics.mli eliminationTactics.mli negationTactics.mli \ + equalityTactics.mli discriminationTactics.mli inversion.mli ring.mli \ + fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \ + statefulProofEngine.mli tactics.mli + +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + + +all: + +tactics.mli: tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli + @echo " OCAMLC -i $< > $@" + $(H)echo "(* GENERATED FILE, DO NOT EDIT *)" > $@ + $(H)$(OCAMLC) -I paramodulation -i $< >> $@ + +STATS_EXCLUDE = tactics.mli + +include ../../Makefile.defs +include ../Makefile.common + +OCAMLOPTIONS+= -I paramodulation +OCAMLDEPOPTIONS+= -I paramodulation diff --git a/helm/software/components/tactics/autoTactic.ml b/helm/software/components/tactics/autoTactic.ml new file mode 100644 index 000000000..42df90768 --- /dev/null +++ b/helm/software/components/tactics/autoTactic.ml @@ -0,0 +1,349 @@ +(* 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/. + *) + +(* $Id$ *) + + let debug = false + let debug_print s = if debug then prerr_endline (Lazy.force s) + +(* let debug_print = fun _ -> () *) + +(* Profiling code +let new_experimental_hint = + let profile = CicUtil.profile "new_experimental_hint" in + fun ~dbd ~facts ?signature ~universe status -> + profile.profile (MetadataQuery.new_experimental_hint ~dbd ~facts ?signature ~universe) status +*) let new_experimental_hint = MetadataQuery.new_experimental_hint + +(* In this versions of auto_tac we maintain an hash table of all inspected + goals. We assume that the context is invariant for application. + To this aim, it is essential to sall hint_verbose, that in turns calls + apply_verbose. *) + +type exitus = + No of int + | Yes of Cic.term * int + | NotYetInspected + +let inspected_goals = Hashtbl.create 503;; + +let search_theorems_in_context status = + let (proof, goal) = status in + let module C = Cic in + let module R = CicReduction in + let module S = CicSubstitution in + let module PET = ProofEngineTypes in + let module PT = PrimitiveTactics in + let _,metasenv,_,_ = proof in + let _,context,ty = CicUtil.lookup_meta goal metasenv in + let rec find n = function + | [] -> [] + | hd::tl -> + let res = + (* we should check that the hypothesys has not been cleared *) + if List.nth context (n-1) = None then + None + else + try + let (subst,(proof, goal_list)) = + PT.apply_tac_verbose ~term:(C.Rel n) status + in + (* + let goal_list = + List.stable_sort (compare_goal_list proof) goal_list in + *) + Some (subst,(proof, goal_list)) + with + PET.Fail _ -> None + in + (match res with + | Some res -> res::(find (n+1) tl) + | None -> find (n+1) tl) + in + try + find 1 context + with Failure s -> [] +;; + + +let compare_goals proof goal1 goal2 = + let _,metasenv,_,_ = proof in + let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in + let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in + let ty_sort1,_ = CicTypeChecker.type_of_aux' metasenv ey1 ty1 + CicUniv.empty_ugraph in + let ty_sort2,_ = CicTypeChecker.type_of_aux' metasenv ey2 ty2 + CicUniv.empty_ugraph in + let prop1 = + let b,_ = CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1 + CicUniv.empty_ugraph in + if b then 0 else 1 + in + let prop2 = + let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2 + CicUniv.empty_ugraph in + if b then 0 else 1 + in + prop1 - prop2 + + +let new_search_theorems f dbd proof goal depth sign = + let choices = f (proof,goal) + in + List.map + (function (subst,(proof, goallist)) -> + (* let goallist = reorder_goals dbd sign proof goallist in *) + let goallist = List.sort (compare_goals proof) goallist in + (subst,(proof,(List.map (function g -> (g,depth)) goallist), sign))) + choices +;; + +exception NoOtherChoices;; + +let rec auto_single dbd proof goal ey ty depth width sign already_seen_goals + universe + = + if depth = 0 then [] else + if List.mem ty already_seen_goals then [] else + let already_seen_goals = ty::already_seen_goals in + let facts = (depth = 1) in + let _,metasenv,p,_ = proof in + (* first of all we check if the goal has been already + inspected *) + assert (CicUtil.exists_meta goal metasenv); + let exitus = + try Hashtbl.find inspected_goals ty + with Not_found -> NotYetInspected in + let is_meta_closed = CicUtil.is_meta_closed ty in + begin + match exitus with + Yes (bo,_) -> + (* + debug_print (lazy "ALREADY PROVED!!!!!!!!!!!!!!!!!!!!!!!!!!!!"); + debug_print (lazy (CicPp.ppterm ty)); + *) + let subst_in = + (* if we just apply the subtitution, the type + is irrelevant: we may use Implicit, since it will + be dropped *) + CicMetaSubst.apply_subst + [(goal,(ey, bo, Cic.Implicit None))] in + let (proof,_) = + ProofEngineHelpers.subst_meta_and_metasenv_in_proof + proof goal subst_in metasenv in + [(subst_in,(proof,[],sign))] + | No d when (d >= depth) -> + (* debug_print (lazy "PRUNED!!!!!!!!!!!!!!!!!!!!!!!!!!!!"); *) + [] (* the empty list means no choices, i.e. failure *) + | No _ + | NotYetInspected -> + debug_print (lazy ("CURRENT GOAL = " ^ CicPp.ppterm ty)); + debug_print (lazy ("CURRENT PROOF = " ^ CicPp.ppterm p)); + debug_print (lazy ("CURRENT HYP = " ^ CicPp.ppcontext ey)); + let sign, new_sign = + if is_meta_closed then + None, Some (MetadataConstraints.signature_of ty) + else sign,sign in (* maybe the union ? *) + let local_choices = + new_search_theorems + search_theorems_in_context dbd + proof goal (depth-1) new_sign in + let global_choices = + new_search_theorems + (fun status -> + List.map snd + (new_experimental_hint + ~dbd ~facts:facts ?signature:sign ~universe status)) + dbd proof goal (depth-1) new_sign in + let all_choices = + local_choices@global_choices in + let sorted_choices = + List.stable_sort + (fun (_, (_, goals1, _)) (_, (_, goals2, _)) -> + Pervasives.compare + (List.length goals1) (List.length goals2)) + all_choices in + (match (auto_new dbd width already_seen_goals universe sorted_choices) + with + [] -> + (* no proof has been found; we update the + hastable *) + (* if is_meta_closed then *) + Hashtbl.add inspected_goals ty (No depth); + [] + | (subst,(proof,[],sign))::tl1 -> + (* a proof for goal has been found: + in order to get the proof we apply subst to + Meta[goal] *) + if is_meta_closed then + begin + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable ey in + let meta_proof = + subst (Cic.Meta(goal,irl)) in + Hashtbl.add inspected_goals + ty (Yes (meta_proof,depth)); +(* + begin + let cty,_ = + CicTypeChecker.type_of_aux' metasenv ey meta_proof CicUniv.empty_ugraph + in + if not (cty = ty) then + begin + debug_print (lazy ("ty = "^CicPp.ppterm ty)); + debug_print (lazy ("cty = "^CicPp.ppterm cty)); + assert false + end + Hashtbl.add inspected_goals + ty (Yes (meta_proof,depth)); + end; +*) + end; + (subst,(proof,[],sign))::tl1 + | _ -> assert false) + end + +and auto_new dbd width already_seen_goals universe = function + | [] -> [] + | (subst,(proof, goals, sign))::tl -> + let _,metasenv,_,_ = proof in + let goals'= + List.filter (fun (goal, _) -> CicUtil.exists_meta goal metasenv) goals + in + auto_new_aux dbd + width already_seen_goals universe ((subst,(proof, goals', sign))::tl) + +and auto_new_aux dbd width already_seen_goals universe = function + | [] -> [] + | (subst,(proof, [], sign))::tl -> (subst,(proof, [], sign))::tl + | (subst,(proof, (goal,0)::_, _))::tl -> + auto_new dbd width already_seen_goals universe tl + | (subst,(proof, goals, _))::tl when + (List.length goals) > width -> + auto_new dbd width already_seen_goals universe tl + | (subst,(proof, (goal,depth)::gtl, sign))::tl -> + let _,metasenv,p,_ = proof in + let (_, ey ,ty) = CicUtil.lookup_meta goal metasenv in + match (auto_single dbd proof goal ey ty depth + (width - (List.length gtl)) sign already_seen_goals) universe + with + [] -> auto_new dbd width already_seen_goals universe tl + | (local_subst,(proof,[],sign))::tl1 -> + let new_subst f t = f (subst t) in + let is_meta_closed = CicUtil.is_meta_closed ty in + let all_choices = + if is_meta_closed then + (new_subst local_subst,(proof,gtl,sign))::tl + else + let tl2 = + (List.map + (function (f,(p,l,s)) -> (new_subst f,(p,l@gtl,s))) tl1) + in + (new_subst local_subst,(proof,gtl,sign))::tl2@tl in + auto_new dbd width already_seen_goals universe all_choices + | _ -> assert false + ;; + +let default_depth = 5 +let default_width = 3 + +(* +let auto_tac ?(depth=default_depth) ?(width=default_width) ~(dbd:HMysql.dbd) + () += + let auto_tac dbd (proof,goal) = + let universe = MetadataQuery.signature_of_goal ~dbd (proof,goal) in + Hashtbl.clear inspected_goals; + debug_print (lazy "Entro in Auto"); + let id t = t in + let t1 = Unix.gettimeofday () in + match auto_new dbd width [] universe [id,(proof, [(goal,depth)],None)] with + [] -> debug_print (lazy "Auto failed"); + raise (ProofEngineTypes.Fail "No Applicable theorem") + | (_,(proof,[],_))::_ -> + let t2 = Unix.gettimeofday () in + debug_print (lazy "AUTO_TAC HA FINITO"); + let _,_,p,_ = proof in + debug_print (lazy (CicPp.ppterm p)); + Printf.printf "tempo: %.9f\n" (t2 -. t1); + (proof,[]) + | _ -> assert false + in + ProofEngineTypes.mk_tactic (auto_tac dbd) +;; +*) + +(* +let paramodulation_tactic = ref + (fun dbd ?full ?depth ?width status -> + raise (ProofEngineTypes.Fail (lazy "Not Ready yet...")));; + +let term_is_equality = ref + (fun term -> debug_print (lazy "term_is_equality E` DUMMY!!!!"); false);; +*) + +let auto_tac ?(depth=default_depth) ?(width=default_width) ?paramodulation + ?full ~(dbd:HMysql.dbd) () = + let auto_tac dbd (proof, goal) = + let normal_auto () = + let universe = MetadataQuery.signature_of_goal ~dbd (proof, goal) in + Hashtbl.clear inspected_goals; + debug_print (lazy "Entro in Auto"); + let id t = t in + let t1 = Unix.gettimeofday () in + match + auto_new dbd width [] universe [id, (proof, [(goal, depth)], None)] + with + [] -> debug_print(lazy "Auto failed"); + raise (ProofEngineTypes.Fail (lazy "No Applicable theorem")) + | (_,(proof,[],_))::_ -> + let t2 = Unix.gettimeofday () in + debug_print (lazy "AUTO_TAC HA FINITO"); + let _,_,p,_ = proof in + debug_print (lazy (CicPp.ppterm p)); + debug_print (lazy (Printf.sprintf "tempo: %.9f\n" (t2 -. t1))); + (proof,[]) + | _ -> assert false + in + let full = match full with None -> false | Some _ -> true in + let paramodulation_ok = + match paramodulation with + | None -> false + | Some _ -> + let _, metasenv, _, _ = proof in + let _, _, meta_goal = CicUtil.lookup_meta goal metasenv in + full || (Inference.term_is_equality meta_goal) + in + if paramodulation_ok then ( + debug_print (lazy "USO PARAMODULATION..."); +(* try *) + Saturation.saturate dbd ~depth ~width ~full (proof, goal) +(* with ProofEngineTypes.Fail _ -> *) +(* normal_auto () *) + ) else + normal_auto () + in + ProofEngineTypes.mk_tactic (auto_tac dbd) +;; diff --git a/helm/software/components/tactics/autoTactic.mli b/helm/software/components/tactics/autoTactic.mli new file mode 100644 index 000000000..fe72629f0 --- /dev/null +++ b/helm/software/components/tactics/autoTactic.mli @@ -0,0 +1,31 @@ + +(* 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 auto_tac: + ?depth:int -> ?width:int -> ?paramodulation:string -> ?full:string -> + dbd:HMysql.dbd -> unit -> + ProofEngineTypes.tactic + diff --git a/helm/software/components/tactics/continuationals.ml b/helm/software/components/tactics/continuationals.ml new file mode 100644 index 000000000..3ed167a71 --- /dev/null +++ b/helm/software/components/tactics/continuationals.ml @@ -0,0 +1,357 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) else () + +exception Error of string lazy_t +let fail msg = raise (Error msg) + +type goal = ProofEngineTypes.goal + +module Stack = +struct + type switch = Open of goal | Closed of goal + type locator = int * switch + type tag = [ `BranchTag | `FocusTag | `NoTag ] + type entry = locator list * locator list * locator list * tag + type t = entry list + + let empty = [ [], [], [], `NoTag ] + + let fold ~env ~cont ~todo init stack = + let rec aux acc depth = + function + | [] -> acc + | (locs, todos, conts, tag) :: tl -> + let acc = List.fold_left (fun acc -> env acc depth tag) acc locs in + let acc = List.fold_left (fun acc -> cont acc depth tag) acc conts in + let acc = List.fold_left (fun acc -> todo acc depth tag) acc todos in + aux acc (depth + 1) tl + in + assert (stack <> []); + aux init 0 stack + + let iter ~env ~cont ~todo = + fold ~env:(fun _ -> env) ~cont:(fun _ -> cont) ~todo:(fun _ -> todo) () + + let map ~env ~cont ~todo = + let depth = ref ~-1 in + List.map + (fun (s, t, c, tag) -> + incr depth; + let d = !depth in + env d tag s, todo d tag t, cont d tag c, tag) + + let is_open = function _, Open _ -> true | _ -> false + let close = function n, Open g -> n, Closed g | l -> l + let filter_open = List.filter is_open + let is_fresh = function n, Open _ when n > 0 -> true | _ -> false + let goal_of_loc = function _, Open g | _, Closed g -> g + let goal_of_switch = function Open g | Closed g -> g + let switch_of_loc = snd + + let zero_pos = List.map (fun g -> 0, Open g) + + let init_pos locs = + let pos = ref 0 in (* positions are 1-based *) + List.map (function _, sw -> incr pos; !pos, sw) locs + + let extract_pos i = + let rec aux acc = + function + | [] -> fail (lazy (sprintf "relative position %d not found" i)) + | (i', _) as loc :: tl when i = i' -> loc, (List.rev acc) @ tl + | hd :: tl -> aux (hd :: acc) tl + in + aux [] + + let deep_close gs = + let close _ _ = + List.map (fun l -> if List.mem (goal_of_loc l) gs then close l else l) + in + let rm _ _ = List.filter (fun l -> not (List.mem (goal_of_loc l) gs)) in + map ~env:close ~cont:rm ~todo:rm + + let rec find_goal = + function + | [] -> raise (Failure "Continuationals.find_goal") + | (l :: _, _ , _ , _) :: _ -> goal_of_loc l + | ( _ , _ , l :: _, _) :: _ -> goal_of_loc l + | ( _ , l :: _, _ , _) :: _ -> goal_of_loc l + | _ :: tl -> find_goal tl + + let is_empty = + function + | [] -> assert false + | [ [], [], [], `NoTag ] -> true + | _ -> false + + let of_metasenv metasenv = + let goals = List.map (fun (g, _, _) -> g) metasenv in + [ zero_pos goals, [], [], `NoTag ] + + let head_switches = + function + | (locs, _, _, _) :: _ -> List.map switch_of_loc locs + | [] -> assert false + + let head_goals = + function + | (locs, _, _, _) :: _ -> List.map goal_of_loc locs + | [] -> assert false + + let head_tag = + function + | (_, _, _, tag) :: _ -> tag + | [] -> assert false + + let shift_goals = + function + | _ :: (locs, _, _, _) :: _ -> List.map goal_of_loc locs + | [] -> assert false + | _ -> [] + + let open_goals stack = + let add_open acc _ _ l = if is_open l then goal_of_loc l :: acc else acc in + List.rev (fold ~env:add_open ~cont:add_open ~todo:add_open [] stack) + + let (@+) = (@) (* union *) + + let (@-) s1 s2 = (* difference *) + List.fold_right + (fun e acc -> if List.mem e s2 then acc else e :: acc) + s1 [] + + let (@~-) locs gs = (* remove some goals from a locators list *) + List.fold_right + (fun loc acc -> if List.mem (goal_of_loc loc) gs then acc else loc :: acc) + locs [] + + let pp stack = + let pp_goal = string_of_int in + let pp_switch = + function Open g -> "o" ^ pp_goal g | Closed g -> "c" ^ pp_goal g + in + let pp_loc (i, s) = string_of_int i ^ pp_switch s in + let pp_env env = sprintf "[%s]" (String.concat ";" (List.map pp_loc env)) in + let pp_tag = function `BranchTag -> "B" | `FocusTag -> "F" | `NoTag -> "N" in + let pp_stack_entry (env, todo, cont, tag) = + sprintf "(%s, %s, %s, %s)" (pp_env env) (pp_env todo) (pp_env cont) + (pp_tag tag) + in + String.concat " :: " (List.map pp_stack_entry stack) +end + +module type Status = +sig + type input_status + type output_status + + type tactic + + val id_tactic : tactic + val mk_tactic : (input_status -> output_status) -> tactic + val apply_tactic : tactic -> input_status -> output_status + + val goals : output_status -> goal list * goal list (** opened, closed goals *) + val set_goals: goal list * goal list -> output_status -> output_status + val get_stack : input_status -> Stack.t + val set_stack : Stack.t -> output_status -> output_status + + val inject : input_status -> output_status + val focus : goal -> output_status -> input_status +end + +module type C = +sig + type input_status + type output_status + type tactic + + type tactical = + | Tactic of tactic + | Skip + + type t = + | Dot + | Semicolon + + | Branch + | Shift + | Pos of int + | Merge + + | Focus of goal list + | Unfocus + + | Tactical of tactical + + val eval: t -> input_status -> output_status +end + +module Make (S: Status) = +struct + open Stack + + type input_status = S.input_status + type output_status = S.output_status + type tactic = S.tactic + + type tactical = + | Tactic of tactic + | Skip + + type t = + | Dot + | Semicolon + | Branch + | Shift + | Pos of int + | Merge + | Focus of goal list + | Unfocus + | Tactical of tactical + + let pp_t = + function + | Dot -> "Dot" + | Semicolon -> "Semicolon" + | Branch -> "Branch" + | Shift -> "Shift" + | Pos i -> "Pos " ^ string_of_int i + | Merge -> "Merge" + | Focus gs -> + sprintf "Focus [%s]" (String.concat "; " (List.map string_of_int gs)) + | Unfocus -> "Unfocus" + | Tactical _ -> "Tactical " + + let eval_tactical tactical ostatus switch = + match tactical, switch with + | Tactic tac, Open n -> + let ostatus = S.apply_tactic tac (S.focus n ostatus) in + let opened, closed = S.goals ostatus in + ostatus, opened, closed + | Skip, Closed n -> ostatus, [], [n] + | Tactic _, Closed _ -> fail (lazy "can't apply tactic to a closed goal") + | Skip, Open _ -> fail (lazy "can't skip an open goal") + + let eval cmd istatus = + let stack = S.get_stack istatus in + debug_print (lazy (sprintf "EVAL CONT %s <- %s" (pp_t cmd) (pp stack))); + let new_stack stack = S.inject istatus, stack in + let ostatus, stack = + match cmd, stack with + | _, [] -> assert false + | Tactical tac, (g, t, k, tag) :: s -> + if g = [] then fail (lazy "can't apply a tactic to zero goals"); + debug_print (lazy ("context length " ^string_of_int (List.length g))); + let rec aux s go gc = + function + | [] -> s, go, gc + | loc :: loc_tl -> + debug_print (lazy "inner eval tactical"); + let s, go, gc = + if List.exists ((=) (goal_of_loc loc)) gc then + s, go, gc + else + let s, go', gc' = eval_tactical tac s (switch_of_loc loc) in + s, (go @- gc') @+ go', gc @+ gc' + in + aux s go gc loc_tl + in + let s0, go0, gc0 = S.inject istatus, [], [] in + let sn, gon, gcn = aux s0 go0 gc0 g in + debug_print (lazy ("opened: " + ^ String.concat " " (List.map string_of_int gon))); + debug_print (lazy ("closed: " + ^ String.concat " " (List.map string_of_int gcn))); + let stack = + (zero_pos gon, t @~- gcn, k @~- gon, tag) :: deep_close gcn s + in + sn, stack + | Dot, ([], _, [], _) :: _ -> + (* backward compatibility: do-nothing-dot *) + new_stack stack + | Dot, (g, t, k, tag) :: s -> + (match filter_open g, k with + | loc :: loc_tl, _ -> new_stack (([ loc ], t, loc_tl @+ k, tag) :: s) + | [], loc :: k -> + assert (is_open loc); + new_stack (([ loc ], t, k, tag) :: s) + | _ -> fail (lazy "can't use \".\" here")) + | Semicolon, _ -> new_stack stack + | Branch, (g, t, k, tag) :: s -> + (match init_pos g with + | [] | [ _ ] -> fail (lazy "too few goals to branch"); + | loc :: loc_tl -> + new_stack + (([ loc ], [], [], `BranchTag) :: (loc_tl, t, k, tag) :: s)) + | Shift, (g, t, k, `BranchTag) :: (g', t', k', tag) :: s -> + (match g' with + | [] -> fail (lazy "no more goals to shift") + | loc :: loc_tl -> + new_stack + (([ loc ], t @+ filter_open g, [],`BranchTag) + :: (loc_tl, t', k', tag) :: s)) + | Shift, _ -> fail (lazy "can't shift goals here") + | Pos i, ([ loc ], [], [],`BranchTag) :: (g', t', k', tag) :: s + when is_fresh loc -> + let loc_i, g' = extract_pos i g' in + new_stack + (([ loc_i ], [], [],`BranchTag) + :: ([ loc ] @+ g', t', k', tag) :: s) + | Pos i, (g, t, k,`BranchTag) :: (g', t', k', tag) :: s -> + let loc_i, g' = extract_pos i g' in + new_stack + (([ loc_i ], [], [],`BranchTag) + :: (g', t' @+ filter_open g, k', tag) :: s) + | Pos _, _ -> fail (lazy "can't use relative positioning here") + | Merge, (g, t, k,`BranchTag) :: (g', t', k', tag) :: s -> + new_stack ((t @+ filter_open g @+ g' @+ k, t', k', tag) :: s) + | Merge, _ -> fail (lazy "can't merge goals here") + | Focus [], _ -> assert false + | Focus gs, s -> + let stack_locs = + let add_l acc _ _ l = if is_open l then l :: acc else acc in + Stack.fold ~env:add_l ~cont:add_l ~todo:add_l [] s + in + List.iter + (fun g -> + if not (List.exists (fun l -> goal_of_loc l = g) stack_locs) then + fail (lazy (sprintf "goal %d not found (or closed)" g))) + gs; + new_stack ((zero_pos gs, [], [], `FocusTag) :: deep_close gs s) + | Unfocus, ([], [], [], `FocusTag) :: s -> new_stack s + | Unfocus, _ -> fail (lazy "can't unfocus, some goals are still open") + in + debug_print (lazy (sprintf "EVAL CONT %s -> %s" (pp_t cmd) (pp stack))); + S.set_stack stack ostatus +end + diff --git a/helm/software/components/tactics/continuationals.mli b/helm/software/components/tactics/continuationals.mli new file mode 100644 index 000000000..d40202d4b --- /dev/null +++ b/helm/software/components/tactics/continuationals.mli @@ -0,0 +1,126 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +exception Error of string Lazy.t + +type goal = ProofEngineTypes.goal + +(** {2 Goal stack} *) + +module Stack: +sig + type switch = Open of goal | Closed of goal + type locator = int * switch + type tag = [ `BranchTag | `FocusTag | `NoTag ] + type entry = locator list * locator list * locator list * tag + type t = entry list + + val empty: t + + val find_goal: t -> goal (** find "next" goal *) + val is_empty: t -> bool (** a singleton empty level *) + val of_metasenv: Cic.metasenv -> t + val head_switches: t -> switch list (** top level switches *) + val head_goals: t -> goal list (** top level goals *) + val head_tag: t -> tag (** top level tag *) + val shift_goals: t -> goal list (** second level goals *) + val open_goals: t -> goal list (** all (Open) goals *) + val goal_of_switch: switch -> goal + + (** @param int depth, depth 0 is the top of the stack *) + val fold: + env: ('a -> int -> tag -> locator -> 'a) -> + cont:('a -> int -> tag -> locator -> 'a) -> + todo:('a -> int -> tag -> locator -> 'a) -> + 'a -> t -> 'a + + val iter: (** @param depth as above *) + env: (int -> tag -> locator -> unit) -> + cont:(int -> tag -> locator -> unit) -> + todo:(int -> tag -> locator -> unit) -> + t -> unit + + val map: (** @param depth as above *) + env: (int -> tag -> locator list -> locator list) -> + cont:(int -> tag -> locator list -> locator list) -> + todo:(int -> tag -> locator list -> locator list) -> + t -> t + + val pp: t -> string +end + +(** {2 Functorial interface} *) + +module type Status = +sig + type input_status + type output_status + + type tactic + + val id_tactic : tactic + val mk_tactic : (input_status -> output_status) -> tactic + val apply_tactic : tactic -> input_status -> output_status + + val goals : output_status -> goal list * goal list (** opened, closed goals *) + val set_goals: goal list * goal list -> output_status -> output_status + val get_stack : input_status -> Stack.t + val set_stack : Stack.t -> output_status -> output_status + + val inject : input_status -> output_status + val focus : goal -> output_status -> input_status +end + +module type C = +sig + type input_status + type output_status + type tactic + + type tactical = + | Tactic of tactic + | Skip + + type t = + | Dot + | Semicolon + + | Branch + | Shift + | Pos of int + | Merge + | Focus of goal list + | Unfocus + + | Tactical of tactical + + val eval: t -> input_status -> output_status +end + +module Make (S: Status) : C + with type tactic = S.tactic + and type input_status = S.input_status + and type output_status = S.output_status + diff --git a/helm/software/components/tactics/discriminationTactics.ml b/helm/software/components/tactics/discriminationTactics.ml new file mode 100644 index 000000000..9e5bc7f43 --- /dev/null +++ b/helm/software/components/tactics/discriminationTactics.ml @@ -0,0 +1,554 @@ +(* 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/. + *) + +(* $Id$ *) + +let debug_print = fun _ -> () + +let rec injection_tac ~term = + let injection_tac ~term status = + let (proof, goal) = status in + 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,_ = CicUtil.lookup_meta goal metasenv in + let termty,_ = (* TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in + ProofEngineTypes.apply_tactic + (match termty with + (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]) + when LibraryObjects.is_eq_URI equri -> ( + 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 (lazy "Discriminate: i 2 termini hanno in testa lo stesso costruttore, ma applicato a un numero diverso di termini. possibile???")) + 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 (lazy "Injection: not a projectable equality")) + ) + | _ -> raise (ProofEngineTypes.Fail (lazy "Injection: not an equation")) + ) status + in + ProofEngineTypes.mk_tactic (injection_tac ~term) + +and injection1_tac ~term ~i = + let injection1_tac ~term ~i status = + let (proof, goal) = status in + (* 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,_ = CicUtil.lookup_meta goal metasenv in + let termty,_ = (* TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in + match termty with (* an equality *) + (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]) + when LibraryObjects.is_eq_URI equri -> ( + match tty with (* some inductive type *) + (C.MutInd (turi,typeno,exp_named_subst)) + | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::_)) -> + 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 + | _ -> assert false + in + let tty',_ = + CicTypeChecker.type_of_aux' metasenv context t1' + CicUniv.empty_ugraph in + let pattern = + match fst(CicEnvironment.get_obj + CicUniv.empty_ugraph 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 (lazy "Discriminate: object is not an Inductive Definition: it's imposible")) + in + ProofEngineTypes.apply_tactic + (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:(ProofEngineTypes.mk_tactic + (fun status -> + let (proof, goal) = status in + let _,metasenv,_,_ = proof in + let _,context,gty = CicUtil.lookup_meta goal metasenv in + let new_t1' = + match gty with + (C.Appl (C.MutInd (_,_,_)::arglist)) -> + List.nth arglist 1 + | _ -> raise (ProofEngineTypes.Fail (lazy "Injection: goal after cut is not correct")) + in + ProofEngineTypes.apply_tactic + (ReductionTactics.change_tac + ~pattern:(ProofEngineTypes.conclusion_pattern + (Some new_t1')) + (fun _ m u -> + 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], m, u)) + status + )) + ~continuation: + (T.then_ + ~start: + (EqualityTactics.rewrite_simpl_tac + ~direction:`LeftToRight + ~pattern:(ProofEngineTypes.conclusion_pattern None) + term) + ~continuation:EqualityTactics.reflexivity_tac + ) + ]) + status + | _ -> raise (ProofEngineTypes.Fail (lazy "Discriminate: not a discriminable equality")) + ) + | _ -> raise (ProofEngineTypes.Fail (lazy "Discriminate: not an equality")) + in + ProofEngineTypes.mk_tactic (injection1_tac ~term ~i) +;; + +exception TwoDifferentSubtermsFound of int + +(* term ha tipo t1=t2; funziona solo se t1 e t2 hanno in testa costruttori +diversi *) + +let discriminate'_tac ~term = + let module C = Cic in + let module U = UriManager in + let module P = PrimitiveTactics in + let module T = Tacticals in + let fail msg = raise (ProofEngineTypes.Fail (lazy ("Discriminate: " ^ msg))) in + let find_discriminating_consno t1 t2 = + let rec aux t1 t2 = + match t1, t2 with + | C.MutConstruct _, C.MutConstruct _ when t1 = t2 -> None + | C.Appl ((C.MutConstruct _ as constr1) :: args1), + C.Appl ((C.MutConstruct _ as constr2) :: args2) + when constr1 = constr2 -> + let rec aux_list l1 l2 = + match l1, l2 with + | [], [] -> None + | hd1 :: tl1, hd2 :: tl2 -> + (match aux hd1 hd2 with + | None -> aux_list tl1 tl2 + | Some _ as res -> res) + | _ -> (* same constructor applied to a different number of args *) + assert false + in + aux_list args1 args2 + | ((C.MutConstruct (_,_,consno1,subst1)), + (C.MutConstruct (_,_,consno2,subst2))) + | ((C.MutConstruct (_,_,consno1,subst1)), + (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _))) + | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)), + (C.MutConstruct (_,_,consno2,subst2))) + | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)), + (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _))) + when (consno1 <> consno2) || (subst1 <> subst2) -> + Some consno2 + | _ -> fail "not a discriminable equality" + in + aux t1 t2 + in + let mk_pattern turi typeno consno context left_args = + (* a list of "True" except for the element in position consno which + * is "False" *) + match fst (CicEnvironment.get_obj CicUniv.empty_ugraph turi) with + | C.InductiveDefinition (ind_type_list,_,nr_ind_params,_) -> + let _,_,_,constructor_list = List.nth ind_type_list typeno in + let false_constr_id,_ = List.nth constructor_list (consno - 1) in + List.map + (fun (id,cty) -> + (* dubbio: e' corretto ridurre in questo context ??? *) + let red_ty = CicReduction.whd context cty in + let rec aux t k = + match t with + | C.Prod (_,_,target) when (k <= nr_ind_params) -> + CicSubstitution.subst (List.nth left_args (k-1)) + (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(LibraryObjects.false_URI (),0,[])) + else (C.MutInd(LibraryObjects.true_URI (),0,[])) + in + (CicSubstitution.lift 1 (aux red_ty 1))) + constructor_list + | _ -> (* object is not an inductive definition *) + assert false + in + let discriminate'_tac ~term status = + let (proof, goal) = status in + let _,metasenv,_,_ = proof in + let _,context,_ = CicUtil.lookup_meta goal metasenv in + let termty,_ = + CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph + in + match termty with + | (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]) + when LibraryObjects.is_eq_URI equri -> + let turi,typeno,exp_named_subst,left_args = + match tty with + | (C.MutInd (turi,typeno,exp_named_subst)) -> + turi,typeno,exp_named_subst,[] + | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::left_args)) -> + turi,typeno,exp_named_subst,left_args + | _ -> fail "not a discriminable equality" + in + let consno = + match find_discriminating_consno t1 t2 with + | Some consno -> consno + | None -> fail "discriminating terms are structurally equal" + in + let pattern = mk_pattern turi typeno consno context left_args in + let (proof',goals') = + ProofEngineTypes.apply_tactic + (EliminationTactics.elim_type_tac + (C.MutInd (LibraryObjects.false_URI (), 0, []))) + status + in + (match goals' with + | [goal'] -> + let _,metasenv',_,_ = proof' in + let _,context',gty' = CicUtil.lookup_meta goal' metasenv' in + ProofEngineTypes.apply_tactic + (T.then_ + ~start: + (ReductionTactics.change_tac + ~pattern:(ProofEngineTypes.conclusion_pattern (Some gty')) + (fun _ m u -> + C.Appl [ + C.Lambda ( C.Name "x", tty, + C.MutCase (turi, typeno, + (C.Lambda ((C.Name "x"), + (CicSubstitution.lift 1 tty), + (C.Sort C.Prop))), + (C.Rel 1), pattern)); + t2 ], m, u)) + ~continuation: + (T.then_ + ~start: + (EqualityTactics.rewrite_simpl_tac + ~direction:`RightToLeft + ~pattern:(ProofEngineTypes.conclusion_pattern None) + term) + ~continuation: + (IntroductionTactics.constructor_tac ~n:1))) + (proof',goal') + | [] -> fail "ElimType False left no goals" + | _ -> fail "ElimType False left more than one goal") + | _ -> fail "not an equality" + in + ProofEngineTypes.mk_tactic (discriminate'_tac ~term) + +let discriminate_tac ~term = + let discriminate_tac ~term status = + ProofEngineTypes.apply_tactic + (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 + in + ProofEngineTypes.mk_tactic (discriminate_tac ~term) + +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 = Tacticals.id_tac + (* +(* 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 = CicUtil.lookup_meta 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 = + let module C = Cic in + let module U = UriManager in + let module P = PrimitiveTactics in + let module T = Tacticals in + let (proof, goal) = status in + let _,metasenv,_,_ = proof in + let _,context,_ = CicUtil.lookup_meta 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 = +debug_print (lazy ("XXXX t1 " ^ CicPp.ppterm t1)) ; +debug_print (lazy ("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 +debug_print (lazy ("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 fst(CicEnvironment.get_obj turi + CicUniv.empty_ugraph) with + C.InductiveDefinition (ind_type_list,_,nr_ind_params) -> +debug_print (lazy ("XXXX nth " ^ (string_of_int (List.length ind_type_list)) ^ " " ^ (string_of_int typeno))) ; + let _,_,_,constructor_list = (List.nth ind_type_list typeno) in +debug_print (lazy ("XXXX nth " ^ (string_of_int (List.length constructor_list)) ^ " " ^ (string_of_int consno2'))) ; + let false_constr_id,_ = List.nth constructor_list (consno2' - 1) in +debug_print (lazy "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' = + CicUtil.lookup_meta goal' metasenv' + in + 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: + ( +debug_print (lazy ("XXXX rewrite<-: " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1' ; t2'])))); +debug_print (lazy ("XXXX rewrite<-: " ^ CicPp.ppterm (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1' ; t2']))) ; +debug_print (lazy ("XXXX equri: " ^ U.string_of_uri equri)) ; +debug_print (lazy ("XXXX tty : " ^ CicPp.ppterm tty)) ; +debug_print (lazy ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1'))) ; +debug_print (lazy ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2'))) ; +if (CicTypeChecker.type_of_aux' metasenv' context' t1') <> tty then debug_print (lazy ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1'))) ; +if (CicTypeChecker.type_of_aux' metasenv' context' t2') <> tty then debug_print (lazy ("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 debug_print (lazy ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' + metasenv' context' t1'))) ; debug_print (lazy ("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 + +debug_print (lazy ("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) + ) + (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") +;; + +*) + + + diff --git a/helm/software/components/tactics/discriminationTactics.mli b/helm/software/components/tactics/discriminationTactics.mli new file mode 100644 index 000000000..f1153256f --- /dev/null +++ b/helm/software/components/tactics/discriminationTactics.mli @@ -0,0 +1,30 @@ +(* 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 + diff --git a/helm/software/components/tactics/doc/Makefile b/helm/software/components/tactics/doc/Makefile new file mode 100644 index 000000000..b7d8fb45c --- /dev/null +++ b/helm/software/components/tactics/doc/Makefile @@ -0,0 +1,124 @@ + +# +# Generic makefile for latex +# +# Author: Stefano Zacchiroli +# +# Created: Sun, 29 Jun 2003 12:00:55 +0200 zack +# Last-Modified: Mon, 10 Oct 2005 15:37:12 +0200 zack +# + +######################################################################## + +# list of .tex _main_ files +TEXS = main.tex + +# number of runs of latex (for table of contents, list of figures, ...) +RUNS = 1 + +# do you need bibtex? +BIBTEX = no + +# would you like to use pdflatex? +PDF_VIA_PDFLATEX = yes + +# which formats generated by default ("all" target)? +# (others will be generated by "world" target) +# see AVAILABLE_FORMATS below +BUILD_FORMATS = dvi + +# which format to be shown on "make show" +SHOW_FORMAT = dvi + +######################################################################## + +AVAILABLE_FORMATS = dvi ps ps.gz pdf html + +ADVI = advi +BIBTEX = bibtex +BROWSER = galeon +DVIPDF = dvipdf +DVIPS = dvips +GV = gv +GZIP = gzip +HEVEA = hevea +ISPELL = ispell +LATEX = latex +PDFLATEX = pdflatex +PRINT = lpr +XDVI = xdvi +XPDF = xpdf + +ALL_FORMATS = $(BUILD_FORMATS) +WORLD_FORMATS = $(AVAILABLE_FORMATS) + +all: $(ALL_FORMATS) +world: $(WORLD_FORMATS) + +DVIS = $(TEXS:.tex=.dvi) +PSS = $(TEXS:.tex=.ps) +PSGZS = $(TEXS:.tex=.ps.gz) +PDFS = $(TEXS:.tex=.pdf) +HTMLS = $(TEXS:.tex=.html) + +dvi: $(DVIS) +ps: $(PSS) +ps.gz: $(PSGZS) +pdf: $(PDFS) +html: $(HTMLS) + +show: show$(SHOW_FORMAT) +showdvi: $(DVIS) + $(XDVI) $< +showps: $(PSS) + $(GV) $< +showpdf: $(PDFS) + $(XPDF) $< +showpsgz: $(PSGZS) + $(GV) $< +showps.gz: showpsgz +showhtml: $(HTMLS) + $(BROWSER) $< + +print: $(PSS) + $(PRINT) $^ + +clean: + rm -f \ + $(TEXS:.tex=.dvi) $(TEXS:.tex=.ps) $(TEXS:.tex=.ps.gz) \ + $(TEXS:.tex=.pdf) $(TEXS:.tex=.aux) $(TEXS:.tex=.log) \ + $(TEXS:.tex=.html) $(TEXS:.tex=.out) $(TEXS:.tex=.haux) \ + $(TEXS:.tex=.htoc) $(TEXS:.tex=.tmp) + +%.dvi: %.tex + $(LATEX) $< + if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi + if [ "$(RUNS)" -gt 1 ]; then \ + for i in seq 1 `expr $(RUNS) - 1`; do \ + $(LATEX) $<; \ + done; \ + fi +ifeq ($(PDF_VIA_PDFLATEX),yes) +%.pdf: %.tex + $(PDFLATEX) $< + if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi + if [ "$(RUNS)" -gt 1 ]; then \ + for i in seq 1 `expr $(RUNS) - 1`; do \ + $(PDFLATEX) $<; \ + done; \ + fi +else +%.pdf: %.dvi + $(DVIPDF) $< $@ +endif +%.ps: %.dvi + $(DVIPS) $< +%.ps.gz: %.ps + $(GZIP) -c $< > $@ +%.html: %.tex + $(HEVEA) -fix $< + +.PHONY: all ps pdf html clean + +######################################################################## + diff --git a/helm/software/components/tactics/doc/body.tex b/helm/software/components/tactics/doc/body.tex new file mode 100644 index 000000000..8b7bbc9b0 --- /dev/null +++ b/helm/software/components/tactics/doc/body.tex @@ -0,0 +1,474 @@ + +\section{Tinycals: \MATITA{} tacticals} + +\subsection{Introduction} + +% outline: +% - script + +Most of modern mainstream proof assistants enable input of proofs of +propositions using a textual language. Compilation units written in such +languages are sequence of textual \emph{statements} and are usually called +\emph{scripts} as a whole. Scripts are so entangled with proof assistants that +they drived the design of state of the art of their Graphical User Interfaces +(GUIs). Fig.~\ref{fig:proofgeneral} is a screenshot of Proof General, a generic +proof assistant interface based on Emacs widely used and compatible with systems +like Coq, Isabelle, PhoX, LEGO, and many more. Other system specific GUIs exist +but share the same design, understanding it and they way such GUIs are operated +is relevant to our discussion. + +%\begin{figure}[ht] +% \begin{center} +% \includegraphic{pics/pg-coq-screenshot} +% \caption{Proof General: a generic interface for proof assistants} +% \label{fig:proofgeneral} +% \end{center} +%\end{figure} + +% - modo di lavorare + +The paradigm behind such GUIs is quite simple. The window on the left is an +editable text area containing the script and split in two by an \emph{execution +point} (the point where background color changes). The part starting at the +beginning of the script and ending at the marker (distinguishable for having a +light blue background in the picture) contains the sequence of statements which +have already been fed into the system. We will call this former part +\emph{locked area} since the user is not free to change it as her willing. The +remaining part, which extends until the end of the script, is named +\emph{scratch area} and can be freely modified. The window on the right is +read-only for the user and includes at the top the current proof status, when +some proof is ongoing, and at the bottom a message area used for error messages +or other feedback from the system to the user. The user usually proceed +alternating editing of the scratch area and execution point movements (forward +to evaluate statements and backward to retract statements if she need to change +something in the locked area). + +Execution point movements are not free, but constrained by the structure of the +script language used. The granularity is that of statements. In systems like Coq +or \MATITA{} examples of statements are: inductive definitions, theorems, and +tactics. \emph{Tactics} are the building blocks of proofs. For example, the +following script snippet contains a theorem about a relationship of natural +minus with natural plus, along with its proof (line numbers have been added for +the sake of presentation) as it can be found in the standard library of the +\MATITA{} proof assistant: + +%\begin{example} +%\begin{Verbatim} +%theorem eq_minus_minus_minus_plus: \forall n,m,p:nat. (n-m)-p = n-(m+p). +% intros. +% cut (m+p \le n \or m+p \nleq n). +% elim Hcut. +% symmetry. +% apply plus_to_minus. +% rewrite > assoc_plus. +% rewrite > (sym_plus p). +% rewrite < plus_minus_m_m. +% rewrite > sym_plus. +% rewrite < plus_minus_m_m. +% reflexivity. +% apply (trans_le ? (m+p)). +% rewrite < sym_plus. +% apply le_plus_n. +% assumption. +% apply le_plus_to_minus_r. +% rewrite > sym_plus. +% assumption. +% rewrite > (eq_minus_n_m_O n (m+p)). +% rewrite > (eq_minus_n_m_O (n-m) p). +% reflexivity. +% apply le_plus_to_minus. +% apply lt_to_le. +% rewrite < sym_plus. +% apply not_le_to_lt. +% assumption. +% apply lt_to_le. +% apply not_le_to_lt. +% assumption. +% apply (decidable_le (m+p) n). +%qed. +%\end{Verbatim} +%\end{example} + +The script snippet is made of 32 statements, one per line (but this is not a +requirement of the \MATITA{} script language, namely \emph{Grafite}). The first +statement is the assertion that the user want to prove a proposition with a +given type, specified after the ``\texttt{:}'', its execution will cause +\MATITA{} to enter the proof state showing to the user the list of goals that +still need to be proved to conclude the proof. The last statement (\texttt{Qed}) +is an assertion that the proof is completed. All intertwining statements are +tactic applications. + +Given the constraint we mentioned about execution point, while inserting (or +replaying) the above script, the user may position it at the end of any line, +having feedback about the status of the proof in that point. See for example +Fig.~\ref{fig:matita} where an intermediate proof status is shown. + +%\begin{figure}[ht] +% \begin{center} +% \includegraphic{matita_screenshot} +% \caption{Matita: ongoing proof} +% \label{fig:matita} +% \end{center} +%\end{figure} + +% - script: sorgenti di un linguaggio imperativo, oggetti la loro semantica +% - script = sequenza di comandi + +You can create an analogy among scripts and sources written in an imperative +programming language, seeing proofs as the denotational semantics of that +language. In such analogy the language used in the script of +Fig.~\ref{fig:matita} is rather poor offering as the only programming construct +the sequential composition of tactic application. What enables step by step +execution is the operational semantics of each tactic application (i.e. how it +changes the current proof status). + +% - pro: concisi + +This kind of scripts have both advantages and drawbacks. Among advantages we can +for sure list the effectiveness of the language. In spite of being longer than +the corresponding informal text version of the proof (a gap hardly fillable with +proof assistants~\cite{debrujinfactor}), the script is fast to write in +interactive use, enable cut and paste approaches, and gives a lot of flexibility +(once the syntax is known of course) in tactic application via additional flags +that can be easily passed to them. + +% - cons: non strutturati, hanno senso solo via reply + +Unfortunately, drawbacks are non negligible. Scripts like those of +Fig.~\ref{fig:matita} are completely unstructured and hardly can be assigned a +meaning simply looking at them. Even experienced users, that knows the details +of all involved tactics, can hardly figure what a script mean without replaying +the proof in their heads. This indeed is a key aspect of scripts: they are +meaningful via \emph{reply}. People interested in understanding a formal proof +written as a script usually start the preferred tool and execute it step by +step. A contrasting approach compared to what happens with high level +programming languages where looking at the code is usually enough to understand +its details. + +% - cons: poco robusti (wrt cambiamenti nelle tattiche, nello statement, ...) + +Additionally, scripts are usually not robust against changes, intending with +that term both changes in the statement that need to be proved (e.g. +strenghtening of an inductive hypothesis) and changes in the implementation of +involved tactics. This drawback can force backward compatibility and slow down +systems development. A real-life example in the history of \MATITA{} was the +reordering of goals after tactic application; the total time needed to port the +(tiny at the time) standard library of no more that 30 scripts was 2 days work. +Having the scripts being structured the task could have been done in much less +time and even automated. + +Tacticals are an attempt at solving this drawbacks. + +\subsection{Tacticals} + +% - script = sequenza di comandi + tatticali + +\ldots descrizione dei tatticali \ldots + +% - pro: fattorizzazione + +Tacticals as described above have several advantages with respect to plain +sequential application of tactics. First of all they enable a great amount of +factorization of proofs using the sequential composition ``;'' operator. Think +for example at proofs by induction on inductive types with several constructors, +which are so frequent when formalizing properties from the computer science +field. It is often the case that several, or even all, cases can be dealt with +uniform strategies, which can in turn by coded in a single script snipped which +can appear only once, at the right hand side of a ``;''. + +% - pro: robustezza + +Scripts properly written using the tacticals above are even more robust with +respect to changes. The additional amount of flexibility is given by +``conditional'' constructs like \texttt{try}, \texttt{solve}, and +\texttt{first}. Using them the scripts no longer contain a single way of +proceeding from one status of the proof to another, they can list more. The wise +proof coder may exploit this mechanism providing fallbacks in order to be more +robust to future changes in tactics implementation. Of course she is not +required to! + +% - pro: strutturazione delle prove (via branching) + +Finally, the branching constructs \texttt{[}, \texttt{|}, and \texttt{]} enable +proof structuring. Consider for example an alternative, branching based, version +of the example above: + +%\begin{example} +%\begin{Verbatim} +%... +%\end{Verbatim} +%\end{example} + +Tactic applications are the same of the previous version of the script, but +branching tacticals are used. The above version is highly more readable and +without executing it key points of the proofs like induction cases can be +observed. + +% - tradeoff: utilizzo dei tatticali vs granularita' dell'esecuzione +% (impossibile eseguire passo passo) + +One can now wonder why thus all scripts are not written in a robust, concise and +structured fashion. The reason is the existence of an unfortunate tradeoff +between the need of using tacticals and the impossibility of executing step by +step \emph{inside} them. Indeed, trying to mimic the structured version of the +proof above in GUIs like Proof General or CoqIDE will result in a single macro +step that will bring you from the beginning of the proof directly at the end of +it! + +Tinycals as implemented in \MATITA{} are a solution to this problem, preserving +the usual tacticals semantics, giving meaning to intermediate execution point +inside complex tacticals. + +\subsection{Tinycals} + +\subsection{Tinycals semantics} + +\subsubsection{Language} + +\[ +\begin{array}{rcll} + S & ::= & & \mbox{(\textbf{continuationals})}\\ + & & \TACTIC{T} & \mbox{(tactic)}\\[2ex] + & | & \DOT & \mbox{(dot)} \\ + & | & \SEMICOLON & \mbox{(semicolon)} \\ + & | & \BRANCH & \mbox{(branch)} \\ + & | & \SHIFT & \mbox{(shift)} \\ + & | & \POS{i} & \mbox{(relative positioning)} \\ + & | & \MERGE & \mbox{(merge)} \\[2ex] + & | & \FOCUS{g_1,\dots,g_n} & \mbox{(absolute positioning)} \\ + & | & \UNFOCUS & \mbox{(unfocus)} \\[2ex] + & | & S ~ S & \mbox{(sequential composition)} \\[2ex] + T & : := & & \mbox{(\textbf{tactics})}\\ + & & \SKIP & \mbox{(skip)} \\ + & | & \mathtt{reflexivity} & \\ + & | & \mathtt{apply}~t & \\ + & | & \dots & +\end{array} +\] + +\subsubsection{Status} + +\[ +\begin{array}{rcll} + \xi & & & \mbox{(proof status)} \\ + \mathit{goal} & & & \mbox{(proof goal)} \\[2ex] + + \SWITCH & = & \OPEN~\mathit{goal} ~ | ~ \CLOSED~\mathit{goal} & \\ + \mathit{locator} & = & \INT\times\SWITCH & \\ + \mathit{tag} & = & \BRANCHTAG ~ | ~ \FOCUSTAG \\[2ex] + + \Gamma & = & \mathit{locator}~\LIST & \mbox{(context)} \\ + \tau & = & \mathit{locator}~\LIST & \mbox{(todo)} \\ + \kappa & = & \mathit{locator}~\LIST & \mbox{(dot's future)} \\[2ex] + + \mathit{stack} & = & (\Gamma\times\tau\times\kappa\times\mathit{tag})~\LIST + \\[2ex] + + \mathit{status} & = & \xi\times\mathit{stack} \\ +\end{array} +\] + +\paragraph{Utilities} +\begin{itemize} + \item $\ZEROPOS([g_1;\cdots;g_n]) = + [\langle 0,\OPEN~g_1\rangle;\cdots;\langle 0,\OPEN~g_n\rangle]$ + \item $\INITPOS([\langle i_1,s_1\rangle;\cdots;\langle i_n,s_n\rangle]) = + [\langle 1,s_1\rangle;\cdots;\langle n,s_n\rangle]$ + \item $\ISFRESH(s) = + \left\{ + \begin{array}{ll} + \mathit{true} & \mathrm{if} ~ s = \langle n, \OPEN~g\rangle\land n > 0 \\ + \mathit{false} & \mathrm{otherwise} \\ + \end{array} + \right.$ + \item $\FILTEROPEN(\mathit{locs})= + \left\{ + \begin{array}{ll} + [] & \mathrm{if}~\mathit{locs} = [] \\ + \langle i,\OPEN~g\rangle :: \FILTEROPEN(\mathit{tl}) + & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} \\ + \FILTEROPEN(\mathit{tl}) + & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\ + \end{array} + \right.$ + \item $\REMOVEGOALS(G,\mathit{locs}) = + \left\{ + \begin{array}{ll} + [] & \mathrm{if}~\mathit{locs} = [] \\ + \REMOVEGOALS(G,\mathit{tl}) + & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} + \land g\in G\\ + hd :: \REMOVEGOALS(G,\mathit{tl}) + & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\ + \end{array} + \right.$ + \item $\DEEPCLOSE(G,S)$: (intuition) given a set of goals $G$ and a stack $S$ + it returns a new stack $S'$ identical to the given one with the exceptions + that each locator whose goal is in $G$ is marked as closed in $\Gamma$ stack + components and removed from $\tau$ and $\kappa$ components. + \item $\GOALS(S)$: (inutition) return all goals appearing in whatever position + on a given stack $S$, appearing in an \OPEN{} switch. +\end{itemize} + +\paragraph{Invariants} +\begin{itemize} + \item $\forall~\mathrm{entry}~\ENTRY{\Gamma}{\tau}{\kappa}{t}, \forall s + \in\tau\cup\kappa, \exists g, s = \OPEN~g$ (each locator on the stack in + $\tau$ and $\kappa$ components has an \OPEN~switch). + \item Unless \FOCUS{} is used the stack contains no duplicate goals. + \item $\forall~\mathrm{locator}~l\in\Gamma \mbox{(with the exception of the + top-level $\Gamma$)}, \ISFRESH(l)$. +\end{itemize} + +\subsubsection{Semantics} + +\[ +\begin{array}{rcll} + \SEMOP{\cdot} & : & C -> \mathit{status} -> \mathit{status} & + \mbox{(continuationals semantics)} \\ + \TSEMOP{\cdot} & : & T -> \xi -> \SWITCH -> + \xi\times\GOAL~\LIST\times\GOAL~\LIST & \mbox{(tactics semantics)} \\ +\end{array} +\] + +\[ +\begin{array}{rcl} + \mathit{apply\_tac} & : & T -> \xi -> \GOAL -> + \xi\times\GOAL~\LIST\times\GOAL~\LIST +\end{array} +\] + +\[ +\begin{array}{rlcc} + \TSEM{T}{\xi}{\OPEN~g} & = & \mathit{apply\_tac}(T,\xi,n) & T\neq\SKIP\\ + \TSEM{\SKIP}{\xi}{\CLOSED~g} & = & \langle \xi, [], [g]\rangle & +\end{array} +\] + +\[ +\begin{array}{rcl} + + \SEM{\TACTIC{T}}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S} + & = + & \langle + \xi_n, + \ENTRY{\Gamma'}{\tau'}{\kappa'}{t} +% \ENTRY{\ZEROPOS(G^o_n)}{\tau\setminus G^c_n}{\kappa\setminus G^o_n}{t} + :: \DEEPCLOSE(G^c_n,S) + \rangle + \\[1ex] + \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{where} ~ n\geq 1} + \\[1ex] + \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~ + \Gamma' = \ZEROPOS(G^o_n) + \land \tau' = \REMOVEGOALS(G^c_n,\tau) + \land \kappa' = \REMOVEGOALS(G^o_n,\kappa) + } + \\[1ex] + \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~ + \left\{ + \begin{array}{rcll} + \langle\xi_0, G^o_0, G^c_0\rangle & = & \langle\xi, [], []\rangle \\ + \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle + & = + & \langle\xi_i, G^o_i, G^c_i\rangle + & l_{i+1}\in G^c_i \\ + \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle + & = + & \langle\xi, (G^o_i\setminus G^c)\cup G^o, G^c_i\cup G^c\rangle + & l_{i+1}\not\in G^c_i \\[1ex] + & & \mathit{where} ~ \langle\xi,G^o,G^c\rangle=\TSEM{T}{\xi_i}{l_{i+1}} \\ + \end{array} + \right. + } + \\[6ex] + + \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{\kappa}{t}::S} + & = + & \langle \xi, \ENTRY{l_1}{\tau}{\GIN[2]\cup\kappa}{t}::S \rangle + \\[1ex] + & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=\GIN \land n\geq 1 + \\[2ex] + + \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{l::\kappa}{t}::S} + & = + & \langle \xi, \ENTRY{[l]}{\tau}{\kappa}{t}::S \rangle + \\[1ex] + & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=[] + \\[2ex] + + \SEM{~\SEMICOLON~}{S} & = & \langle \xi, S \rangle \\[1ex] + + \SEM{~\BRANCH~}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S} + \quad + & = + & \langle\xi, \ENTRY{[l_1']}{[]}{[]}{\BRANCHTAG} + ::\ENTRY{[l_2';\cdots;l_n']}{\tau}{\kappa}{t}::S + \\[1ex] + & & \mathrm{where} ~ n\geq 2 ~ \land ~ \INITPOS(\GIN)=[l_1';\cdots;l_n'] + \\[2ex] + + \SEM{~\SHIFT~} + {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\GIN}{\tau'}{\kappa'}{t'} + ::S} + & = + & \langle + \xi, \ENTRY{[l_1]}{\tau\cup\FILTEROPEN(\Gamma)}{[]}{\BRANCHTAG} + ::\ENTRY{\GIN[2]}{\tau'}{\kappa'}{t'}::S + \rangle + \\[1ex] + & & \mathrm{where} ~ n\geq 1 + \\[2ex] + + \SEM{~\POS{i}~} + {\ENTRY{[l]}{[]}{[]}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S} + & = + & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG} + ::\ENTRY{l :: (\Gamma'\setminus [l_i])}{\tau'}{\kappa'}{t'}::S \rangle + \\[1ex] + & & \mathrm{where} ~ \langle i,l'\rangle = l_i\in \Gamma'~\land~\ISFRESH(l) + \\[2ex] + + \SEM{~\POS{i}~} + {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG} + ::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S} + & = + & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG} + ::\ENTRY{\Gamma'\setminus [l_i]}{\tau'\cup\FILTEROPEN(\Gamma)}{\kappa'}{t'}::S + \rangle + \\[1ex] + & & \mathrm{where} ~ \langle i, l'\rangle = l_i\in \Gamma' + \\[2ex] + + \SEM{~\MERGE~} + {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'} + ::S} + & = + & \langle \xi, + \ENTRY{\tau\cup\FILTEROPEN(\Gamma)\cup\Gamma'\cup\kappa}{\tau'}{\kappa'}{t'} + :: S + \rangle + \\[2ex] + + \SEM{\FOCUS{g_1,\dots,g_n}}{S} + & = + & \langle \xi, \ENTRY{\ZEROPOS([g_1;\cdots;g_n])}{[]}{[]}{\FOCUSTAG} + ::\DEEPCLOSE(S) + \rangle + \\[1ex] + & & \mathrm{where} ~ + \forall i=1,\dots,n,~g_i\in\GOALS(S) + \\[2ex] + + \SEM{\UNFOCUS}{\ENTRY{[]}{[]}{[]}{\FOCUSTAG}::S} + & = + & \langle \xi, S\rangle \\[2ex] + +\end{array} +\] + +\subsection{Related works} + +In~\cite{fk:strata2003}, Kirchner described a small step semantics for Coq +tacticals and PVS strategies. + diff --git a/helm/software/components/tactics/doc/infernce.sty b/helm/software/components/tactics/doc/infernce.sty new file mode 100644 index 000000000..fc4afeaaf --- /dev/null +++ b/helm/software/components/tactics/doc/infernce.sty @@ -0,0 +1,217 @@ +%% +%% This is file `infernce.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% semantic.dtx (with options: `allOptions,inference') +%% +%% IMPORTANT NOTICE: +%% +%% For the copyright see the source file. +%% +%% Any modified versions of this file must be renamed +%% with new filenames distinct from infernce.sty. +%% +%% For distribution of the original source see the terms +%% for copying and modification in the file semantic.dtx. +%% +%% This generated file may be distributed as long as the +%% original source files, as listed above, are part of the +%% same distribution. (The sources need not necessarily be +%% in the same archive or directory.) +%% +%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and +%% Arne John Glenstrup +%% +\expandafter\ifx\csname sem@nticsLoader\endcsname\relax + \PackageError{semantic}{% + This file should not be loaded directly} + {% + This file is an option of the semantic package. It should not be + loaded directly\MessageBreak + but by using \protect\usepackage{semantic} in your document + preamble.\MessageBreak + No commands are defined.\MessageBreak + Type to proceed. + }% +\else +\TestForConflict{\@@tempa,\@@tempb,\@adjustPremises,\@inference} +\TestForConflict{\@inferenceBack,\@inferenceFront,\@inferenceOrPremis} +\TestForConflict{\@premises,\@processInference,\@processPremiseLine} +\TestForConflict{\@setLengths,\inference,\predicate,\predicatebegin} +\TestForConflict{\predicateend,\setnamespace,\setpremisesend} +\TestForConflict{\setpremisesspace,\@makeLength,\@@space} +\TestForConflict{\@@aLineBox,\if@@shortDivider} +\newtoks\@@tempa +\newtoks\@@tempb +\newcommand{\@makeLength}[4]{ + \@@tempa=\expandafter{\csname @@#2\endcsname} + \@@tempb=\expandafter{\csname @set#2\endcsname} % + \expandafter \newlength \the\@@tempa + \expandafter \newcommand \the\@@tempb {} + \expandafter \newcommand \csname set#1\endcsname[1]{} + \expandafter \xdef \csname set#1\endcsname##1% + {{\dimen0=##1}% + \noexpand\renewcommand{\the\@@tempb}{% + \noexpand\setlength{\the \@@tempa}{##1 #4}}% + }% + \csname set#1\endcsname{#3} + \@@tempa=\expandafter{\@setLengths} % + \edef\@setLengths{\the\@@tempa \the\@@tempb} % + } + +\newcommand{\@setLengths}{% + \setlength{\baselineskip}{1.166em}% + \setlength{\lineskip}{1pt}% + \setlength{\lineskiplimit}{1pt}} +\@makeLength{premisesspace}{pSpace}{1.5em}{plus 1fil} +\@makeLength{premisesend}{pEnd}{.75em}{plus 0.5fil} +\@makeLength{namespace}{nSpace}{.5em}{} +\newbox\@@aLineBox +\newif\if@@shortDivider +\newcommand{\@@space}{ } +\newcommand{\predicate}[1]{\predicatebegin #1\predicateend} +\newcommand{\predicatebegin}{$} +\newcommand{\predicateend}{$} +\def\inference{% + \@@shortDividerfalse + \expandafter\hbox\bgroup + \@ifstar{\@@shortDividertrue\@inferenceFront}% + \@inferenceFront +} +\def\@inferenceFront{% + \@ifnextchar[% + {\@inferenceFrontName}% + {\@inferenceMiddle}% +} +\def\@inferenceFrontName[#1]{% + \setbox3=\hbox{\footnotesize #1}% + \ifdim \wd3 > \z@ + \unhbox3% + \hskip\@@nSpace + \fi + \@inferenceMiddle +} +\long\def\@inferenceMiddle#1{% + \@setLengths% + \setbox\@@pBox= + \vbox{% + \@premises{#1}% + \unvbox\@@pBox + }% + \@inferenceBack +} +\long\def\@inferenceBack#1{% + \setbox\@@cBox=% + \hbox{\hskip\@@pEnd \predicate{\ignorespaces#1}\unskip\hskip\@@pEnd}% + \setbox1=\hbox{$ $}% + \setbox\@@pBox=\vtop{\unvbox\@@pBox + \vskip 4\fontdimen8\textfont3}% + \setbox\@@cBox=\vbox{\vskip 4\fontdimen8\textfont3% + \box\@@cBox}% + \if@@shortDivider + \ifdim\wd\@@pBox >\wd\@@cBox% + \dimen1=\wd\@@pBox% + \else% + \dimen1=\wd\@@cBox% + \fi% + \dimen0=\wd\@@cBox% + \hbox to \dimen1{% + \hss + $\frac{\hbox to \dimen0{\hss\box\@@pBox\hss}}% + {\box\@@cBox}$% + \hss + }% + \else + $\frac{\box\@@pBox}% + {\box\@@cBox}$% + \fi + \@ifnextchar[% + {\@inferenceBackName}%{}% + {\egroup} +} +\def\@inferenceBackName[#1]{% + \setbox3=\hbox{\footnotesize #1}% + \ifdim \wd3 > \z@ + \hskip\@@nSpace + \unhbox3% + \fi + \egroup +} +\newcommand{\@premises}[1]{% + \setbox\@@pBox=\vbox{}% + \dimen\@@maxwidth=\wd\@@cBox% + \@processPremises #1\\\end% + \@adjustPremises% +} +\newcommand{\@adjustPremises}{% + \setbox\@@pBox=\vbox{% + \@@moreLinestrue % + \loop % + \setbox\@@pBox=\vbox{% + \unvbox\@@pBox % + \global\setbox\@@aLineBox=\lastbox % + }% + \ifvoid\@@aLineBox % + \@@moreLinesfalse % + \else % + \hbox to \dimen\@@maxwidth{\unhbox\@@aLineBox}% + \fi % + \if@@moreLines\repeat% + }% +} +\def\@processPremises#1\\#2\end{% + \setbox\@@pLineBox=\hbox{}% + \@processPremiseLine #1&\end% + \setbox\@@pLineBox=\hbox{\unhbox\@@pLineBox \unskip}% + \ifdim \wd\@@pLineBox > \z@ % + \setbox\@@pLineBox=% + \hbox{\hskip\@@pEnd \unhbox\@@pLineBox \hskip\@@pEnd}% + \ifdim \wd\@@pLineBox > \dimen\@@maxwidth % + \dimen\@@maxwidth=\wd\@@pLineBox % + \fi % + \setbox\@@pBox=\vbox{\box\@@pLineBox\unvbox\@@pBox}% + \fi % + \def\sem@tmp{#2}% + \ifx \sem@tmp\empty \else % + \@ReturnAfterFi{% + \@processPremises #2\end % + }% + \fi% +} +\def\@processPremiseLine#1\end{% + \def\sem@tmp{#1}% + \ifx \sem@tmp\empty \else% + \ifx \sem@tmp\@@space \else% + \setbox\@@pLineBox=% + \hbox{\unhbox\@@pLineBox% + \@inferenceOrPremis #1\inference\end% + \hskip\@@pSpace}% + \fi% + \fi% + \def\sem@tmp{#2}% + \ifx \sem@tmp\empty \else% + \@ReturnAfterFi{% + \@processPremiseLine#2\end% + }% + \fi% +} +\def\@inferenceOrPremis#1\inference{% + \@ifnext \end + {\@dropnext{\predicate{\ignorespaces #1}\unskip}}% + {\@processInference #1\inference}% +} +\def\@processInference#1\inference\end{% + \ignorespaces #1% + \setbox3=\lastbox + \dimen3=\dp3 + \advance\dimen3 by -\fontdimen22\textfont2 + \advance\dimen3 by \fontdimen8\textfont3 + \expandafter\raise\dimen3\box3% +} +\long\def\@ReturnAfterFi#1\fi{\fi#1} +\fi +\endinput +%% +%% End of file `infernce.sty'. diff --git a/helm/software/components/tactics/doc/ligature.sty b/helm/software/components/tactics/doc/ligature.sty new file mode 100644 index 000000000..a914d91d1 --- /dev/null +++ b/helm/software/components/tactics/doc/ligature.sty @@ -0,0 +1,169 @@ +%% +%% This is file `ligature.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% semantic.dtx (with options: `allOptions,ligature') +%% +%% IMPORTANT NOTICE: +%% +%% For the copyright see the source file. +%% +%% Any modified versions of this file must be renamed +%% with new filenames distinct from ligature.sty. +%% +%% For distribution of the original source see the terms +%% for copying and modification in the file semantic.dtx. +%% +%% This generated file may be distributed as long as the +%% original source files, as listed above, are part of the +%% same distribution. (The sources need not necessarily be +%% in the same archive or directory.) +%% +%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and +%% Arne John Glenstrup +%% +\expandafter\ifx\csname sem@nticsLoader\endcsname\relax + \PackageError{semantic}{% + This file should not be loaded directly} + {% + This file is an option of the semantic package. It should not be + loaded directly\MessageBreak + but by using \protect\usepackage{semantic} in your document + preamble.\MessageBreak + No commands are defined.\MessageBreak + Type to proceed. + }% +\else +\TestForConflict{\@addligto,\@addligtofollowlist,\@def@ligstep} +\TestForConflict{\@@trymathlig,\@defactive,\@defligstep} +\TestForConflict{\@definemathlig,\@domathligfirsts,\@domathligfollows} +\TestForConflict{\@exitmathlig,\@firstmathligs,\@ifactive,\@ifcharacter} +\TestForConflict{\@ifinlist,\@lastvalidmathlig,\@mathliglink} +\TestForConflict{\@mathligredefactive,\@mathligsoff,\@mathligson} +\TestForConflict{\@seentoks,\@setupfirstligchar,\@try@mathlig} +\TestForConflict{\@trymathlig,\if@mathligon,\mathlig,\mathligprotect} +\TestForConflict{\mathligsoff,\mathligson,\@startmathlig,\@pushedtoks} +\newif\if@mathligon +\DeclareRobustCommand\mathlig[1]{\@addligtolists#1\@@ + \if@mathligon\mathligson\fi + \@setupfirstligchar#1\@@ + \@defligstep{}#1\@@} +\def\@mathligson{\if@mathligon\mathligson\fi} +\def\@mathligsoff{\if@mathligon\mathligsoff\@mathligontrue\fi} +\DeclareRobustCommand\mathligprotect[1]{\expandafter + \def\expandafter#1\expandafter{% + \expandafter\@mathligsoff#1\@mathligson}} +\DeclareRobustCommand\mathligson{\def\do##1##2##3{\mathcode`##1="8000}% + \@domathligfirsts\@mathligontrue} +\AtBeginDocument{\mathligson} +\DeclareRobustCommand\mathligsoff{\def\do##1##2##3{\mathcode`##1=##2}% + \@domathligfirsts\@mathligonfalse} +\edef\@mathliglink{Error: \noexpand\verb|\string\@mathliglink| expanded} +{\catcode`\A=11\catcode`\1=12\catcode`\~=13 % Letter, Other and Active +\gdef\@ifcharacter#1{\ifcat A\noexpand#1\let\next\@firstoftwo + \else\ifcat 1\noexpand#1\let\next\@firstoftwo + \else\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo + \else\let\next\@secondoftwo\fi\fi\fi\next}% +\gdef\@ifactive#1{\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo + \else\let\next\@secondoftwo\fi\next}} +\def\@domathligfollows{}\def\@domathligfirsts{} +\def\@makemathligsactive{\mathligson + \def\do##1##2##3{\catcode`##1=12}\@domathligfollows} +\def\@makemathligsnormal{\mathligsoff + \def\do##1##2##3{\catcode`##1=##3}\@domathligfollows} +\def\@ifinlist#1#2{\@tempswafalse + \def\do##1##2##3{\ifnum`##1=`#2\relax\@tempswatrue\fi}#1% + \if@tempswa\let\next\@firstoftwo\else\let\next\@secondoftwo\fi\next} +\def\@addligto#1#2{% + \@ifinlist#1#2{\def\do##1##2##3{\noexpand\do\noexpand##1% + \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}% + \else{##2}{##3}\fi}% + \edef#1{#1}}% + {\def\do##1##2##3{\noexpand\do\noexpand##1% + \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}% + \else{##2}{##3}\fi}% + \edef#1{#1\do#2{\the\mathcode`#2}{\the\catcode`#2}}}} +\def\@addligtolists#1{\expandafter\@addligto + \expandafter\@domathligfirsts + \csname\string#1\endcsname\@addligtofollowlist} +\def\@addligtofollowlist#1{\ifx#1\@@\let\next\relax\else + \def\next{\expandafter\@addligto + \expandafter\@domathligfollows + \csname\string#1\endcsname + \@addligtofollowlist}\fi\next} +\def\@defligstep#1#2{\def\@tempa##1{\ifx##1\endcsname + \expandafter\endcsname\else + \string##1\expandafter\@tempa\fi}% + \expandafter\@def@ligstep\csname @mathlig\@tempa#1#2\endcsname{#1#2}} +\def\@def@ligstep#1#2#3{% + \ifx#3\@@ + \def\next{\def#1}% + \else + \ifx#1\relax + \def\next{\let#1\@mathliglink\@defligstep{#2}#3}% + \else + \def\next{\@defligstep{#2}#3}% + \fi + \fi\next} +\def\@setupfirstligchar#1#2\@@{% + \@ifactive{#1}{% + \expandafter\expandafter\expandafter\@mathligredefactive + \expandafter\string\expandafter#1\expandafter{#1}{#1}}% + {\@defactive#1{\@startmathlig #1}\@namedef{@mathlig#1}{#1}}} +\def\@mathligredefactive#1#2#3{% + \def#3{{}\ifmmode\def\next{\@startmathlig#1}\else + \def\next{#2}\fi\next}% + \@namedef{@mathlig#1}{#2}} +\def\@defactive#1{\@ifundefined{@definemathlig\string#1}% + {\@latex@error{Illegal first character in math ligature} + {You can only use \@firstmathligs\space as the first^^J + character of a math ligature}}% + {\csname @definemathlig\string#1\endcsname}} + +{\def\@firstmathligs{}\def\do#1{\catcode`#1=\active + \expandafter\gdef\expandafter\@firstmathligs + \expandafter{\@firstmathligs\space\string#1}\next} + \def\next#1{\expandafter\gdef\csname + @definemathlig\string#1\endcsname{\def#1}} + \do{"}"\do{@}@\do{/}/\do{(}(\do{)})\do{[}[\do{]}]\do{=}= + \do{?}?\do{!}!\do{`}`\do{'}'\do{|}|\do{~}~\do{<}<\do{>}> + \do{+}+\do{-}-\do{*}*\do{.}.\do{,},\do{:}:\do{;};} +\newtoks\@pushedtoks +\newtoks\@seentoks +\def\@startmathlig{\def\@lastvalidmathlig{}\@pushedtoks{}% + \@seentoks{}\@trymathlig} +\def\@trymathlig{\futurelet\next\@@trymathlig} +\def\@@trymathlig{\@ifcharacter\next{\@try@mathlig}{\@exitmathlig{}}} +\def\@exitmathlig#1{% + \expandafter\@makemathligsnormal\@lastvalidmathlig\mathligson + \the\@pushedtoks#1} +\def\@try@mathlig#1{%\typeout{char: #1 catcode: \the\catcode`#1 + \@ifundefined{@mathlig\the\@seentoks#1}{\@exitmathlig{#1}}% + {\expandafter\ifx + \csname @mathlig\the\@seentoks#1\endcsname + \@mathliglink + \expandafter\@pushedtoks + \expandafter=\expandafter{\the\@pushedtoks#1}% + \else + \expandafter\let\expandafter\@lastvalidmathlig + \csname @mathlig\the\@seentoks#1\endcsname + \@pushedtoks={}% + \fi + \expandafter\@seentoks\expandafter=\expandafter% + {\the\@seentoks#1}\@makemathligsactive\obeyspaces\@trymathlig}} +\edef\patch@newmcodes@{% + \mathcode\number`\'=39 + \mathcode\number`\*=42 + \mathcode\number`\.=\string "613A + \mathchardef\noexpand\std@minus=\the\mathcode`\-\relax + \mathcode\number`\-=45 + \mathcode\number`\/=47 + \mathcode\number`\:=\string "603A\relax +} +\AtBeginDocument{\let\newmcodes@=\patch@newmcodes@} +\fi +\endinput +%% +%% End of file `ligature.sty'. diff --git a/helm/software/components/tactics/doc/main.tex b/helm/software/components/tactics/doc/main.tex new file mode 100644 index 000000000..06952d61c --- /dev/null +++ b/helm/software/components/tactics/doc/main.tex @@ -0,0 +1,70 @@ +\documentclass[a4paper]{article} + +\usepackage{a4wide} +\usepackage{pifont} +\usepackage{semantic} +\usepackage{stmaryrd} +\usepackage{graphicx} + +\newcommand{\MATITA}{\ding{46}\textsf{\textbf{Matita}}} + +\title{Continuationals semantics for \MATITA} +\author{Claudio Sacerdoti Coen \quad Enrico Tassi \quad Stefano Zacchiroli \\ +\small Department of Computer Science, University of Bologna \\ +\small Mura Anteo Zamboni, 7 -- 40127 Bologna, ITALY \\ +\small \{\texttt{sacerdot}, \texttt{tassi}, \texttt{zacchiro}\}\texttt{@cs.unibo.it}} + +\newcommand{\MATHIT}[1]{\ensuremath{\mathit{#1}}} +\newcommand{\MATHTT}[1]{\ensuremath{\mathtt{#1}}} + +\newcommand{\DOT}{\ensuremath{\mbox{\textbf{.}}}} +\newcommand{\SEMICOLON}{\ensuremath{\mbox{\textbf{;}}}} +\newcommand{\BRANCH}{\ensuremath{\mbox{\textbf{[}}}} +\newcommand{\SHIFT}{\ensuremath{\mbox{\textbf{\textbar}}}} +\newcommand{\POS}[1]{\ensuremath{#1\mbox{\textbf{:}}}} +\newcommand{\MERGE}{\ensuremath{\mbox{\textbf{]}}}} +\newcommand{\FOCUS}[1]{\ensuremath{\mathtt{focus}~#1}} +\newcommand{\UNFOCUS}{\ensuremath{\mathtt{unfocus}}} +\newcommand{\SKIP}{\MATHTT{skip}} +\newcommand{\TACTIC}[1]{\ensuremath{\mathtt{tactic}~#1}} + +\newcommand{\APPLY}[1]{\ensuremath{\mathtt{apply}~\mathit{#1}}} + +\newcommand{\GOAL}{\MATHIT{goal}} +\newcommand{\SWITCH}{\MATHIT{switch}} +\newcommand{\LIST}{\MATHTT{list}} +\newcommand{\INT}{\MATHTT{int}} +\newcommand{\OPEN}{\MATHTT{Open}} +\newcommand{\CLOSED}{\MATHTT{Closed}} + +\newcommand{\SEMOP}[1]{|[#1|]} +\newcommand{\TSEMOP}[1]{{}_t|[#1|]} +\newcommand{\SEM}[3][\xi]{\SEMOP{#2}_{{#1},{#3}}} +\newcommand{\ENTRY}[4]{\langle#1,#2,#3,#4\rangle} +\newcommand{\TSEM}[3]{\TSEMOP{#1}_{#2,#3}} + +\newcommand{\GIN}[1][1]{\ensuremath{[l_{#1};\cdots;l_n]}} + +\newcommand{\ZEROPOS}{\MATHIT{zero\_pos}} +\newcommand{\INITPOS}{\MATHIT{init\_pos}} +\newcommand{\ISFRESH}{\MATHIT{is\_fresh}} +\newcommand{\FILTER}{\MATHIT{filter}} +\newcommand{\FILTEROPEN}{\MATHIT{filter\_open}} +\newcommand{\ISOPEN}{\MATHIT{is\_open}} +\newcommand{\DEEPCLOSE}{\MATHIT{deep\_close}} +\newcommand{\REMOVEGOALS}{\MATHIT{remove\_goals}} +\newcommand{\GOALS}{\MATHIT{open\_goals}} + +\newcommand{\BRANCHTAG}{\ensuremath{\mathtt{B}}} +\newcommand{\FOCUSTAG}{\ensuremath{\mathtt{F}}} + +\newlength{\sidecondlen} +\setlength{\sidecondlen}{2cm} + +\begin{document} +\maketitle + +\input{body.tex} + +\end{document} + diff --git a/helm/software/components/tactics/doc/reserved.sty b/helm/software/components/tactics/doc/reserved.sty new file mode 100644 index 000000000..c0d56b8aa --- /dev/null +++ b/helm/software/components/tactics/doc/reserved.sty @@ -0,0 +1,80 @@ +%% +%% This is file `reserved.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% semantic.dtx (with options: `allOptions,reservedWords') +%% +%% IMPORTANT NOTICE: +%% +%% For the copyright see the source file. +%% +%% Any modified versions of this file must be renamed +%% with new filenames distinct from reserved.sty. +%% +%% For distribution of the original source see the terms +%% for copying and modification in the file semantic.dtx. +%% +%% This generated file may be distributed as long as the +%% original source files, as listed above, are part of the +%% same distribution. (The sources need not necessarily be +%% in the same archive or directory.) +%% +%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and +%% Arne John Glenstrup +%% +\expandafter\ifx\csname sem@nticsLoader\endcsname\relax + \PackageError{semantic}{% + This file should not be loaded directly} + {% + This file is an option of the semantic package. It should not be + loaded directly\MessageBreak + but by using \protect\usepackage{semantic} in your document + preamble.\MessageBreak + No commands are defined.\MessageBreak + Type to proceed. + }% +\else +\TestForConflict{\reservestyle,\@reservestyle,\setreserved,\<} +\TestForConflict{\@parseDefineReserved,\@xparseDefineReserved} +\TestForConflict{\@defineReserved,\@xdefineReserved} +\newcommand{\reservestyle}[3][]{ + \newcommand{#2}{\@parseDefineReserved{#1}{#3}} + \expandafter\expandafter\expandafter\def + \expandafter\csname set\expandafter\@gobble\string#2\endcsname##1% + {#1{#3{##1}}}} +\newtoks\@@spacing +\newtoks\@@formating +\def\@parseDefineReserved#1#2{% + \@ifnextchar[{\@xparseDefineReserved{#2}}% + {\@xparseDefineReserved{#2}[#1]}} +\def\@xparseDefineReserved#1[#2]#3{% + \@@formating{#1}% + \@@spacing{#2}% + \expandafter\@defineReserved#3,\end +} +\def\@defineReserved#1,{% + \@ifnextchar\end + {\@xdefineReserved #1[]\END\@gobble}% + {\@xdefineReserved#1[]\END\@defineReserved}} +\def\@xdefineReserved#1[#2]#3\END{% + \def\reserved@a{#2}% + \ifx \reserved@a\empty \toks0{#1}\else \toks0{#2} \fi + \expandafter\edef\csname\expandafter<#1>\endcsname + {\the\@@formating{\the\@@spacing{\the\toks0}}}} +\def\setreserved#1>{% + \expandafter\let\expandafter\reserved@a\csname<#1>\endcsname + \@ifundefined{reserved@a}{\PackageError{Semantic} + {``#1'' is not defined as a reserved word}% + {Before referring to a name as a reserved word, it % + should be defined\MessageBreak using an appropriate style + definer. A style definer is defined \MessageBreak + using \protect\reservestyle.\MessageBreak% + Type to proceed --- nothing will be set.}}% + {\reserved@a}} +\let\<=\setreserved +\fi +\endinput +%% +%% End of file `reserved.sty'. diff --git a/helm/software/components/tactics/doc/semantic.sty b/helm/software/components/tactics/doc/semantic.sty new file mode 100644 index 000000000..98257cab8 --- /dev/null +++ b/helm/software/components/tactics/doc/semantic.sty @@ -0,0 +1,137 @@ +%% +%% This is file `semantic.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% semantic.dtx (with options: `general') +%% +%% IMPORTANT NOTICE: +%% +%% For the copyright see the source file. +%% +%% Any modified versions of this file must be renamed +%% with new filenames distinct from semantic.sty. +%% +%% For distribution of the original source see the terms +%% for copying and modification in the file semantic.dtx. +%% +%% This generated file may be distributed as long as the +%% original source files, as listed above, are part of the +%% same distribution. (The sources need not necessarily be +%% in the same archive or directory.) +%% +%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and +%% Arne John Glenstrup +%% +\NeedsTeXFormat{LaTeX2e} +\newcommand{\semanticVersion}{2.0(epsilon)} +\newcommand{\semanticDate}{2003/10/28} +\ProvidesPackage{semantic} + [\semanticDate\space v\semanticVersion\space] +\typeout{Semantic Package v\semanticVersion\space [\semanticDate]} +\typeout{CVSId: $Id$} +\newcounter{@@conflict} +\newcommand{\@semanticNotDefinable}{% + \typeout{Command \@backslashchar\reserved@a\space already defined} + \stepcounter{@@conflict}} +\newcommand{\@oldNotDefinable}{} +\let\@oldNotDefinable=\@notdefinable +\let\@notdefinable=\@semanticNotDefinable +\newcommand{\TestForConflict}{} +\def\TestForConflict#1{\sem@test #1,,} +\newcommand{\sem@test}{} +\newcommand{\sem@tmp}{} +\newcommand{\@@next}{} +\def\sem@test#1,{% + \def\sem@tmp{#1}% + \ifx \sem@tmp\empty \let\@@next=\relax \else + \@ifdefinable{#1}{} \let\@@next=\sem@test \fi + \@@next} +\TestForConflict{\@inputLigature,\@inputInference,\@inputTdiagram} +\TestForConflict{\@inputReservedWords,\@inputShorthand} +\TestForConflict{\@ddInput,\sem@nticsLoader,\lo@d} +\def\@inputLigature{\input{ligature.sty}\message{ math mode ligatures,}% + \let\@inputLigature\relax} +\def\@inputInference{\input{infernce.sty}\message{ inference rules,}% + \let\@inputInference\relax} +\def\@inputTdiagram{\input{tdiagram.sty}\message{ T diagrams,}% + \let\@inputTdiagram\relax} +\def\@inputReservedWords{\input{reserved.sty}\message{ reserved words,}% + \let\@inputReservedWords\relax} +\def\@inputShorthand{\input{shrthand.sty}\message{ short hands,}% + \let\@inputShorthand\relax} +\toks1={} +\newcommand{\@ddInput}[1]{% + \toks1=\expandafter{\the\toks1\noexpand#1}} +\DeclareOption{ligature}{\@ddInput\@inputLigature} +\DeclareOption{inference}{\@ddInput\@inputInference} +\DeclareOption{tdiagram}{\@ddInput\@inputTdiagram} +\DeclareOption{reserved}{\@ddInput\@inputReservedWords} +\DeclareOption{shorthand}{\@ddInput\@inputLigature + \@ddInput\@inputShorthand} +\ProcessOptions* +\typeout{Loading features: } +\def\sem@nticsLoader{} +\edef\lo@d{\the\toks1} +\ifx\lo@d\empty + \@inputLigature + \@inputInference + \@inputTdiagram + \@inputReservedWords + \@inputShorthand +\else + \lo@d +\fi +\typeout{and general definitions.^^J} +\let\@ddInput\relax +\let\@inputInference\relax +\let\@inputLigature\relax +\let\@inputTdiagram\relax +\let\@inputReservedWords\relax +\let\@inputShorthand\relax +\let\sem@nticsLoader\realx +\let\lo@d\relax +\TestForConflict{\@dropnext,\@ifnext,\@ifn,\@ifNextMacro,\@ifnMacro} +\TestForConflict{\@@maxwidth,\@@pLineBox,\if@@Nested,\@@cBox} +\TestForConflict{\if@@moreLines,\@@pBox} +\def\@ifnext#1#2#3{% + \let\reserved@e=#1\def\reserved@a{#2}\def\reserved@b{#3}\futurelet% + \reserved@c\@ifn} +\def\@ifn{% + \ifx \reserved@c \reserved@e\let\reserved@d\reserved@a\else% + \let\reserved@d\reserved@b\fi \reserved@d} +\def\@ifNextMacro#1#2{% + \def\reserved@a{#1}\def\reserved@b{#2}% + \futurelet\reserved@c\@ifnMacro} +\def\@ifnMacro{% + \ifcat\noexpand\reserved@c\noexpand\@ifnMacro + \let\reserved@d\reserved@a + \else \let\reserved@d\reserved@b\fi \reserved@d} +\newcommand{\@dropnext}[2]{#1} +\ifnum \value{@@conflict} > 0 + \PackageError{Semantic} + {The \the@@conflict\space command(s) listed above have been + redefined.\MessageBreak + Please report this to turtle@bu.edu} + {Some of the commands defined in semantic was already defined % + and has\MessageBreak now be redefined. There is a risk that % + these commands will be used\MessageBreak by other packages % + leading to spurious errors.\MessageBreak + \space\space Type and cross your fingers% +}\fi +\let\@notdefinable=\@oldNotDefinable +\let\@semanticNotDefinable=\relax +\let\@oldNotDefinable=\relax +\let\TestForConflict=\relax +\let\@endmark=\relax +\let\sem@test=\relax +\newdimen\@@maxwidth +\newbox\@@pLineBox +\newbox\@@cBox +\newbox\@@pBox +\newif\if@@moreLines +\newif\if@@Nested \@@Nestedfalse +\endinput +%% +%% End of file `semantic.sty'. diff --git a/helm/software/components/tactics/doc/shrthand.sty b/helm/software/components/tactics/doc/shrthand.sty new file mode 100644 index 000000000..b73af4470 --- /dev/null +++ b/helm/software/components/tactics/doc/shrthand.sty @@ -0,0 +1,96 @@ +%% +%% This is file `shrthand.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% semantic.dtx (with options: `allOptions,shorthand') +%% +%% IMPORTANT NOTICE: +%% +%% For the copyright see the source file. +%% +%% Any modified versions of this file must be renamed +%% with new filenames distinct from shrthand.sty. +%% +%% For distribution of the original source see the terms +%% for copying and modification in the file semantic.dtx. +%% +%% This generated file may be distributed as long as the +%% original source files, as listed above, are part of the +%% same distribution. (The sources need not necessarily be +%% in the same archive or directory.) +%% +%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and +%% Arne John Glenstrup +%% +\expandafter\ifx\csname sem@nticsLoader\endcsname\relax + \PackageError{semantic}{% + This file should not be loaded directly} + {% + This file is an option of the semantic package. It should not be + loaded directly\MessageBreak + but by using \protect\usepackage{semantic} in your document + preamble.\MessageBreak + No commands are defined.\MessageBreak + Type to proceed. + }% +\else +\IfFileExists{DONOTUSEmathbbol.sty}{% + \RequirePackage{mathbbol} + \newcommand{\@bblb}{\textbb{[}} + \newcommand{\@bbrb}{\textbb{]}} + \newcommand{\@mbblb}{\mathopen{\mbox{\textbb{[}}}} + \newcommand{\@mbbrb}{\mathclose{\mbox{\textbb{]}}}} +} +{ \newcommand{\@bblb}{\textnormal{[\kern-.15em[}} + \newcommand{\@bbrb}{\textnormal{]\kern-.15em]}} + \newcommand{\@mbblb}{\mathopen{[\mkern-2.67mu[}} + \newcommand{\@mbbrb}{\mathclose{]\mkern-2.67mu]}} +} +\mathlig{|-}{\vdash} +\mathlig{|=}{\models} +\mathlig{->}{\rightarrow} +\mathlig{->*}{\mathrel{\rightarrow^*}} +\mathlig{->+}{\mathrel{\rightarrow^+}} +\mathlig{-->}{\longrightarrow} +\mathlig{-->*}{\mathrel{\longrightarrow^*}} +\mathlig{-->+}{\mathrel{\longrightarrow^+}} +\mathlig{=>}{\Rightarrow} +\mathlig{=>*}{\mathrel{\Rightarrow^*}} +\mathlig{=>+}{\mathrel{\Rightarrow^+}} +\mathlig{==>}{\Longrightarrow} +\mathlig{==>*}{\mathrel{\Longrightarrow^*}} +\mathlig{==>+}{\mathrel{\Longrightarrow^+}} +\mathlig{<-}{\leftarrow} +\mathlig{*<-}{\mathrel{{}^*\mkern-1mu\mathord\leftarrow}} +\mathlig{+<-}{\mathrel{{}^+\mkern-1mu\mathord\leftarrow}} +\mathlig{<--}{\longleftarrow} +\mathlig{*<--}{\mathrel{{}^*\mkern-1mu\mathord{\longleftarrow}}} +\mathlig{+<--}{\mathrel{{}^+\mkern-1mu\mathord{\longleftarrow}}} +\mathlig{<=}{\Leftarrow} +\mathlig{*<=}{\mathrel{{}^*\mkern-1mu\mathord\Leftarrow}} +\mathlig{+<=}{\mathrel{{}^+\mkern-1mu\mathord\Leftarrow}} +\mathlig{<==}{\Longleftarrow} +\mathlig{*<==}{\mathrel{{}^*\mkern-1mu\mathord{\Longleftarrow}}} +\mathlig{+<==}{\mathrel{{}^+\mkern-1mu\mathord{\Longleftarrow}}} +\mathlig{<->}{\longleftrightarrow} +\mathlig{<=>}{\Longleftrightarrow} +\mathlig{|[}{\@mbblb} +\mathlig{|]}{\@mbbrb} +\newcommand{\evalsymbol}[1][]{\ensuremath{\mathcal{E}^{#1}}} +\newcommand{\compsymbol}[1][]{\ensuremath{\mathcal{C}^{#1}}} +\newcommand{\eval}[3][]% + {\mbox{$\mathcal{E}^{#1}$\@bblb \texttt{#2}\@bbrb}% + \ensuremath{\mathtt{#3}}} +\newcommand{\comp}[3][]% + {\mbox{$\mathcal{C}^{#1}$\@bblb \texttt{#2}\@bbrb}% + \ensuremath{\mathtt{#3}}} +\newcommand{\@exe}[3]{} +\newcommand{\exe}[1]{\@ifnextchar[{\@exe{#1}}{\@exe{#1}[]}} +\def\@exe#1[#2]#3{% + \mbox{\@bblb\texttt{#1}\@bbrb$^\mathtt{#2}\mathtt{(#3)}$}} +\fi +\endinput +%% +%% End of file `shrthand.sty'. diff --git a/helm/software/components/tactics/doc/tdiagram.sty b/helm/software/components/tactics/doc/tdiagram.sty new file mode 100644 index 000000000..02202b34a --- /dev/null +++ b/helm/software/components/tactics/doc/tdiagram.sty @@ -0,0 +1,166 @@ +%% +%% This is file `tdiagram.sty', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% semantic.dtx (with options: `allOptions,Tdiagram') +%% +%% IMPORTANT NOTICE: +%% +%% For the copyright see the source file. +%% +%% Any modified versions of this file must be renamed +%% with new filenames distinct from tdiagram.sty. +%% +%% For distribution of the original source see the terms +%% for copying and modification in the file semantic.dtx. +%% +%% This generated file may be distributed as long as the +%% original source files, as listed above, are part of the +%% same distribution. (The sources need not necessarily be +%% in the same archive or directory.) +%% +%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and +%% Arne John Glenstrup +%% +\expandafter\ifx\csname sem@nticsLoader\endcsname\relax + \PackageError{semantic}{% + This file should not be loaded directly} + {% + This file is an option of the semantic package. It should not be + loaded directly\MessageBreak + but by using \protect\usepackage{semantic} in your document + preamble.\MessageBreak + No commands are defined.\MessageBreak + Type to proceed. + }% +\else +\TestForConflict{\@getSymbol,\@interpreter,\@parseArg,\@program} +\TestForConflict{\@putSymbol,\@saveBeforeSymbolMacro,\compiler} +\TestForConflict{\interpreter,\machine,\program,\@compiler} +\newif\if@@Left +\newif\if@@Up +\newcount\@@xShift +\newcount\@@yShift +\newtoks\@@symbol +\newtoks\@@tempSymbol +\newcommand{\compiler}[1]{\@compiler#1\end} +\def\@compiler#1,#2,#3\end{% + \if@@Nested % + \if@@Up % + \@@yShift=40 \if@@Left \@@xShift=-50 \else \@@xShift=-30 \fi + \else% + \@@yShift=20 \@@xShift =0 % + \fi% + \else% + \@@yShift=40 \@@xShift=-40% + \fi + \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% + \put(0,0){\line(1,0){80}}% + \put(0,-20){\line(1,0){30}}% + \put(50,-20){\line(1,0){30}}% + \put(30,-40){\line(1,0){20}}% + \put(0,0){\line(0,-1){20}}% + \put(80,0){\line(0,-1){20}}% + \put(30,-20){\line(0,-1){20}}% + \put(50,-20){\line(0,-1){20}}% + \put(30,-20){\makebox(20,20){$\rightarrow$}} % + {\@@Uptrue \@@Lefttrue \@parseArg(0,-20)(5,-20)#1\end}% + \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi + {\@@Uptrue \@@Leftfalse \@parseArg(80,-20)(55,-20)#3\end}% + {\@@Upfalse \@@Lefttrue \@parseArg(50,-40)(30,-40)#2\end}% + \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi + \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi% + }% +} +\newcommand{\interpreter}[1]{\@interpreter#1\end} +\def\@interpreter#1,#2\end{% + \if@@Nested % + \if@@Up % + \@@yShift=40 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi + \else% + \@@yShift=0 \@@xShift =0 % + \fi% + \else% + \@@yShift=40 \@@xShift=10% + \fi + \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% + \put(0,0){\line(-1,0){20}}% + \put(0,-40){\line(-1,0){20}}% + \put(0,0){\line(0,-1){40}}% + \put(-20,0){\line(0,-1){40}}% + {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-20)#1\end}% + \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi + {\@@Upfalse \@@Lefttrue \@parseArg(0,-40)(-20,-40)#2\end}% + \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi + \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi% + }% +} +\newcommand{\program}[1]{\@program#1\end} +\def\@program#1,#2\end{% + \if@@Nested % + \if@@Up % + \@@yShift=0 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi + \else% + \PackageError{semantic}{% + A program cannot be at the bottom} + {% + You have tried to use a \protect\program\space as the + bottom\MessageBreak parameter to \protect\compiler, + \protect\interpreter\space or \protect\program.\MessageBreak + Type to proceed --- Output can be distorted.}% + \fi% + \else% + \@@yShift=0 \@@xShift=10% + \fi + \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% + \put(0,0){\line(-1,0){20}}% + \put(0,0){\line(0,1){30}}% + \put(-20,0){\line(0,1){30}}% + \put(-10,30){\oval(20,20)[t]}% + \@putSymbol[#1]{-20,20}% + {\@@Upfalse \@@Lefttrue \@parseArg(0,0)(-20,0)#2\end}% + }% +} +\newcommand{\machine}[1]{% + \if@@Nested % + \if@@Up % + \PackageError{semantic}{% + A machine cannot be at the top} + {% + You have tried to use a \protect\machine\space as a + top\MessageBreak parameter to \protect\compiler or + \protect\interpreter.\MessageBreak + Type to proceed --- Output can be distorted.}% + \else \@@yShift=0 \@@xShift=0 + \fi% + \else% + \@@yShift=20 \@@xShift=10% + \fi + \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% + \put(0,0){\line(-1,0){20}} \put(-20,0){\line(3,-5){10}} + \put(0,0){\line(-3,-5){10}}% + {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-15)#1\end}% + }% +} +\def\@parseArg(#1)(#2){% + \@ifNextMacro{\@doSymbolMacro(#1)(#2)}{\@getSymbol(#2)}} +\def\@getSymbol(#1)#2\end{\@putSymbol[#2]{#1}} +\def\@doSymbolMacro(#1)(#2)#3{% + \@ifnextchar[{\@saveBeforeSymbolMacro(#1)(#2)#3}% + {\@symbolMacro(#1)(#2)#3}} +\def\@saveBeforeSymbolMacro(#1)(#2)#3[#4]#5\end{% + \@@tempSymbol={#4}% + \@@Nestedtrue\put(#1){#3#5}% + \@putSymbol[\the\@@tempSymbol]{#2}} +\def\@symbolMacro(#1)(#2)#3\end{% + \@@Nestedtrue\put(#1){#3}% + \@putSymbol{#2}} +\newcommand{\@putSymbol}[2][\the\@@symbol]{% + \global\@@symbol=\expandafter{#1}% + \put(#2){\makebox(20,20){\texttt{\the\@@symbol}}}} +\fi +\endinput +%% +%% End of file `tdiagram.sty'. diff --git a/helm/software/components/tactics/eliminationTactics.ml b/helm/software/components/tactics/eliminationTactics.ml new file mode 100644 index 000000000..e98bcd3c8 --- /dev/null +++ b/helm/software/components/tactics/eliminationTactics.ml @@ -0,0 +1,217 @@ +(* 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/. + *) + +(* $Id$ *) + +module C = Cic +module P = PrimitiveTactics +module T = Tacticals +module S = ProofEngineStructuralRules +module F = FreshNamesGenerator +module E = ProofEngineTypes +module H = ProofEngineHelpers + +(* +let induction_tac ~term status = + let (proof, goal) = status in + 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 = CicUtil.lookup_meta 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 +;; +*) + +(* unexported tactics *******************************************************) + +let get_name context index = + try match List.nth context (pred index) with + | Some (Cic.Name name, _) -> Some name + | _ -> None + with Invalid_argument "List.nth" -> None + +let rec scan_tac ~old_context_length ~index ~tactic = + let scan_tac status = + let (proof, goal) = status in + let _, metasenv, _, _ = proof in + let _, context, _ = CicUtil.lookup_meta goal metasenv in + let context_length = List.length context in + let rec aux index = + match get_name context index with + | _ when index <= 0 -> (proof, [goal]) + | None -> aux (pred index) + | Some what -> + let tac = T.then_ ~start:(tactic ~what) + ~continuation:(scan_tac ~old_context_length:context_length ~index ~tactic) + in + try E.apply_tactic tac status + with E.Fail _ -> aux (pred index) + in aux (index + context_length - old_context_length - 1) + in + E.mk_tactic scan_tac + +let rec check_inductive_types types = function + | C.MutInd (uri, typeno, _) -> List.mem (uri, typeno) types + | C.Appl (hd :: tl) -> check_inductive_types types hd + | _ -> false + +let elim_clear_tac ~mk_fresh_name_callback ~types ~what = + let elim_clear_tac status = + let (proof, goal) = status in + let _, metasenv, _, _ = proof in + let _, context, _ = CicUtil.lookup_meta goal metasenv in + let index, ty = H.lookup_type metasenv context what in + if check_inductive_types types ty then + let tac = T.then_ ~start:(P.elim_intros_tac ~mk_fresh_name_callback (C.Rel index)) + ~continuation:(S.clear what) + in + E.apply_tactic tac status + else raise (E.Fail (lazy "unexported elim_clear: not an eliminable type")) + in + E.mk_tactic elim_clear_tac + +(* elim type ****************************************************************) + +let elim_type_tac ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) ?depth + ?using what += + let elim what = + P.elim_intros_simpl_tac ?using ?depth ~mk_fresh_name_callback what + in + let elim_type_tac status = + let tac = + T.thens ~start: (P.cut_tac what) ~continuations:[elim (C.Rel 1); T.id_tac] + in + E.apply_tactic tac status + in + E.mk_tactic elim_type_tac + +(* decompose ****************************************************************) + +(* robaglia --------------------------------------------------------------- *) + + (** perform debugging output? *) +let debug = false +let debug_print = fun _ -> () + + (** debugging print *) +let warn s = debug_print (lazy ("DECOMPOSE: " ^ (Lazy.force s))) + +(* search in term the Inductive Types and return a list of uris as triples like this: (uri,typeno,exp_named_subst) *) +let search_inductive_types ty = + let rec aux types = function + | C.MutInd (uri, typeno, _) when (not (List.mem (uri, typeno) types)) -> + (uri, typeno) :: types + | C.Appl applist -> List.fold_left aux types applist + | _ -> types + in + aux [] ty +(* N.B: in un caso tipo (and A forall C:Prop.(or B C)) l'or *non* viene selezionato! *) + +(* roba seria ------------------------------------------------------------- *) + +let decompose_tac ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) + ?(user_types=[]) ~dbd what = + let decompose_tac status = + let (proof, goal) = status in + let _, metasenv,_,_ = proof in + let _, context, _ = CicUtil.lookup_meta goal metasenv in + let types = List.rev_append user_types (FwdQueries.decomposables dbd) in + let tactic = elim_clear_tac ~mk_fresh_name_callback ~types in + let old_context_length = List.length context in + let tac = T.then_ ~start:(tactic ~what) + ~continuation:(scan_tac ~old_context_length ~index:1 ~tactic) + in + E.apply_tactic tac status + in + E.mk_tactic decompose_tac + +(* +module R = CicReduction + + let rec elim_clear_tac ~term' ~nr_of_hyp_still_to_elim status = + let (proof, goal) = status in + warn (lazy ("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,_ = CicUtil.lookup_meta goal metasenv in + let old_context_len = List.length context in + let termty,_ = + CicTypeChecker.type_of_aux' metasenv context term' + CicUniv.empty_ugraph in + warn (lazy ("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 (lazy ("elim " ^ CicPp.ppterm termty)); + ProofEngineTypes.apply_tactic + (T.then_ + ~start:(P.elim_intros_simpl_tac term') + ~continuation:( + (* clear the hyp that has just been eliminated *) + ProofEngineTypes.mk_tactic (fun status -> + let (proof, goal) = status in + let _,metasenv,_,_ = proof in + let _,context,_ = CicUtil.lookup_meta goal metasenv in + let new_context_len = List.length context in + warn (lazy ("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 + let hyp_name = + match List.nth context new_nr_of_hyp_still_to_elim with + None + | Some (Cic.Anonymous,_) -> assert false + | Some (Cic.Name name,_) -> name + in + ProofEngineTypes.apply_tactic + (T.then_ + ~start:( + if (term'==term) (* if it's the first application of elim, there's no need to clear the hyp *) + then begin debug_print (lazy ("%%%%%%% no clear")); T.id_tac end + else begin debug_print (lazy ("%%%%%%% clear " ^ (string_of_int (new_nr_of_hyp_still_to_elim)))); (S.clear ~hyp:hyp_name) end) + ~continuation:(ProofEngineTypes.mk_tactic (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 (lazy ("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 *) + ProofEngineTypes.apply_tactic T.id_tac status + + in + elim_clear_tac ~term':term ~nr_of_hyp_still_to_elim:1 status +*) diff --git a/helm/software/components/tactics/eliminationTactics.mli b/helm/software/components/tactics/eliminationTactics.mli new file mode 100644 index 000000000..cf6589f9a --- /dev/null +++ b/helm/software/components/tactics/eliminationTactics.mli @@ -0,0 +1,33 @@ +(* 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: + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic + +val decompose_tac: + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?user_types:((UriManager.uri * int) list) -> + dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/equalityTactics.ml b/helm/software/components/tactics/equalityTactics.ml new file mode 100644 index 000000000..da7f599a9 --- /dev/null +++ b/helm/software/components/tactics/equalityTactics.ml @@ -0,0 +1,356 @@ +(* 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/. + *) + +(* $Id$ *) + +let rec rewrite_tac ~direction ~(pattern: ProofEngineTypes.lazy_pattern) equality = + let _rewrite_tac ~direction ~pattern:(wanted,hyps_pat,concl_pat) equality status + = + let module C = Cic in + let module U = UriManager in + let module PET = ProofEngineTypes in + let module PER = ProofEngineReduction in + let module PEH = ProofEngineHelpers in + let module PT = PrimitiveTactics in + assert (wanted = None); (* this should be checked syntactically *) + let proof,goal = status in + let curi, metasenv, pbo, pty = proof in + let (metano,context,gty) = CicUtil.lookup_meta goal metasenv in + match hyps_pat with + he::(_::_ as tl) -> + PET.apply_tactic + (Tacticals.then_ + (rewrite_tac ~direction + ~pattern:(None,[he],None) equality) + (rewrite_tac ~direction ~pattern:(None,tl,concl_pat) equality) + ) status + | [_] as hyps_pat when concl_pat <> None -> + PET.apply_tactic + (Tacticals.then_ + (rewrite_tac ~direction + ~pattern:(None,hyps_pat,None) equality) + (rewrite_tac ~direction ~pattern:(None,[],concl_pat) equality) + ) status + | _ -> + let arg,dir2,tac,concl_pat,gty = + match hyps_pat with + [] -> None,true,(fun ~term _ -> PT.exact_tac term),concl_pat,gty + | [name,pat] -> + let rec find_hyp n = + function + [] -> assert false + | Some (Cic.Name s,Cic.Decl ty)::_ when name = s -> + Cic.Rel n, CicSubstitution.lift n ty + | Some (Cic.Name s,Cic.Def _)::_ -> assert false (*CSC: not implemented yet! But does this make any sense?*) + | _::tl -> find_hyp (n+1) tl + in + let arg,gty = find_hyp 1 context in + let dummy = "dummy" in + Some arg,false, + (fun ~term typ -> + Tacticals.seq + ~tactics: + [ProofEngineStructuralRules.rename name dummy; + PT.letin_tac + ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name name) term; + ProofEngineStructuralRules.clearbody name; + ReductionTactics.change_tac + ~pattern: + (None,[name,Cic.Implicit (Some `Hole)], None) + (ProofEngineTypes.const_lazy_term typ); + ProofEngineStructuralRules.clear dummy + ]), + Some pat,gty + | _::_ -> assert false + in + let if_right_to_left do_not_change a b = + match direction with + | `RightToLeft -> if do_not_change then a else b + | `LeftToRight -> if do_not_change then b else a + in + let ty_eq,ugraph = + CicTypeChecker.type_of_aux' metasenv context equality + CicUniv.empty_ugraph in + let (ty_eq,metasenv',arguments,fresh_meta) = + ProofEngineHelpers.saturate_term + (ProofEngineHelpers.new_meta_of_proof proof) metasenv context ty_eq 0 in + let equality = + if List.length arguments = 0 then + equality + else + C.Appl (equality :: arguments) in + (* t1x is t2 if we are rewriting in an hypothesis *) + let eq_ind, ty, t1, t2, t1x = + match ty_eq with + | C.Appl [C.MutInd (uri, 0, []); ty; t1; t2] + when LibraryObjects.is_eq_URI uri -> + let ind_uri = + if_right_to_left dir2 + LibraryObjects.eq_ind_URI LibraryObjects.eq_ind_r_URI + in + let eq_ind = C.Const (ind_uri uri,[]) in + if dir2 then + if_right_to_left true (eq_ind,ty,t2,t1,t2) (eq_ind,ty,t1,t2,t1) + else + if_right_to_left true (eq_ind,ty,t1,t2,t2) (eq_ind,ty,t2,t1,t1) + | _ -> raise (PET.Fail (lazy "Rewrite: argument is not a proof of an equality")) in + (* now we always do as if direction was `LeftToRight *) + let fresh_name = + FreshNamesGenerator.mk_fresh_name + ~subst:[] metasenv' context C.Anonymous ~typ:ty in + let lifted_t1 = CicSubstitution.lift 1 t1x in + let lifted_gty = CicSubstitution.lift 1 gty in + let lifted_conjecture = + metano,(Some (fresh_name,Cic.Decl ty))::context,lifted_gty in + let lifted_pattern = + let lifted_concl_pat = + match concl_pat with + | None -> None + | Some term -> Some (CicSubstitution.lift 1 term) in + Some (fun _ m u -> lifted_t1, m, u),[],lifted_concl_pat + in + let subst,metasenv',ugraph,_,selected_terms_with_context = + ProofEngineHelpers.select + ~metasenv:metasenv' ~ugraph ~conjecture:lifted_conjecture + ~pattern:lifted_pattern in + let metasenv' = CicMetaSubst.apply_subst_metasenv subst metasenv' in + let what,with_what = + (* Note: Rel 1 does not live in the context context_of_t *) + (* The replace_lifting_csc 0 function will take care of lifting it *) + (* to context_of_t *) + List.fold_right + (fun (context_of_t,t) (l1,l2) -> t::l1, Cic.Rel 1::l2) + selected_terms_with_context ([],[]) in + let t1 = CicMetaSubst.apply_subst subst t1 in + let t2 = CicMetaSubst.apply_subst subst t2 in + let equality = CicMetaSubst.apply_subst subst equality in + let abstr_gty = + ProofEngineReduction.replace_lifting_csc 0 + ~equality:(==) ~what ~with_what:with_what ~where:lifted_gty in + let abstr_gty = CicMetaSubst.apply_subst subst abstr_gty in + let pred = C.Lambda (fresh_name, ty, abstr_gty) in + (* The argument is either a meta if we are rewriting in the conclusion + or the hypothesis if we are rewriting in an hypothesis *) + let metasenv',arg,newtyp = + match arg with + None -> + let gty' = CicSubstitution.subst t2 abstr_gty in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + let metasenv' = (fresh_meta,context,gty')::metasenv' in + metasenv', C.Meta (fresh_meta,irl), Cic.Rel (-1) (* dummy term, never used *) + | Some arg -> + let gty' = CicSubstitution.subst t1 abstr_gty in + metasenv',arg,gty' + in + let exact_proof = + C.Appl [eq_ind ; ty ; t2 ; pred ; arg ; t1 ;equality] + in + let (proof',goals) = + PET.apply_tactic + (tac ~term:exact_proof newtyp) ((curi,metasenv',pbo,pty),goal) + in + let goals = + goals@(ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv + ~newmetasenv:metasenv') + in + (proof',goals) + in + ProofEngineTypes.mk_tactic (_rewrite_tac ~direction ~pattern equality) + + +let rewrite_simpl_tac ~direction ~pattern equality = + let rewrite_simpl_tac ~direction ~pattern equality status = + ProofEngineTypes.apply_tactic + (Tacticals.then_ + ~start:(rewrite_tac ~direction ~pattern equality) + ~continuation: + (ReductionTactics.simpl_tac + ~pattern:(ProofEngineTypes.conclusion_pattern None))) + status + in + ProofEngineTypes.mk_tactic (rewrite_simpl_tac ~direction ~pattern equality) +;; + +let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what = + let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what status = + let _wanted, hyps_pat, concl_pat = pattern in + let (proof, goal) = status in + let module C = Cic in + let module U = UriManager in + let module P = PrimitiveTactics in + let module T = Tacticals in + let uri,metasenv,pbo,pty = proof in + let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in + assert (hyps_pat = []); (*CSC: not implemented yet *) + let context_len = List.length context in + let subst,metasenv,u,_,selected_terms_with_context = + ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph + ~conjecture ~pattern in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + let with_what, metasenv, u = with_what context metasenv u in + let with_what = CicMetaSubst.apply_subst subst with_what in + let pbo = CicMetaSubst.apply_subst subst pbo in + let pty = CicMetaSubst.apply_subst subst pty in + let status = (uri,metasenv,pbo,pty),goal in + let ty_of_with_what,u = + CicTypeChecker.type_of_aux' + metasenv context with_what CicUniv.empty_ugraph in + let whats = + match selected_terms_with_context with + [] -> raise (ProofEngineTypes.Fail (lazy "Replace: no term selected")) + | l -> + List.map + (fun (context_of_t,t) -> + let t_in_context = + try + let context_of_t_len = List.length context_of_t in + if context_of_t_len = context_len then t + else + (let t_in_context,subst,metasenv' = + CicMetaSubst.delift_rels [] metasenv + (context_of_t_len - context_len) t + in + assert (subst = []); + assert (metasenv = metasenv'); + t_in_context) + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + (*CSC: we could implement something stronger by completely changing + the semantics of the tactic *) + raise (ProofEngineTypes.Fail + (lazy "Replace: one of the selected terms is not closed")) in + let ty_of_t_in_context,u = (* TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv context t_in_context + CicUniv.empty_ugraph in + let b,u = CicReduction.are_convertible ~metasenv context + ty_of_with_what ty_of_t_in_context u in + if b then + let concl_pat_for_t = ProofEngineHelpers.pattern_of ~term:ty [t] in + let pattern_for_t = None,[],Some concl_pat_for_t in + t_in_context,pattern_for_t + else + raise + (ProofEngineTypes.Fail + (lazy "Replace: one of the selected terms and the term to be replaced with have not convertible types")) + ) l in + let rec aux n whats status = + match whats with + [] -> ProofEngineTypes.apply_tactic T.id_tac status + | (what,lazy_pattern)::tl -> + let what = CicSubstitution.lift n what in + let with_what = CicSubstitution.lift n with_what in + let ty_of_with_what = CicSubstitution.lift n ty_of_with_what in + ProofEngineTypes.apply_tactic + (T.thens + ~start:( + P.cut_tac + (C.Appl [ + (C.MutInd (LibraryObjects.eq_URI (), 0, [])) ; + ty_of_with_what ; + what ; + with_what])) + ~continuations:[ + T.then_ + ~start:( + rewrite_tac ~direction:`LeftToRight ~pattern:lazy_pattern (C.Rel 1)) + ~continuation:( + T.then_ + ~start:( + ProofEngineTypes.mk_tactic + (function ((proof,goal) as status) -> + let _,metasenv,_,_ = proof in + let _,context,_ = CicUtil.lookup_meta goal metasenv in + let hyp = + try + match List.hd context with + Some (Cic.Name name,_) -> name + | _ -> assert false + with (Failure "hd") -> assert false + in + ProofEngineTypes.apply_tactic + (ProofEngineStructuralRules.clear ~hyp) status)) + ~continuation:(aux_tac (n + 1) tl)); + T.id_tac]) + status + and aux_tac n tl = ProofEngineTypes.mk_tactic (aux n tl) in + aux 0 whats status + in + ProofEngineTypes.mk_tactic (replace_tac ~pattern ~with_what) +;; + + +(* All these tacs do is applying the right constructor/theorem *) + +let reflexivity_tac = + IntroductionTactics.constructor_tac ~n:1 +;; + +let symmetry_tac = + let symmetry_tac (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 = CicUtil.lookup_meta goal metasenv in + match (R.whd context ty) with + (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) + when LibraryObjects.is_eq_URI uri -> + ProofEngineTypes.apply_tactic + (PrimitiveTactics.apply_tac + ~term: (C.Const (LibraryObjects.sym_eq_URI uri, []))) + (proof,goal) + + | _ -> raise (ProofEngineTypes.Fail (lazy "Symmetry failed")) + in + ProofEngineTypes.mk_tactic symmetry_tac +;; + +let transitivity_tac ~term = + let transitivity_tac ~term status = + let (proof, goal) = status in + 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 = CicUtil.lookup_meta goal metasenv in + match (R.whd context ty) with + (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) + when LibraryObjects.is_eq_URI uri -> + ProofEngineTypes.apply_tactic + (T.thens + ~start:(PrimitiveTactics.apply_tac + ~term: (C.Const (LibraryObjects.trans_eq_URI uri, []))) + ~continuations: + [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac]) + status + + | _ -> raise (ProofEngineTypes.Fail (lazy "Transitivity failed")) + in + ProofEngineTypes.mk_tactic (transitivity_tac ~term) +;; + + diff --git a/helm/software/components/tactics/equalityTactics.mli b/helm/software/components/tactics/equalityTactics.mli new file mode 100644 index 000000000..1d60ae149 --- /dev/null +++ b/helm/software/components/tactics/equalityTactics.mli @@ -0,0 +1,41 @@ +(* 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: + direction:[`LeftToRight | `RightToLeft] -> + pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> ProofEngineTypes.tactic + +val rewrite_simpl_tac: + direction:[`LeftToRight | `RightToLeft] -> + pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> ProofEngineTypes.tactic + +val replace_tac: + pattern:ProofEngineTypes.lazy_pattern -> + with_what:Cic.lazy_term -> ProofEngineTypes.tactic + +val reflexivity_tac: ProofEngineTypes.tactic +val symmetry_tac: ProofEngineTypes.tactic +val transitivity_tac: term:Cic.term -> ProofEngineTypes.tactic + diff --git a/helm/software/components/tactics/fourier.ml b/helm/software/components/tactics/fourier.ml new file mode 100644 index 000000000..d7728c0b3 --- /dev/null +++ b/helm/software/components/tactics/fourier.ml @@ -0,0 +1,244 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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;; + +*) diff --git a/helm/software/components/tactics/fourier.mli b/helm/software/components/tactics/fourier.mli new file mode 100644 index 000000000..8b26bc21a --- /dev/null +++ b/helm/software/components/tactics/fourier.mli @@ -0,0 +1,27 @@ +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 diff --git a/helm/software/components/tactics/fourierR.ml b/helm/software/components/tactics/fourierR.ml new file mode 100644 index 000000000..8b910bded --- /dev/null +++ b/helm/software/components/tactics/fourierR.ml @@ -0,0 +1,1201 @@ +(* 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/. + *) + +(* $Id$ *) + + +(******************** 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 +open ProofEngineTypes + + +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) -> + if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then + rat_of_unop rop next + else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then + rat_of_unop rinv next + else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then + rat_of_binop rmult next + else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then + rat_of_binop rdiv next + else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then + rat_of_binop rplus next + else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then + rat_of_binop rminus next + else failwith "not a rational" + | _ -> failwith "not a rational") + | Cic.Const (u,boh) -> + if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then r1 + else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then r0 + else failwith "not a rational" + | _ -> failwith "not a rational" +;; + +(* coq wrapper +let rational_of_const = rational_of_term;; +*) +let fails f a = + try + ignore (f a); + 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 + if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then + flin_emult (rop r1) (flin_of_term (List.hd next)) + else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then + fl_of_binop flin_plus next + else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then + fl_of_binop flin_minus next + else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then + 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 + else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then + let a=(rational_of_term (List.hd next)) in + flin_add_cste (flin_zero()) (rinv a) + else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then + 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 + else assert false + end + |_ -> assert false + end + | Cic.Const (u,boh) -> + begin + if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then flin_one () + else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then flin_zero () + else 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) -> + if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then + [{hname=h; + htype="Rlt"; + hleft=arg1; + hright=arg2; + hflin= flin_minus (flin_of_term arg1) + (flin_of_term arg2); + hstrict=true}] + else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then + [{hname=h; + htype="Rgt"; + hleft=arg2; + hright=arg1; + hflin= flin_minus (flin_of_term arg2) + (flin_of_term arg1); + hstrict=true}] + else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then + [{hname=h; + htype="Rle"; + hleft=arg1; + hright=arg2; + hflin= flin_minus (flin_of_term arg1) + (flin_of_term arg2); + hstrict=false}] + else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then + [{hname=h; + htype="Rge"; + hleft=arg2; + hright=arg1; + hflin= flin_minus (flin_of_term arg2) + (flin_of_term arg1); + hstrict=false}] + else assert false + | Cic.MutInd (u,i,o) -> + if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then + 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) -> + if UriManager.eq u HelmLibraryObjects.Reals.r_URI then + [{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}] + else assert false + |_-> assert false) + else 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(HelmLibraryObjects.Logic.eq_URI, 0, []) ;; +let _False = Cic.MutInd (HelmLibraryObjects.Logic.false_URI, 0, []) ;; +let _not = Cic.Const (HelmLibraryObjects.Logic.not_URI,[]);; +let _R0 = Cic.Const (HelmLibraryObjects.Reals.r0_URI,[]);; +let _R1 = Cic.Const (HelmLibraryObjects.Reals.r1_URI,[]);; +let _R = Cic.Const (HelmLibraryObjects.Reals.r_URI,[]);; +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 (HelmLibraryObjects.Reals.rinv_URI, []);; +let _Rinv_R1 = Cic.Const(HelmLibraryObjects.Reals.rinv_r1_URI, []);; +let _Rle = Cic.Const (HelmLibraryObjects.Reals.rle_URI, []);; +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 _Rlt = Cic.Const (HelmLibraryObjects.Reals.rlt_URI, []);; +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 (HelmLibraryObjects.Reals.rminus_URI, []);; +let _Rmult = Cic.Const (HelmLibraryObjects.Reals.rmult_URI, []);; +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 (HelmLibraryObjects.Reals.ropp_URI, []);; +let _Rplus = Cic.Const (HelmLibraryObjects.Reals.rplus_URI, []);; + +(******************************************************************************) + +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 + pall "n0" status _Rlt_zero_1 ; + apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in + let tacd=ref (mk_tactic (fun status -> + pall "d0" status _Rlt_zero_1 ; + apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in + + + for i=1 to n-1 do + tacn:=(Tacticals.then_ + ~start:(mk_tactic (fun status -> + pall ("n"^string_of_int i) status _Rlt_zero_pos_plus1; + apply_tactic + (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) + status)) + ~continuation:!tacn); + done; + for i=1 to d-1 do + tacd:=(Tacticals.then_ + ~start:(mk_tactic (fun status -> + pall "d" status _Rlt_zero_pos_plus1 ; + apply_tactic + (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) status)) + ~continuation:!tacd); + done; + +debug("TAC ZERO INF POS\n"); + apply_tactic + (Tacticals.thens + ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_mult_inv_pos) + ~continuations:[!tacn ;!tacd ] ) + status + in + mk_tactic (tac_zero_inf_pos (n,d)) +;; + + + +(* preuve que 0<=n*1/d +*) + +let tac_zero_infeq_pos gl (n,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; + apply_tactic + (Tacticals.thens + ~start:(PrimitiveTactics.apply_tac ~term:_Rle_mult_inv_pos) + ~continuations:[!tacn;!tacd]) status + in + mk_tactic (tac_zero_infeq_pos gl (n,d)) +;; + + + +(* preuve que 0<(-n)*(1/d) => False +*) + +let tac_zero_inf_false gl (n,d) = + let tac_zero_inf_false gl (n,d) status = + if n=0 then + apply_tactic (PrimitiveTactics.apply_tac ~term:_Rnot_lt0) status + else + apply_tactic (Tacticals.then_ + ~start:(mk_tactic (apply_tactic (PrimitiveTactics.apply_tac ~term:_Rle_not_lt))) + ~continuation:(tac_zero_infeq_pos gl (-n,d))) + status + in + mk_tactic (tac_zero_inf_false gl (n,d)) +;; + +(* preuve que 0<=n*(1/d) => False ; n est negatif +*) + +let tac_zero_infeq_false gl (n,d) = + let tac_zero_infeq_false gl (n,d) status = + let (proof, goal) = status in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta 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 *) + apply_tactic + (Tacticals.then_ + ~start: + (ReductionTactics.fold_tac + ~reduction:(const_lazy_reduction CicReduction.whd) + ~pattern:(ProofEngineTypes.conclusion_pattern None) + ~term: + (const_lazy_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 + mk_tactic (tac_zero_infeq_false gl (n,d)) +;; + + +(* *********** ********** ******** ??????????????? *********** **************) + +let apply_type_tac ~cast:t ~applist:al = + let apply_type_tac ~cast:t ~applist:al (proof,goal) = + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in + let irl = + CicMkImplicit.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 = + apply_tactic + (PrimitiveTactics.apply_tac + (*~term:(Cic.Appl ((Cic.Cast (Cic.Meta (fresh_meta,irl),t))::al)) *) + ~term:(Cic.Appl ((Cic.Meta (fresh_meta,irl))::al))) (* ??? *) + (proof',goal) + in + proof'',fresh_meta::goals + in + mk_tactic (apply_type_tac ~cast:t ~applist:al) +;; + +let my_cut ~term:c = + let my_cut ~term:c (proof,goal) = + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in + let irl = + CicMkImplicit.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_tactic + (apply_type_tac + ~cast:(Cic.Prod(Cic.Name "Anonymous",c,CicSubstitution.lift 1 ty)) + ~applist:[Cic.Meta(fresh_meta,irl)]) + (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 + in + mk_tactic (my_cut ~term:c) +;; + +let exact = PrimitiveTactics.exact_tac;; + +let tac_use h = + let tac_use h status = + let (proof, goal) = status in + debug("Inizio TC_USE\n"); + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + debug ("hname = "^ CicPp.ppterm h.hname ^"\n"); + debug ("ty = "^ CicPp.ppterm ty^"\n"); + apply_tactic + (match h.htype with + "Rlt" -> exact ~term:h.hname + | "Rle" -> exact ~term:h.hname + | "Rgt" -> (Tacticals.then_ + ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_gt_to_lt) + ~continuation:(exact ~term:h.hname)) + | "Rge" -> (Tacticals.then_ + ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_ge_to_le) + ~continuation:(exact ~term:h.hname)) + | "eqTLR" -> (Tacticals.then_ + ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqLR_to_le) + ~continuation:(exact ~term:h.hname)) + | "eqTRL" -> (Tacticals.then_ + ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqRL_to_le) + ~continuation:(exact ~term:h.hname)) + | _->assert false) + status + in + mk_tactic (tac_use h) +;; + +let is_ineq (h,t) = + match t with + Cic.Appl ( Cic.Const(u,boh)::next) -> + (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI or + UriManager.eq u HelmLibraryObjects.Reals.rgt_URI or + UriManager.eq u HelmLibraryObjects.Reals.rle_URI or + UriManager.eq u HelmLibraryObjects.Reals.rge_URI then true + else if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then + (match (List.hd next) with + Cic.Const (uri,_) when + UriManager.eq uri HelmLibraryObjects.Reals.r_URI + -> true + | _ -> false) + else 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 -> + [(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,None))::next -> + [Some(name,Cic.Def((CicSubstitution.lift n a),None))]@ superlift next (n+1) + | Some(name,Cic.Def(a,Some ty))::next -> + [Some(name, + Cic.Def((CicSubstitution.lift n a),Some (CicSubstitution.lift n ty))) + ] @ superlift next (n+1) + | _::next -> superlift next (n+1) (*?? ??*) + +;; + +let equality_replace a b = + 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 = CicUtil.lookup_meta goal metasenv in + let a_eq_b = C.Appl [ _eqT ; _R ; a ; b ] in + let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in + let irl = + CicMkImplicit.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) = apply_tactic + (EqualityTactics.rewrite_simpl_tac + ~direction:`LeftToRight + ~pattern:(ProofEngineTypes.conclusion_pattern None) + (C.Meta (fresh_meta,irl))) + ((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) + in + mk_tactic (equality_replace a b) +;; + +let tcl_fail a (proof,goal) = + match a with + 1 -> raise (ProofEngineTypes.Fail (lazy "fail-tactical")) + | _ -> (proof,[goal]) +;; + +(* Galla: moved in variousTactics.ml +let assumption_tac (proof,goal)= + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta 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.first ~tactics:tac_list (proof,goal) +;; +*) +(* Galla: moved in negationTactics.ml +(* !!!!! fix !!!!!!!!!! *) +let contradiction_tac (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)) + (proof,goal) +;; +*) + +(* ********************* TATTICA ******************************** *) + +let rec fourier (s_proof,s_goal)= + let s_curi,s_metasenv,s_pbo,s_pty = s_proof in + let s_metano,s_context,s_ty = CicUtil.lookup_meta s_goal s_metasenv in + debug ("invoco fourier_tac sul goal "^string_of_int(s_goal)^" e contesto:\n"); + debug_pcontext s_context; + +(* 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) -> + th_to_appl := + (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then + _Rfourier_not_ge_lt + else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then + _Rfourier_not_gt_le + else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then + _Rfourier_not_le_gt + else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then + _Rfourier_not_lt_ge + else 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 = apply_tactic + (Tacticals.then_ + ~start:(PrimitiveTactics.apply_tac ~term:!th_to_appl) + ~continuation:(PrimitiveTactics.intros_tac ())) + (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 = CicUtil.lookup_meta 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 ( mk_tactic (fun status -> + apply_tactic + (if h1.hstrict then + (Tacticals.thens + ~start:(mk_tactic (fun status -> + debug ("inizio t1 strict\n"); + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + debug ("th = "^ CicPp.ppterm _Rfourier_lt ^"\n"); + debug ("ty = "^ CicPp.ppterm ty^"\n"); + apply_tactic + (PrimitiveTactics.apply_tac ~term:_Rfourier_lt) status)) + ~continuations:[tac_use h1; + tac_zero_inf_pos (rational_to_fraction c1)]) + 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:(mk_tactic (fun status -> + debug("INIZIO TAC 1 2\n"); + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + debug ("th = "^ CicPp.ppterm _Rfourier_lt_le ^"\n"); + debug ("ty = "^ CicPp.ppterm ty^"\n"); + apply_tactic + (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)) (* end fun -> *) + 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.then_ + ~start:( mk_tactic (fun status -> + let (proof, goal) = status in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + apply_tactic + (ReductionTactics.change_tac + ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty)) + (const_lazy_term (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:(mk_tactic (fun status -> + debug("t1 ="^CicPp.ppterm !t1 ^"t2 ="^ + CicPp.ppterm !t2 ^"tc="^ CicPp.ppterm tc^"\n"); + let r = apply_tactic + (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:(mk_tactic (fun status -> + let r = apply_tactic + (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.first + ~tactics:[ "ring",Ring.ring_tac; "id", Tacticals.id_tac] + ]) + ;(*Tacticals.id_tac*) + Tacticals.then_ + ~start:(mk_tactic (fun status -> + let (proof, goal) = status in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta 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 = apply_tactic + (ReductionTactics.change_tac + ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty)) + (const_lazy_term 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 = apply_tactic !tac (proof,goal) in + debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r + + ) +;; + +let fourier_tac = mk_tactic fourier + + diff --git a/helm/software/components/tactics/fourierR.mli b/helm/software/components/tactics/fourierR.mli new file mode 100644 index 000000000..e5790ec0f --- /dev/null +++ b/helm/software/components/tactics/fourierR.mli @@ -0,0 +1,5 @@ +(* +val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic +val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic +*) +val fourier_tac: ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/fwdSimplTactic.ml b/helm/software/components/tactics/fwdSimplTactic.ml new file mode 100644 index 000000000..0bae64f6c --- /dev/null +++ b/helm/software/components/tactics/fwdSimplTactic.ml @@ -0,0 +1,144 @@ +(* 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/. + *) + +(* $Id$ *) + +module PEH = ProofEngineHelpers +module U = CicUniv +module TC = CicTypeChecker +module PET = ProofEngineTypes +module S = CicSubstitution +module PT = PrimitiveTactics +module T = Tacticals +module FNG = FreshNamesGenerator +module MI = CicMkImplicit +module PESR = ProofEngineStructuralRules + +let fail_msg0 = "unexported clearbody: invalid argument" +let fail_msg2 = "fwd: no applicable simplification" + +let error msg = raise (PET.Fail (lazy msg)) + +(* unexported tactics *******************************************************) + +let id_tac = + let id_tac (proof,goal) = + try + let _, metasenv, _, _ = proof in + let _, _, _ = CicUtil.lookup_meta goal metasenv in + (proof,[goal]) + with CicUtil.Meta_not_found _ -> (proof, []) + in + PET.mk_tactic id_tac + +let clearbody ~index = + let rec find_name index = function + | Some (Cic.Name name, _) :: _ when index = 1 -> name + | _ :: tail when index > 1 -> find_name (pred index) tail + | _ -> error fail_msg0 + in + let clearbody status = + let (proof, goal) = status in + let _, metasenv, _, _ = proof in + let _, context, _ = CicUtil.lookup_meta goal metasenv in + PET.apply_tactic (PESR.clearbody ~hyp:(find_name index context)) status + in + PET.mk_tactic clearbody + +(* lapply *******************************************************************) + +let strip_prods metasenv context ?how_many to_what term = + let irl = MI.identity_relocation_list_for_metavariable context in + let mk_meta metasenv its_type = + let index = MI.new_meta metasenv [] in + let metasenv = [index, context, its_type] @ metasenv in + metasenv, Cic.Meta (index, irl), index + in + let update_counters = function + | None, [] -> None, false, id_tac, [] + | None, to_what :: tail -> None, true, PT.apply_tac ~term:to_what, tail + | Some hm, [] -> Some (pred hm), false, id_tac, [] + | Some hm, to_what :: tail -> Some (pred hm), true, PT.apply_tac ~term:to_what, tail + in + let rec aux metasenv metas conts tw = function + | Some hm, _ when hm <= 0 -> metasenv, metas, conts + | xhm, Cic.Prod (Cic.Name _, t1, t2) -> + let metasenv, meta, index = mk_meta metasenv t1 in + aux metasenv (meta :: metas) (conts @ [id_tac, index]) tw (xhm, (S.subst meta t2)) + | xhm, Cic.Prod (Cic.Anonymous, t1, t2) -> + let xhm, pos, tac, tw = update_counters (xhm, tw) in + let metasenv, meta, index = mk_meta metasenv t1 in + let conts = if pos then (tac, index) :: conts else conts @ [tac, index] in + aux metasenv (meta :: metas) conts tw (xhm, (S.subst meta t2)) + | _, t -> metasenv, metas, conts + in + aux metasenv [] [] to_what (how_many, term) + +let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + (* ?(substs = []) *) ?how_many ?(to_what = []) what = + let letin_tac term = PT.letin_tac ~mk_fresh_name_callback term in + let lapply_tac (proof, goal) = + let xuri, metasenv, u, t = proof in + let _, context, _ = CicUtil.lookup_meta goal metasenv in + let lemma, _ = TC.type_of_aux' metasenv context what U.empty_ugraph in + let lemma = FNG.clean_dummy_dependent_types lemma in + let metasenv, metas, conts = strip_prods metasenv context ?how_many to_what lemma in + let conclusion = + match metas with [] -> what | _ -> Cic.Appl (what :: List.rev metas) + in + let tac = T.then_ ~start:(letin_tac conclusion) + ~continuation:(clearbody ~index:1) + in + let proof = (xuri, metasenv, u, t) in + let aux (proof, goals) (tac, goal) = + let proof, new_goals = PET.apply_tactic tac (proof, goal) in + proof, goals @ new_goals + in + List.fold_left aux (proof, []) ((tac, goal) :: conts) + in + PET.mk_tactic lapply_tac + +(* fwd **********************************************************************) + +let fwd_simpl_tac + ?(mk_fresh_name_callback = FNG.mk_fresh_name ~subst:[]) + ~dbd hyp = + let lapply_tac to_what lemma = + lapply_tac ~mk_fresh_name_callback ~how_many:1 ~to_what:[to_what] lemma + in + let fwd_simpl_tac status = + let (proof, goal) = status in + let _, metasenv, _, _ = proof in + let _, context, ty = CicUtil.lookup_meta goal metasenv in + let index, major = PEH.lookup_type metasenv context hyp in + match FwdQueries.fwd_simpl ~dbd major with + | [] -> error fail_msg2 + | uri :: _ -> + Printf.eprintf "fwd: %s\n" (UriManager.string_of_uri uri); flush stderr; + let start = lapply_tac (Cic.Rel index) (Cic.Const (uri, [])) in + let tac = T.then_ ~start ~continuation:(PESR.clear hyp) in + PET.apply_tactic tac status + in + PET.mk_tactic fwd_simpl_tac diff --git a/helm/software/components/tactics/fwdSimplTactic.mli b/helm/software/components/tactics/fwdSimplTactic.mli new file mode 100644 index 000000000..d75b83320 --- /dev/null +++ b/helm/software/components/tactics/fwdSimplTactic.mli @@ -0,0 +1,32 @@ +(* 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 lapply_tac: + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?how_many:int -> ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic + +val fwd_simpl_tac: + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/hashtbl_equiv.ml b/helm/software/components/tactics/hashtbl_equiv.ml new file mode 100644 index 000000000..86448268c --- /dev/null +++ b/helm/software/components/tactics/hashtbl_equiv.ml @@ -0,0 +1,190 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 8/09/2004 *) +(* *) +(* *) +(*********************************************************************) + +(* $Id$ *) + +(* the file contains an hash table of objects of the library + equivalent to some object in the standard subset; it is + mostly used to filter useless cases in auto *) + + +let equivalent_objects = +(* finte costanti; i.e. costanti senza corpo *) +[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack0.con"(*,"finte costanti"*); + UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ac10.con"(*,"finte costanti"*); + UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack2.con"(*,"finte costanti"*) + ]@ +(* inutili mostri *) +[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg0.con"(*,"useless monster"*); + UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg1.con"(*,"useless monster"*); + UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/ResAck0.con"(*,"useless monster"*) + ]@ +(* istanze *) + (UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"*)):: +[ +UriManager.uri_of_string "cic:/Paris/ZF/src/useful/lem_iff_sym.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/iff_sym.con"*); +UriManager.uri_of_string "cic:/Lyon/AUTOMATA/Ensf_types/False_imp_P.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/Rfunctions/sum_f_R0_triangle.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Misc/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_not_and.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/or_not_and.con"*); +UriManager.uri_of_string "cic:/Rocq/DEMOS/Sorting/diff_true_false.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/diff_true_false.con"*); +UriManager.uri_of_string "cic:/CoRN/metrics/CMetricSpaces/nz.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Max/le_max_l.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/Decidable/not_or.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); +UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_eq.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_sqrt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_def.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eqT2eq.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_eq_0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rsqr_0_uniq.con"*); +UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/en_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_10.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_pos.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*); +UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/le.ind#xpointer(1/1/1)"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_n_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"*); +UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor1.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_diag_eq_mult_2.con"*); +UriManager.uri_of_string "cic:/Coq/Relations/Newman/caseRxy.con"(*,UriManager.uri_of_string "cic:/Coq/Relations/Newman/Ind_proof.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/S_plus_r.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_n_Sm.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zmult_ab0a0b0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_integral.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax8.con"(*,UriManager.uri_of_string "cic:/Coq/NArith/BinPos/ZC2.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/Zlt_reg_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat_l.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*); +UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_1.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Classic.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_pos_lt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_sqr.con"*); +UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo_def/sin_antisym.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo/sin_neg.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/false_implies_everything.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*); +UriManager.uri_of_string "cic:/Coq/ring/Setoid_ring_normalize/index_eq_prop.con"(*,UriManager.uri_of_string "cic:/Coq/ring/Ring_normalize/index_eq_prop.con"*); +UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_pred.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_pred.con"*); +UriManager.uri_of_string "cic:/Lannion/continuations/FOUnify_cps/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*); +UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_right.con"(*,UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_cons.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_compat_l.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rplus_lt_0_compat.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/DiscrR/Rplus_lt_pos.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*); +UriManager.uri_of_string "cic:/CoRN/fta/KeyLemma/lem_1c.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); +UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA20.con"(*,UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA17.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_2.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/injective_projections.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*); +UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zle_lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_lt_compat.con"*); +UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); +UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/not_gt_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_gt.con"*); +UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*); +UriManager.uri_of_string "cic:/CoRN/algebra/Basics/lt_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_lt_compat_r.con"*); +UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_neg.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_non_eq.con"*); +UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_Sn_m.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Qhomographic_Qpositive_to_Qpositive/one_non_negative.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zle_0_1.con"*); +UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rle_0_1.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/proof_irrel.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*); +UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_eq.con"*); +UriManager.uri_of_string "cic:/Coq/IntMap/Mapiter/pair_sp.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/ProofIrrelevance/proof_irrelevance_cci.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_or_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_and_or.con"*); +UriManager.uri_of_string "cic:/CoRN/model/structures/Zsec/Zplus_wd0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_eq_compat.con"*); +UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor6.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_0_r_reverse.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/S_inj.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*); +UriManager.uri_of_string "cic:/Coq/ZArith/Wf_Z/Z_of_nat_complete.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/IZN.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_orb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/orb_comm.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/PartSum/plus_sum.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Cauchy_prod/sum_plus.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Qpositive/minus_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); +UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_zero.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1_auto/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_andb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/andb_comm.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/canonicite/Prelude0/Morgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/TrueP.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/FalseP.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zminus_eq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zminus_eq.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_1.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*); +UriManager.uri_of_string "cic:/Orsay/Maths/divide/Zabs_ind.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_ind.con"*); +UriManager.uri_of_string "cic:/CoRN/algebra/Basics/Zmult_minus_distr_r.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_minus_distr_l.con"*); +UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/Sn_eq_Sm_n_eq_m.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*); +UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"*); +UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA2.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/P_Rmin.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/P_Rmin.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Huffman/Aux/le_minus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); +UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_O_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_l.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/Berardi/inv2.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Berardi/AC.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/SeqProp/not_Rlt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rnot_lt_ge.con"*); +UriManager.uri_of_string "cic:/Nancy/FOUnify/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_le_0_compat.con"*); +UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le_sym.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_Zmult.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_n_O.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); +UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_mult.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat.con"*); +UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_true2.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_left.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_l.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax3.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zgt_pos_0.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_triangle.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Buchberger/Buch/Sdep.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/prod_ind.con"*); +UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rsum_abs.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*); +UriManager.uri_of_string "cic:/Cachan/SMC/mu/minus_n_m_le_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); +UriManager.uri_of_string "cic:/Marseille/GC/lib_arith/lib_S_pred/eqnm_eqSnSm.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/predminus1.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/pred_of_minus.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/Rpower_pow.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/Rpower_pow.con"*); +UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*); +UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_neq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zlt_not_eq.con"*); +UriManager.uri_of_string "cic:/Coq/Arith/Lt/nat_total_order.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_eq.con"*); +UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/2)"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/1)"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zmult_pos_pos.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_O_compat.con"*); +UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zlt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat.con"*); +UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/pred_ext_and_rel_choice_imp_EM.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*); +UriManager.uri_of_string "cic:/Sophia-Antipolis/Rsa/MiscRsa/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*) +] +;; + +let equiv_table = Hashtbl.create 503 +;; + +let _ = List.iter (fun a -> Hashtbl.add equiv_table a "") equivalent_objects +;; + +let not_a_duplicate u = + try + ignore(Hashtbl.find equiv_table u); false + with + Not_found -> true +;; diff --git a/helm/software/components/tactics/hashtbl_equiv.mli b/helm/software/components/tactics/hashtbl_equiv.mli new file mode 100644 index 000000000..d2608b862 --- /dev/null +++ b/helm/software/components/tactics/hashtbl_equiv.mli @@ -0,0 +1,38 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 8/09/2004 *) +(* *) +(* *) +(*********************************************************************) + + +val not_a_duplicate : UriManager.uri -> bool + diff --git a/helm/software/components/tactics/history.ml b/helm/software/components/tactics/history.ml new file mode 100644 index 000000000..7559f367e --- /dev/null +++ b/helm/software/components/tactics/history.ml @@ -0,0 +1,86 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception History_failure + +class ['a] history size = + let unsome = function Some x -> x | None -> assert false in + object (self) + + val history_data = Array.create (size + 1) None + + val mutable history_hd = 0 (* rightmost index *) + val mutable history_cur = 0 (* current index *) + val mutable history_tl = 0 (* leftmost index *) + + method private is_empty = history_data.(history_cur) = None + + method push (status: 'a) = + if self#is_empty then + history_data.(history_cur) <- Some status + else begin + history_cur <- (history_cur + 1) mod size; + history_data.(history_cur) <- Some status; + history_hd <- history_cur; (* throw away fake future line *) + if history_hd = history_tl then (* tail overwritten *) + history_tl <- (history_tl + 1) mod size + end + + method undo = function + | 0 -> unsome history_data.(history_cur) + | steps when steps > 0 -> + let max_undo_steps = + if history_cur >= history_tl then + history_cur - history_tl + else + history_cur + (size - history_tl) + in + if steps > max_undo_steps then + raise History_failure; + history_cur <- history_cur - steps; + if history_cur < 0 then (* fix underflow *) + history_cur <- size + history_cur; + unsome history_data.(history_cur) + | steps (* when steps > 0 *) -> self#redo ~-steps + + method redo = function + | 0 -> unsome history_data.(history_cur) + | steps when steps > 0 -> + let max_redo_steps = + if history_hd >= history_cur then + history_hd - history_cur + else + history_hd + (size - history_cur) + in + if steps > max_redo_steps then + raise History_failure; + history_cur <- (history_cur + steps) mod size; + unsome history_data.(history_cur) + | steps (* when steps > 0 *) -> self#undo ~-steps + + end + diff --git a/helm/software/components/tactics/history.mli b/helm/software/components/tactics/history.mli new file mode 100644 index 000000000..86bad463f --- /dev/null +++ b/helm/software/components/tactics/history.mli @@ -0,0 +1,35 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +exception History_failure + +class ['a] history : + int -> + object + method push : 'a -> unit + method redo : int -> 'a + method undo : int -> 'a + end + diff --git a/helm/software/components/tactics/introductionTactics.ml b/helm/software/components/tactics/introductionTactics.ml new file mode 100644 index 000000000..9ed3647c1 --- /dev/null +++ b/helm/software/components/tactics/introductionTactics.ml @@ -0,0 +1,49 @@ +(* 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/. + *) + +(* $Id$ *) + +let fake_constructor_tac ~n (proof, goal) = + let module C = Cic in + let module R = CicReduction in + let (_,metasenv,_,_) = proof in + let metano,context,ty = CicUtil.lookup_meta 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))::_)) -> + ProofEngineTypes.apply_tactic ( + PrimitiveTactics.apply_tac + ~term: (C.MutConstruct (uri, typeno, n, exp_named_subst))) + (proof, goal) + | _ -> raise (ProofEngineTypes.Fail (lazy "Constructor: failed")) +;; + +let constructor_tac ~n = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n) + +let exists_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; +let split_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; +let left_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; +let right_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:2) ;; + diff --git a/helm/software/components/tactics/introductionTactics.mli b/helm/software/components/tactics/introductionTactics.mli new file mode 100644 index 000000000..c3a12720b --- /dev/null +++ b/helm/software/components/tactics/introductionTactics.mli @@ -0,0 +1,31 @@ +(* 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 diff --git a/helm/software/components/tactics/inversion.ml b/helm/software/components/tactics/inversion.ml new file mode 100644 index 000000000..5e442657d --- /dev/null +++ b/helm/software/components/tactics/inversion.ml @@ -0,0 +1,252 @@ +(* 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/. + *) + +(* $Id$ *) + +exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple +exception NotAnInductiveTypeToEliminate + +let debug = false;; +let debug_print = + fun msg -> if debug then prerr_endline (Lazy.force msg) else () + + +let inside_obj = function + | Cic.InductiveDefinition (l,params, nleft, _) -> + (l,params,nleft) + | _ -> raise (Invalid_argument "Errore in inside_obj") + +let term_to_list = function + | Cic.Appl l -> l + | _ -> raise (Invalid_argument "Errore in term_to_list") + + +let rec baseuri_of_term = function + | Cic.Appl l -> baseuri_of_term (List.hd l) + | Cic.MutInd (baseuri, tyno, []) -> baseuri + | _ -> raise (Invalid_argument "baseuri_of_term") + + +(* prende il numero dei parametri sinistri, la lista dei parametri, la lista +dei tipi dei parametri, il tipo del GOAL e costruisce il termine per la cut +ossia DX1 = DX1 -> ... DXn=DXn -> GOALTY *) + +let rec foo_cut nleft l param_ty_l body uri_of_eq = + if nleft > 0 then foo_cut (nleft-1) (List.tl l) (List.tl param_ty_l) body + uri_of_eq + else match l with + | hd::tl -> Cic.Prod (Cic.Anonymous, Cic.Appl[Cic.MutInd (uri_of_eq ,0,[]); + (List.hd param_ty_l) ; hd; hd], foo_cut nleft + (List.map (CicSubstitution.lift 1) tl) (List.tl param_ty_l) + (CicSubstitution.lift 1 body) uri_of_eq ) + | [] -> body + ;; + +(* da una catena di prod costruisce una lista dei termini che lo compongono.*) +let rec list_of_prod term = +match term with + | Cic.Prod (Cic.Anonymous,src,tgt) -> [src] @ (list_of_prod tgt) + | _ -> [term] +;; + + +let rec cut_first n l = + if n>0 then + match l with + | hd::tl -> cut_first (n-1) tl + | [] -> [] + else l +;; + + +let rec cut_last l = +match l with + | hd::tl when tl != [] -> hd:: (cut_last tl) + | _ -> [] +;; + + +let foo_appl nleft nright_consno term uri = + let l = [] in + let a = ref l in + for n = 1 to nleft do + a := !a @ [(Cic.Implicit None)] + done; + a:= !a @ [term]; + for n = 1 to nright_consno do + a := !a @ [(Cic.Implicit None)] + done; + Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1]) (*L'ipotesi e' sempre Rel 1. (?) *) +;; + + +let rec foo_prod nright param_ty_l l l2 base_rel body uri_of_eq nleft termty + isSetType term = + match param_ty_l with + | hd::tl -> Cic.Prod ( + Cic.Anonymous, + Cic.Appl[Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd l); Cic.Rel base_rel], + foo_prod (nright-1) tl (List.map (CicSubstitution.lift 1) (List.tl l)) + (List.map (CicSubstitution.lift 1) l2) + base_rel (CicSubstitution.lift 1 body) + uri_of_eq nleft (CicSubstitution.lift 1 termty) + isSetType (CicSubstitution.lift 1 term)) + | [] -> ProofEngineReduction.replace_lifting + ~equality:(ProofEngineReduction.alpha_equivalence) + ~what: (if isSetType + then ((cut_first (1+nleft) (term_to_list termty) ) @ [term] ) + else (cut_first (1+nleft) (term_to_list termty) ) ) + ~with_what: (List.map (CicSubstitution.lift (-1)) l2) + ~where:body +(*TODO lo stesso sottotermine di body puo' essere sia sx che dx!*) +;; + +let rec foo_lambda nright param_ty_l nright_ param_ty_l_ l l2 base_rel body + uri_of_eq nleft termty isSetType ty_indty term = + (*assert nright >0 *) + match param_ty_l with + | hd::tl ->Cic.Lambda ( + (Cic.Name ("lambda" ^ (string_of_int nright))), + hd, (* typ *) + foo_lambda (nright-1) tl nright_ param_ty_l_ + (List.map (CicSubstitution.lift 1) l) + (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1])) + base_rel (CicSubstitution.lift 1 body) + uri_of_eq nleft + (CicSubstitution.lift 1 termty) + isSetType ty_indty + (CicSubstitution.lift 1 term)) + | [] when isSetType -> Cic.Lambda ( + (Cic.Name ("lambda" ^ (string_of_int nright))), + (ProofEngineReduction.replace_lifting + ~equality:(ProofEngineReduction.alpha_equivalence) + ~what: (cut_first (1+nleft) (term_to_list termty) ) + ~with_what: (List.map (CicSubstitution.lift (-1)) l2) + ~where:termty), (* tipo di H con i parametri destri sostituiti *) + foo_prod nright_ param_ty_l_ (List.map (CicSubstitution.lift 1) l) + (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1])) + (base_rel+1) (CicSubstitution.lift 1 body) + uri_of_eq nleft + (CicSubstitution.lift 1 termty) isSetType + (CicSubstitution.lift 1 term)) + | [] -> foo_prod nright_ param_ty_l_ l l2 base_rel body uri_of_eq nleft + termty isSetType term +;; + +let inversion_tac ~term = + let module T = CicTypeChecker in + let module R = CicReduction in + let module C = Cic in + let module P = PrimitiveTactics in + let module PET = ProofEngineTypes in + let module PEH = ProofEngineHelpers in + let inversion_tac ~term (proof, goal) = + let (_,metasenv,_,_) = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let uri_of_eq = HelmLibraryObjects.Logic.eq_URI in + + (* dall'indice che indentifica il goal nel metasenv, ritorna il suo tipo, che + e' la terza componente della relativa congettura *) + let (_,_,body) = CicUtil.lookup_meta goal metasenv in + (* estrae il tipo del termine(ipotesi) oggetto di inversion, + di solito un Cic.Appl *) + let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in + let uri = baseuri_of_term termty in + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + let l,params,nleft = inside_obj o in + let (_,_,typeno,_) = + 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 = UriManager.buri_of_uri uri in + let name = + match o with + C.InductiveDefinition (tys,_,_,_) -> + let (name,_,_,_) = List.nth tys typeno in + name + |_ -> assert false + in + let ext = "_ind" in + UriManager.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con") + in + (* il tipo del tipo induttivo da cui viene l'ipotesi oggetto di inversione *) + let (_,_,ty_indty,cons_list) = (List.hd l) in + (*la lista di Cic.term ricavata dal tipo del tipo induttivo. *) + let param_ty_l = list_of_prod ty_indty in + let consno = List.length cons_list in + let nright= (List.length param_ty_l)- (nleft+1) in + let isSetType = ((Pervasives.compare + (List.nth param_ty_l ((List.length param_ty_l)-1)) + (Cic.Sort Cic.Prop)) != 0) + in + (* eliminiamo la testa di termty, in quanto e' il nome del predicato e non un parametro.*) + let cut_term = foo_cut nleft (List.tl (term_to_list termty)) + (list_of_prod ty_indty) body uri_of_eq in + (* cut DXn=DXn \to GOAL *) + let proof1,gl1 = PET.apply_tactic (P.cut_tac cut_term) (proof,goal) in + (* apply Hcut ; reflexivity (su tutti i goals aperti da apply_tac) *) + let proof2, gl2 = PET.apply_tactic + (Tacticals.then_ + ~start: (P.apply_tac (C.Rel 1)) (* apply Hcut *) + ~continuation: (EqualityTactics.reflexivity_tac) + ) (proof1, (List.hd gl1)) + in + (* apply (ledx_ind( lambda x. lambda y, ...)) *) + let (t1,metasenv,t3,t4) = proof2 in + let goal2 = List.hd (List.tl gl1) in + let (metano,context,_) = CicUtil.lookup_meta goal2 metasenv in + let cut_param_ty_l = (cut_first nleft (cut_last param_ty_l)) in + (* la lista dei soli parametri destri *) + let l= cut_first (1+nleft) (term_to_list termty) in + let lambda_t = foo_lambda nright cut_param_ty_l nright cut_param_ty_l l [] + nright body uri_of_eq nleft termty isSetType ty_indty term in + let t = foo_appl nleft (nright+consno) lambda_t eliminator_uri in + debug_print (lazy ("Lambda_t: " ^ (CicPp.ppterm t))); + debug_print (lazy ("Term: " ^ (CicPp.ppterm termty))); + debug_print (lazy ("Body: " ^ (CicPp.ppterm body))); + debug_print (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl l)))); + + let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t + CicUniv.empty_ugraph + in + let proof2 = (t1,metasenv'',t3,t4) in + let proof3,gl3 = PET.apply_tactic (P.apply_tac ref_t) (proof2, goal2) in + let new_goals = ProofEngineHelpers.compare_metasenvs + ~oldmetasenv:metasenv ~newmetasenv:metasenv'' + in + let patched_new_goals = + let (_,metasenv''',_,_) = proof3 in + List.filter (function i -> List.exists (function (j,_,_) -> j=i) metasenv''') + new_goals @ gl3 + in + (*prerr_endline ("METASENV: " ^ CicMetaSubst.ppmetasenv metasenv []); DEBUG*) + (proof3, patched_new_goals) +in +ProofEngineTypes.mk_tactic (inversion_tac ~term) +;; diff --git a/helm/software/components/tactics/inversion.mli b/helm/software/components/tactics/inversion.mli new file mode 100644 index 000000000..50bdf58f2 --- /dev/null +++ b/helm/software/components/tactics/inversion.mli @@ -0,0 +1,26 @@ +(* 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 inversion_tac: term: Cic.term -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/metadataQuery.ml b/helm/software/components/tactics/metadataQuery.ml new file mode 100644 index 000000000..b9c053653 --- /dev/null +++ b/helm/software/components/tactics/metadataQuery.ml @@ -0,0 +1,367 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let nonvar uri = not (UriManager.uri_is_var uri) + +module Constr = MetadataConstraints + +exception Goal_is_not_an_equation + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) + +let ( ** ) x y = int_of_float ((float_of_int x) ** (float_of_int y)) + +let signature_of_hypothesis context = + List.fold_left + (fun set hyp -> + match hyp with + | None -> set + | Some (_, Cic.Decl t) + | Some (_, Cic.Def (t, _)) -> + Constr.UriManagerSet.union set (Constr.constants_of t)) + Constr.UriManagerSet.empty context + +let intersect uris siguris = + let set1 = List.fold_right Constr.UriManagerSet.add uris Constr.UriManagerSet.empty in + let set2 = + List.fold_right Constr.UriManagerSet.add siguris Constr.UriManagerSet.empty + in + let inter = Constr.UriManagerSet.inter set1 set2 in + List.filter (fun s -> Constr.UriManagerSet.mem s inter) uris + +(* Profiling code +let at_most = + let profiler = CicUtil.profile "at_most" in + fun ~dbd ~where uri -> profiler.profile (Constr.at_most ~dbd ~where) uri + +let sigmatch = + let profiler = CicUtil.profile "sigmatch" in + fun ~dbd ~facts ~where signature -> + profiler.profile (MetadataConstraints.sigmatch ~dbd ~facts ~where) signature +*) +let at_most = Constr.at_most +let sigmatch = MetadataConstraints.sigmatch + +let filter_uris_forward ~dbd (main, constants) uris = + let main_uris = + match main with + | None -> [] + | Some (main, types) -> main :: types + in + let full_signature = + List.fold_right Constr.UriManagerSet.add main_uris constants + in + List.filter (at_most ~dbd ~where:`Statement full_signature) uris + +let filter_uris_backward ~dbd ~facts signature uris = + let siguris = + List.map snd + (sigmatch ~dbd ~facts ~where:`Statement signature) + in + intersect uris siguris + +let compare_goal_list proof goal1 goal2 = + let _,metasenv,_,_ = proof in + let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in + let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in + let ty_sort1,_ = + CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.empty_ugraph + in + let ty_sort2,_ = + CicTypeChecker.type_of_aux' metasenv ey2 ty2 CicUniv.empty_ugraph + in + let prop1 = + let b,_ = + CicReduction.are_convertible + ey1 (Cic.Sort Cic.Prop) ty_sort1 CicUniv.empty_ugraph + in + if b then 0 + else 1 + in + let prop2 = + let b,_ = + CicReduction.are_convertible + ey2 (Cic.Sort Cic.Prop) ty_sort2 CicUniv.empty_ugraph + in + if b then 0 + else 1 + in + prop1 - prop2 + +(* experimental_hint is a version of hint for experimental + purposes. It uses auto_tac_verbose instead of auto tac. + Auto_tac verbose also returns a substitution - for the moment + as a function from cic to cic, to be changed into an association + list in the future -. This substitution is used to build a + hash table of the inspected goals with their associated proofs. + The cose is a cut and paste of the previous one: at the end + of the experimentation we shall make a choice. *) + +let close_with_types s metasenv context = + Constr.UriManagerSet.fold + (fun e bag -> + let t = CicUtil.term_of_uri e in + let ty, _ = + CicTypeChecker.type_of_aux' metasenv context t CicUniv.empty_ugraph + in + Constr.UriManagerSet.union bag (Constr.constants_of ty)) + s s + +let close_with_constructors s metasenv context = + Constr.UriManagerSet.fold + (fun e bag -> + let t = CicUtil.term_of_uri e in + match t with + Cic.MutInd (uri,_,_) + | Cic.MutConstruct (uri,_,_,_) -> + (match fst (CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + Cic.InductiveDefinition(tl,_,_,_) -> + snd + (List.fold_left + (fun (i,s) (_,_,_,cl) -> + let _,s = + List.fold_left + (fun (j,s) _ -> + let curi = UriManager.uri_of_uriref uri i (Some j) in + j+1,Constr.UriManagerSet.add curi s) (1,s) cl in + (i+1,s)) (0,bag) tl) + | _ -> assert false) + | _ -> bag) + s s + +(* Profiling code +let apply_tac_verbose = + let profiler = CicUtil.profile "apply_tac_verbose" in + fun ~term status -> profiler.profile (PrimitiveTactics.apply_tac_verbose ~term) status + +let sigmatch = + let profiler = CicUtil.profile "sigmatch" in + fun ~dbd ~facts ?(where=`Conclusion) signature -> profiler.profile (Constr.sigmatch ~dbd ~facts ~where) signature + +let cmatch' = + let profiler = CicUtil.profile "cmatch'" in + fun ~dbd ~facts signature -> profiler.profile (Constr.cmatch' ~dbd ~facts) signature +*) +let apply_tac_verbose = PrimitiveTactics.apply_tac_verbose +let cmatch' = Constr.cmatch' + +let signature_of_goal ~(dbd:HMysql.dbd) ((proof, goal) as _status) = + let (_, metasenv, _, _) = proof in + let (_, context, ty) = CicUtil.lookup_meta goal metasenv in + let main, sig_constants = Constr.signature_of ty in + let set = signature_of_hypothesis context in + let set = + match main with + None -> set + | Some (main,l) -> + List.fold_right Constr.UriManagerSet.add (main::l) set in + let set = Constr.UriManagerSet.union set sig_constants in + let all_constants_closed = close_with_types set metasenv context in + let uris = + sigmatch ~dbd ~facts:false ~where:`Statement (None,all_constants_closed) in + let uris = List.filter nonvar (List.map snd uris) in + let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in + uris + +let equations_for_goal ~(dbd:HMysql.dbd) ((proof, goal) as _status) = +(* let to_string set = + "{ " ^ + (String.concat ", " + (Constr.UriManagerSet.fold + (fun u l -> (UriManager.string_of_uri u)::l) set [])) + ^ " }" + in *) + let (_, metasenv, _, _) = proof in + let (_, context, ty) = CicUtil.lookup_meta goal metasenv in + let main, sig_constants = Constr.signature_of ty in +(* Printf.printf "\nsig_constants: %s\n\n" (to_string sig_constants); *) +(* match main with *) +(* None -> raise Goal_is_not_an_equation *) +(* | Some (m,l) -> *) + let m, l = + let eq_URI = + let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (us ^ "#xpointer(1/1)") + in + match main with + | None -> eq_URI, [] + | Some (m, l) when UriManager.eq m eq_URI -> m, l + | Some (m, l) -> eq_URI, [] + in + Printf.printf "\nSome (m, l): %s, [%s]\n\n" + (UriManager.string_of_uri m) + (String.concat "; " (List.map UriManager.string_of_uri l)); + (* if m == UriManager.uri_of_string HelmLibraryObjects.Logic.eq_XURI then ( *) + let set = signature_of_hypothesis context in + (* Printf.printf "\nsignature_of_hypothesis: %s\n\n" (to_string set); *) + let set = Constr.UriManagerSet.union set sig_constants in + let set = close_with_types set metasenv context in + (* Printf.printf "\ndopo close_with_types: %s\n\n" (to_string set); *) + let set = close_with_constructors set metasenv context in + (* Printf.printf "\ndopo close_with_constructors: %s\n\n" (to_string set); *) + let set = List.fold_right Constr.UriManagerSet.remove (m::l) set in + let uris = + sigmatch ~dbd ~facts:false ~where:`Statement (main,set) in + let uris = List.filter nonvar (List.map snd uris) in + let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in + uris + (* ) *) + (* else raise Goal_is_not_an_equation *) + +let experimental_hint + ~(dbd:HMysql.dbd) ?(facts=false) ?signature ((proof, goal) as status) = + let (_, metasenv, _, _) = proof in + let (_, context, ty) = CicUtil.lookup_meta goal metasenv in + let (uris, (main, sig_constants)) = + match signature with + | Some signature -> + (sigmatch ~dbd ~facts signature, signature) + | None -> + (cmatch' ~dbd ~facts ty, Constr.signature_of ty) + in + let uris = List.filter nonvar (List.map snd uris) in + let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in + let types_constants = + match main with + | None -> Constr.UriManagerSet.empty + | Some (main, types) -> + List.fold_right Constr.UriManagerSet.add (main :: types) + Constr.UriManagerSet.empty + in + let all_constants = + let hyp_and_sug = + Constr.UriManagerSet.union + (signature_of_hypothesis context) + sig_constants + in + let main = + match main with + | None -> Constr.UriManagerSet.empty + | Some (main,_) -> + let ty, _ = + CicTypeChecker.type_of_aux' + metasenv context (CicUtil.term_of_uri main) CicUniv.empty_ugraph + in + Constr.constants_of ty + in + Constr.UriManagerSet.union main hyp_and_sug + in +(* Constr.UriManagerSet.iter debug_print hyp_constants; *) + let all_constants_closed = close_with_types all_constants metasenv context in + let other_constants = + Constr.UriManagerSet.diff all_constants_closed types_constants + in + debug_print (lazy "all_constants_closed"); + if debug then Constr.UriManagerSet.iter (fun s -> debug_print (lazy (UriManager.string_of_uri s))) all_constants_closed; + debug_print (lazy "other_constants"); + if debug then Constr.UriManagerSet.iter (fun s -> debug_print (lazy (UriManager.string_of_uri s))) other_constants; + let uris = + let pow = 2 ** (Constr.UriManagerSet.cardinal other_constants) in + if ((List.length uris < pow) or (pow <= 0)) + then begin + debug_print (lazy "MetadataQuery: large sig, falling back to old method"); + filter_uris_forward ~dbd (main, other_constants) uris + end else + filter_uris_backward ~dbd ~facts (main, other_constants) uris + in + let rec aux = function + | [] -> [] + | uri :: tl -> + (let status' = + try + let (subst,(proof, goal_list)) = + (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *) + apply_tac_verbose + ~term:(CicUtil.term_of_uri uri) + status + in + let goal_list = + List.stable_sort (compare_goal_list proof) goal_list + in + Some (uri, (subst,(proof, goal_list))) + with ProofEngineTypes.Fail _ -> None + in + match status' with + | None -> aux tl + | Some status' -> status' :: aux tl) + in + List.stable_sort + (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) -> + Pervasives.compare (List.length goals1) (List.length goals2)) + (aux uris) + +let new_experimental_hint + ~(dbd:HMysql.dbd) ?(facts=false) ?signature ~universe + ((proof, goal) as status) += + let (_, metasenv, _, _) = proof in + let (_, context, ty) = CicUtil.lookup_meta goal metasenv in + let (uris, (main, sig_constants)) = + match signature with + | Some signature -> + (sigmatch ~dbd ~facts signature, signature) + | None -> + (cmatch' ~dbd ~facts ty, Constr.signature_of ty) in + let universe = + List.fold_left + (fun res u -> Constr.UriManagerSet.add u res) + Constr.UriManagerSet.empty universe in + let uris = + List.fold_left + (fun res (_,u) -> Constr.UriManagerSet.add u res) + Constr.UriManagerSet.empty uris in + let uris = Constr.UriManagerSet.inter uris universe in + let uris = Constr.UriManagerSet.elements uris in + let rec aux = function + | [] -> [] + | uri :: tl -> + (let status' = + try + let (subst,(proof, goal_list)) = + (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *) + apply_tac_verbose + ~term:(CicUtil.term_of_uri uri) + status + in + let goal_list = + List.stable_sort (compare_goal_list proof) goal_list + in + Some (uri, (subst,(proof, goal_list))) + with ProofEngineTypes.Fail _ -> None + in + match status' with + | None -> aux tl + | Some status' -> status' :: aux tl) + in + List.stable_sort + (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) -> + Pervasives.compare (List.length goals1) (List.length goals2)) + (aux uris) + diff --git a/helm/software/components/tactics/metadataQuery.mli b/helm/software/components/tactics/metadataQuery.mli new file mode 100644 index 000000000..b65a23fa9 --- /dev/null +++ b/helm/software/components/tactics/metadataQuery.mli @@ -0,0 +1,55 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + + (** @param vars if set variables (".var" URIs) are considered. Defaults to + * false + * @param pat shell like pattern matching over object names, a string where "*" + * is interpreted as 0 or more characters and "?" as exactly one character *) + +val signature_of_goal: + dbd:HMysql.dbd -> ProofEngineTypes.status -> UriManager.uri list + +val equations_for_goal: + dbd:HMysql.dbd -> ProofEngineTypes.status -> UriManager.uri list + +val experimental_hint: + dbd:HMysql.dbd -> + ?facts:bool -> + ?signature:MetadataConstraints.term_signature -> + ProofEngineTypes.status -> + (UriManager.uri * + ((Cic.term -> Cic.term) * + (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list + +val new_experimental_hint: + dbd:HMysql.dbd -> + ?facts:bool -> + ?signature:MetadataConstraints.term_signature -> + universe:UriManager.uri list -> + ProofEngineTypes.status -> + (UriManager.uri * + ((Cic.term -> Cic.term) * + (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list + diff --git a/helm/software/components/tactics/negationTactics.ml b/helm/software/components/tactics/negationTactics.ml new file mode 100644 index 000000000..7ee79e534 --- /dev/null +++ b/helm/software/components/tactics/negationTactics.ml @@ -0,0 +1,88 @@ +(* 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/. + *) + +(* $Id$ *) + +let absurd_tac ~term = + let absurd_tac ~term status = + let (proof, goal) = status in + let module C = Cic in + let module U = UriManager in + let module P = PrimitiveTactics in + let _,metasenv,_,_ = proof in + let _,context,ty = CicUtil.lookup_meta goal metasenv in + let ty_term,_ = + CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in + if (ty_term = (C.Sort C.Prop)) (* ma questo controllo serve?? *) + then ProofEngineTypes.apply_tactic + (P.apply_tac + ~term:( + C.Appl [(C.Const (LibraryObjects.absurd_URI (), [] )) ; + term ; ty]) + ) + status + else raise (ProofEngineTypes.Fail (lazy "Absurd: Not a Proposition")) + in + ProofEngineTypes.mk_tactic (absurd_tac ~term) +;; + +(* FG: METTERE I NOMI ANCHE QUI? CSC: in teoria si', per la intros*) +let contradiction_tac = + 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 + ProofEngineTypes.apply_tactic ( + T.then_ + ~start:(P.intros_tac ()) + ~continuation:( + T.then_ + ~start: + (EliminationTactics.elim_type_tac + (C.MutInd (LibraryObjects.false_URI (), 0, []))) + ~continuation: VariousTactics.assumption_tac)) + status + with + ProofEngineTypes.Fail msg when Lazy.force msg = "Assumption: No such assumption" -> raise (ProofEngineTypes.Fail (lazy "Contradiction: No such assumption")) + (* sarebbe piu' elegante se Assumtion sollevasse un'eccezione tutta sua che questa cattura, magari con l'aiuto di try_tactics *) + in + ProofEngineTypes.mk_tactic contradiction_tac +;; + +(* Questa era in fourierR.ml +(* !!!!! fix !!!!!!!!!! *) +let contradiction_tac (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)) + (proof,goal) +;; +*) + + diff --git a/helm/software/components/tactics/negationTactics.mli b/helm/software/components/tactics/negationTactics.mli new file mode 100644 index 000000000..bfa3e8d5d --- /dev/null +++ b/helm/software/components/tactics/negationTactics.mli @@ -0,0 +1,28 @@ +(* 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 + diff --git a/helm/software/components/tactics/paramodulation/.depend b/helm/software/components/tactics/paramodulation/.depend new file mode 100644 index 000000000..e69de29bb diff --git a/helm/software/components/tactics/paramodulation/Makefile b/helm/software/components/tactics/paramodulation/Makefile new file mode 100644 index 000000000..f1b613400 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/Makefile @@ -0,0 +1,23 @@ +PACKAGE = dummy + +LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser,helm-tactics + +include ../../../Makefile.defs +include ../../Makefile.common + +all $(PACKAGE).cma :saturate + @echo -n +opt $(PACKAGE).cmxa:saturate.opt + @echo -n + +saturate: saturate_main.ml $(LIBRARIES) + @echo " OCAMLC $<" + @$(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $< +saturate.opt: saturate_main.ml $(LIBRARIES) + @echo " OCAMLOPT $<" + @$(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $< + +clean: + rm -f saturate saturate.opt + + diff --git a/helm/software/components/tactics/paramodulation/README b/helm/software/components/tactics/paramodulation/README new file mode 100644 index 000000000..bf484ae16 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/README @@ -0,0 +1,45 @@ +make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata) + +./saturate -h per vedere una lista di parametri: + +./saturate: unknown option `-h'. +Usage: + -full Enable full mode + -f Enable/disable full-reduction strategy (default: enabled) + -r Weight-Age equality selection ratio (default: 4) + -s symbols-based selection ratio (relative to the weight ratio, default: 0) + -c Configuration file (for the db connection) + -o Term ordering. Possible values are: + kbo: Knuth-Bendix ordering + nr-kbo: Non-recursive variant of kbo (default) + lpo: Lexicographic path ordering + -l Time limit in seconds (default: no limit) + -w Maximal width (default: 3) + -d Maximal depth (default: 3) + -retrieve retrieve only + -help Display this list of options + --help Display this list of options + + +./saturate -l 10 -demod-equalities + +dove -l 10 e` il timeout in secondi. + +Il programma legge da standard input il teorema, per esempio + +\forall n:nat.n + n = 2 * n +\forall n:R.n + n = 2 * n +\forall n:R.n+n=n+n + +l'input termina con una riga vuota (quindi basta un doppio invio alla fine) + +In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi +active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output +su file, per esempio usando tee: + +./saturate -l 10 -demod-equalities | tee output.txt + +Il formato di stampa e` quello per gli oggetti di tipo equality (usa la +funzione Inference.string_of_equality) + + diff --git a/helm/software/components/tactics/paramodulation/equality_indexing.ml b/helm/software/components/tactics/paramodulation/equality_indexing.ml new file mode 100644 index 000000000..1dffb6399 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/equality_indexing.ml @@ -0,0 +1,131 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +module type EqualityIndex = + sig + module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality + val arities : (Cic.term, int) Hashtbl.t + type key = Cic.term + type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + val empty : t + val retrieve_generalizations : t -> key -> PosEqSet.t + val retrieve_unifiables : t -> key -> PosEqSet.t + val init_index : unit -> unit + val remove_index : t -> Inference.equality -> t + val index : t -> Inference.equality -> t + val in_index : t -> Inference.equality -> bool + end + +module DT = +struct + module OrderedPosEquality = struct + type t = Utils.pos * Inference.equality + let compare = Pervasives.compare + end + + module PosEqSet = Set.Make(OrderedPosEquality);; + + include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) + + + (* DISCRIMINATION TREES *) + let init_index () = + Hashtbl.clear arities; + ;; + + let remove_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> remove_index tree l (Utils.Left, equality) + | Utils.Lt -> remove_index tree r (Utils.Right, equality) + | _ -> + let tree = remove_index tree r (Utils.Right, equality) in + remove_index tree l (Utils.Left, equality) + + let index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> index tree l (Utils.Left, equality) + | Utils.Lt -> index tree r (Utils.Right, equality) + | _ -> + let tree = index tree r (Utils.Right, equality) in + index tree l (Utils.Left, equality) + + + let in_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let meta_convertibility (pos,equality') = + Inference.meta_convertibility_eq equality equality' + in + in_index tree l meta_convertibility || in_index tree r meta_convertibility + + end + +module PT = + struct + module OrderedPosEquality = struct + type t = Utils.pos * Inference.equality + let compare = Pervasives.compare + end + + module PosEqSet = Set.Make(OrderedPosEquality);; + + include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) + + + (* DISCRIMINATION TREES *) + let init_index () = + Hashtbl.clear arities; + ;; + + let remove_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> remove_index tree l (Utils.Left, equality) + | Utils.Lt -> remove_index tree r (Utils.Right, equality) + | _ -> + let tree = remove_index tree r (Utils.Right, equality) in + remove_index tree l (Utils.Left, equality) + + let index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> index tree l (Utils.Left, equality) + | Utils.Lt -> index tree r (Utils.Right, equality) + | _ -> + let tree = index tree r (Utils.Right, equality) in + index tree l (Utils.Left, equality) + + + let in_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let meta_convertibility (pos,equality') = + Inference.meta_convertibility_eq equality equality' + in + in_index tree l meta_convertibility || in_index tree r meta_convertibility +end + diff --git a/helm/software/components/tactics/paramodulation/equality_indexing.mli b/helm/software/components/tactics/paramodulation/equality_indexing.mli new file mode 100644 index 000000000..d7c3bec5e --- /dev/null +++ b/helm/software/components/tactics/paramodulation/equality_indexing.mli @@ -0,0 +1,43 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +module type EqualityIndex = + sig + module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality + val arities : (Cic.term, int) Hashtbl.t + type key = Cic.term + type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + val empty : t + val retrieve_generalizations : t -> key -> PosEqSet.t + val retrieve_unifiables : t -> key -> PosEqSet.t + val init_index : unit -> unit + val remove_index : t -> Inference.equality -> t + val index : t -> Inference.equality -> t + val in_index : t -> Inference.equality -> bool + end + +module DT : EqualityIndex +module PT : EqualityIndex + diff --git a/helm/software/components/tactics/paramodulation/indexing.ml b/helm/software/components/tactics/paramodulation/indexing.ml new file mode 100644 index 000000000..5830b0842 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/indexing.ml @@ -0,0 +1,1052 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +module Index = Equality_indexing.DT (* discrimination tree based indexing *) +(* +module Index = Equality_indexing.DT (* path tree based indexing *) +*) + +let debug_print = Utils.debug_print;; + +(* +for debugging +let check_equation env equation msg = + let w, proof, (eq_ty, left, right, order), metas, args = equation in + let metasenv, context, ugraph = env in + let metasenv' = metasenv @ metas in + try + CicTypeChecker.type_of_aux' metasenv' context left ugraph; + CicTypeChecker.type_of_aux' metasenv' context right ugraph; + () + with + CicUtil.Meta_not_found _ as exn -> + begin + prerr_endline msg; + prerr_endline (CicPp.ppterm left); + prerr_endline (CicPp.ppterm right); + raise exn + end +*) + +type retrieval_mode = Matching | Unification;; + +let print_candidates mode term res = + let _ = + match mode with + | Matching -> + Printf.printf "| candidates Matching %s\n" (CicPp.ppterm term) + | Unification -> + Printf.printf "| candidates Unification %s\n" (CicPp.ppterm term) + in + print_endline + (String.concat "\n" + (List.map + (fun (p, e) -> + Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p) + (Inference.string_of_equality e)) + res)); + print_endline "|"; +;; + + +let indexing_retrieval_time = ref 0.;; + + +let apply_subst = CicMetaSubst.apply_subst + +let index = Index.index +let remove_index = Index.remove_index +let in_index = Index.in_index +let empty = Index.empty +let init_index = Index.init_index + +(* returns a list of all the equalities in the tree that are in relation + "mode" with the given term, where mode can be either Matching or + Unification. + + Format of the return value: list of tuples in the form: + (position - Left or Right - of the term that matched the given one in this + equality, + equality found) + + Note that if equality is "left = right", if the ordering is left > right, + the position will always be Left, and if the ordering is left < right, + position will be Right. +*) +let get_candidates mode tree term = + let t1 = Unix.gettimeofday () in + let res = + let s = + match mode with + | Matching -> Index.retrieve_generalizations tree term + | Unification -> Index.retrieve_unifiables tree term + in + Index.PosEqSet.elements s + in + (* print_candidates mode term res; *) +(* print_endline (Discrimination_tree.string_of_discrimination_tree tree); *) +(* print_newline (); *) + let t2 = Unix.gettimeofday () in + indexing_retrieval_time := !indexing_retrieval_time +. (t2 -. t1); + res +;; + + +let match_unif_time_ok = ref 0.;; +let match_unif_time_no = ref 0.;; + + +(* + finds the first equality in the index that matches "term", of type "termty" + termty can be Implicit if it is not needed. The result (one of the sides of + the equality, actually) should be not greater (wrt the term ordering) than + term + + Format of the return value: + + (term to substitute, [Cic.Rel 1 properly lifted - see the various + build_newtarget functions inside the various + demodulation_* functions] + substitution used for the matching, + metasenv, + ugraph, [substitution, metasenv and ugraph have the same meaning as those + returned by CicUnification.fo_unif] + (equality where the matching term was found, [i.e. the equality to use as + rewrite rule] + uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of + the equality: this is used to build the proof term, again see one of + the build_newtarget functions] + )) +*) +let rec find_matches metasenv context ugraph lift_amount term termty = + let module C = Cic in + let module U = Utils in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let cmp = !Utils.compare_terms in + let check = match termty with C.Implicit None -> false | _ -> true in + function + | [] -> None + | candidate::tl -> + let pos, (_, proof, (ty, left, right, o), metas, args) = candidate in + if check && not (fst (CicReduction.are_convertible + ~metasenv context termty ty ugraph)) then ( + find_matches metasenv context ugraph lift_amount term termty tl + ) else + let do_match c eq_URI = + let subst', metasenv', ugraph' = + let t1 = Unix.gettimeofday () in + try + let r = + Inference.matching (metasenv @ metas) context + term (S.lift lift_amount c) ugraph + in + let t2 = Unix.gettimeofday () in + match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); + r + with + | Inference.MatchingFailure as e -> + let t2 = Unix.gettimeofday () in + match_unif_time_no := !match_unif_time_no +. (t2 -. t1); + raise e + | CicUtil.Meta_not_found _ as exn -> + prerr_endline "zurg"; + raise exn + in + Some (C.Rel (1 + lift_amount), subst', metasenv', ugraph', + (candidate, eq_URI)) + in + let c, other, eq_URI = + if pos = Utils.Left then left, right, Utils.eq_ind_URI () + else right, left, Utils.eq_ind_r_URI () + in + if o <> U.Incomparable then + try + do_match c eq_URI + with Inference.MatchingFailure -> + find_matches metasenv context ugraph lift_amount term termty tl + else + let res = + try do_match c eq_URI + with Inference.MatchingFailure -> None + in + match res with + | Some (_, s, _, _, _) -> + let c' = apply_subst s c in + (* + let other' = U.guarded_simpl context (apply_subst s other) in *) + let other' = apply_subst s other in + let order = cmp c' other' in + if order = U.Gt then + res + else + find_matches + metasenv context ugraph lift_amount term termty tl + | None -> + find_matches metasenv context ugraph lift_amount term termty tl +;; + + +(* + as above, but finds all the matching equalities, and the matching condition + can be either Inference.matching or Inference.unification +*) +let rec find_all_matches ?(unif_fun=Inference.unification) + metasenv context ugraph lift_amount term termty = + let module C = Cic in + let module U = Utils in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let cmp = !Utils.compare_terms in + function + | [] -> [] + | candidate::tl -> + let pos, (_, _, (ty, left, right, o), metas, args) = candidate in + let do_match c eq_URI = + let subst', metasenv', ugraph' = + let t1 = Unix.gettimeofday () in + try + let r = + unif_fun (metasenv @ metas) context + term (S.lift lift_amount c) ugraph in + let t2 = Unix.gettimeofday () in + match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); + r + with + | Inference.MatchingFailure + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ as e -> + let t2 = Unix.gettimeofday () in + match_unif_time_no := !match_unif_time_no +. (t2 -. t1); + raise e + in + (C.Rel (1 + lift_amount), subst', metasenv', ugraph', + (candidate, eq_URI)) + in + let c, other, eq_URI = + if pos = Utils.Left then left, right, Utils.eq_ind_URI () + else right, left, Utils.eq_ind_r_URI () + in + if o <> U.Incomparable then + try + let res = do_match c eq_URI in + res::(find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl) + with + | Inference.MatchingFailure + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl + else + try + let res = do_match c eq_URI in + match res with + | _, s, _, _, _ -> + let c' = apply_subst s c + and other' = apply_subst s other in + let order = cmp c' other' in + if order <> U.Lt && order <> U.Le then + res::(find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl) + else + find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl + with + | Inference.MatchingFailure + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl +;; + + +(* + returns true if target is subsumed by some equality in table +*) +let subsumption env table target = + let _, _, (ty, left, right, _), tmetas, _ = target in + let metasenv, context, ugraph = env in + let metasenv = metasenv @ tmetas in + let samesubst subst subst' = + let tbl = Hashtbl.create (List.length subst) in + List.iter (fun (m, (c, t1, t2)) -> Hashtbl.add tbl m (c, t1, t2)) subst; + List.for_all + (fun (m, (c, t1, t2)) -> + try + let c', t1', t2' = Hashtbl.find tbl m in + if (c = c') && (t1 = t1') && (t2 = t2') then true + else false + with Not_found -> + true) + subst' + in + let leftr = + match left with + | Cic.Meta _ -> [] + | _ -> + let leftc = get_candidates Matching table left in + find_all_matches ~unif_fun:Inference.matching + metasenv context ugraph 0 left ty leftc + in + let rec ok what = function + | [] -> false, [] + | (_, subst, menv, ug, ((pos, (_, _, (_, l, r, o), m, _)), _))::tl -> + try + let other = if pos = Utils.Left then r else l in + let subst', menv', ug' = + let t1 = Unix.gettimeofday () in + try + let r = + Inference.matching (metasenv @ menv @ m) context what other ugraph + in + let t2 = Unix.gettimeofday () in + match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); + r + with Inference.MatchingFailure as e -> + let t2 = Unix.gettimeofday () in + match_unif_time_no := !match_unif_time_no +. (t2 -. t1); + raise e + in + if samesubst subst subst' then + true, subst + else + ok what tl + with Inference.MatchingFailure -> + ok what tl + in + let r, subst = ok right leftr in + let r, s = + if r then + true, subst + else + let rightr = + match right with + | Cic.Meta _ -> [] + | _ -> + let rightc = get_candidates Matching table right in + find_all_matches ~unif_fun:Inference.matching + metasenv context ugraph 0 right ty rightc + in + ok left rightr + in +(* (if r then *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "SUBSUMPTION! %s\n%s\n" *) +(* (Inference.string_of_equality target) (Utils.print_subst s)))); *) + r, s +;; + + +let rec demodulation_aux ?(typecheck=false) + metasenv context ugraph table lift_amount term = + (* Printf.eprintf "term = %s\n" (CicPp.ppterm term); *) + + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let candidates = get_candidates Matching table term in + match term with + | C.Meta _ -> None + | term -> + let termty, ugraph = + if typecheck then + CicTypeChecker.type_of_aux' metasenv context term ugraph + else + C.Implicit None, ugraph + in + let res = + find_matches metasenv context ugraph lift_amount term termty candidates + in + if res <> None then + res + else + match term with + | C.Appl l -> + let res, ll = + List.fold_left + (fun (res, tl) t -> + if res <> None then + (res, tl @ [S.lift 1 t]) + else + let r = + demodulation_aux metasenv context ugraph table + lift_amount t + in + match r with + | None -> (None, tl @ [S.lift 1 t]) + | Some (rel, _, _, _, _) -> (r, tl @ [rel])) + (None, []) l + in ( + match res with + | None -> None + | Some (_, subst, menv, ug, eq_found) -> + Some (C.Appl ll, subst, menv, ug, eq_found) + ) + | C.Prod (nn, s, t) -> + let r1 = + demodulation_aux metasenv context ugraph table lift_amount s in ( + match r1 with + | None -> + let r2 = + demodulation_aux metasenv + ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t + in ( + match r2 with + | None -> None + | Some (t', subst, menv, ug, eq_found) -> + Some (C.Prod (nn, (S.lift 1 s), t'), + subst, menv, ug, eq_found) + ) + | Some (s', subst, menv, ug, eq_found) -> + Some (C.Prod (nn, s', (S.lift 1 t)), + subst, menv, ug, eq_found) + ) + | C.Lambda (nn, s, t) -> + let r1 = + demodulation_aux metasenv context ugraph table lift_amount s in ( + match r1 with + | None -> + let r2 = + demodulation_aux metasenv + ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t + in ( + match r2 with + | None -> None + | Some (t', subst, menv, ug, eq_found) -> + Some (C.Lambda (nn, (S.lift 1 s), t'), + subst, menv, ug, eq_found) + ) + | Some (s', subst, menv, ug, eq_found) -> + Some (C.Lambda (nn, s', (S.lift 1 t)), + subst, menv, ug, eq_found) + ) + | t -> + None +;; + + +let build_newtarget_time = ref 0.;; + + +let demod_counter = ref 1;; + +(** demodulation, when target is an equality *) +let rec demodulation_equality newmeta env table sign target = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let module U = Utils in + let metasenv, context, ugraph = env in + let w, proof, (eq_ty, left, right, order), metas, args = target in + (* first, we simplify *) + let right = U.guarded_simpl context right in + let left = U.guarded_simpl context left in + let w = Utils.compute_equality_weight eq_ty left right in + let order = !Utils.compare_terms left right in + let target = w, proof, (eq_ty, left, right, order), metas, args in + + let metasenv' = metasenv @ metas in + + let maxmeta = ref newmeta in + + let build_newtarget is_left (t, subst, menv, ug, (eq_found, eq_URI)) = + let time1 = Unix.gettimeofday () in + + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let ty = + try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) + with CicUtil.Meta_not_found _ -> ty + in + let what, other = if pos = Utils.Left then what, other else other, what in + let newterm, newproof = + let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in + let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in + incr demod_counter; + let bo' = + let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); + S.lift 1 eq_ty; l; r] + in + if sign = Utils.Positive then + (bo, + Inference.ProofBlock ( + subst, eq_URI, (name, ty), bo'(* t' *), eq_found, proof)) + else + let metaproof = + incr maxmeta; + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in +(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) +(* print_newline (); *) + C.Meta (!maxmeta, irl) + in + let eq_found = + let proof' = + let termlist = + if pos = Utils.Left then [ty; what; other] + else [ty; other; what] + in + Inference.ProofSymBlock (termlist, proof') + in + let what, other = + if pos = Utils.Left then what, other else other, what + in + pos, (0, proof', (ty, other, what, Utils.Incomparable), + menv', args') + in + let target_proof = + let pb = + Inference.ProofBlock (subst, eq_URI, (name, ty), bo', + eq_found, Inference.BasicProof metaproof) + in + match proof with + | Inference.BasicProof _ -> + print_endline "replacing a BasicProof"; + pb + | Inference.ProofGoalBlock (_, parent_proof) -> + print_endline "replacing another ProofGoalBlock"; + Inference.ProofGoalBlock (pb, parent_proof) + | _ -> assert false + in + let refl = + C.Appl [C.MutConstruct (* reflexivity *) + (LibraryObjects.eq_URI (), 0, 1, []); + eq_ty; if is_left then right else left] + in + (bo, + Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) + in + let left, right = if is_left then newterm, right else left, newterm in + let m = + (Inference.metas_of_term left) + @ (Inference.metas_of_term right) + @ (Inference.metas_of_term eq_ty) in + (* let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') *) + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metasenv' @ menv') + and newargs = args + in + let ordering = !Utils.compare_terms left right in + + let time2 = Unix.gettimeofday () in + build_newtarget_time := !build_newtarget_time +. (time2 -. time1); + + let res = + let w = Utils.compute_equality_weight eq_ty left right in + (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs) + in + !maxmeta, res + in + let _ = + try + CicTypeChecker.type_of_aux' metasenv' context left ugraph; + CicTypeChecker.type_of_aux' metasenv' context right ugraph; + with + CicUtil.Meta_not_found _ as exn -> + begin + prerr_endline "siamo in demodulation_equality 1"; + prerr_endline (CicPp.ppterm left); + prerr_endline (CicPp.ppterm right); + raise exn + end + in + let res = demodulation_aux metasenv' context ugraph table 0 left in + let newmeta, newtarget = + match res with + | Some t -> + let newmeta, newtarget = build_newtarget true t in + if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) || + (Inference.meta_convertibility_eq target newtarget) then + newmeta, newtarget + else + demodulation_equality newmeta env table sign newtarget + | None -> + let res = demodulation_aux metasenv' context ugraph table 0 right in + match res with + | Some t -> + let newmeta, newtarget = build_newtarget false t in + if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) || + (Inference.meta_convertibility_eq target newtarget) then + newmeta, newtarget + else + demodulation_equality newmeta env table sign newtarget + | None -> + newmeta, target + in + (* newmeta, newtarget *) + newmeta,newtarget +;; + + +(** + Performs the beta expansion of the term "term" w.r.t. "table", + i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2 + in table. +*) +let rec betaexpand_term metasenv context ugraph table lift_amount term = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let candidates = get_candidates Unification table term in + let res, lifted_term = + match term with + | C.Meta (i, l) -> + let l', lifted_l = + List.fold_right + (fun arg (res, lifted_tl) -> + match arg with + | Some arg -> + let arg_res, lifted_arg = + betaexpand_term metasenv context ugraph table + lift_amount arg in + let l1 = + List.map + (fun (t, s, m, ug, eq_found) -> + (Some t)::lifted_tl, s, m, ug, eq_found) + arg_res + in + (l1 @ + (List.map + (fun (l, s, m, ug, eq_found) -> + (Some lifted_arg)::l, s, m, ug, eq_found) + res), + (Some lifted_arg)::lifted_tl) + | None -> + (List.map + (fun (r, s, m, ug, eq_found) -> + None::r, s, m, ug, eq_found) res, + None::lifted_tl) + ) l ([], []) + in + let e = + List.map + (fun (l, s, m, ug, eq_found) -> + (C.Meta (i, l), s, m, ug, eq_found)) l' + in + e, C.Meta (i, lifted_l) + + | C.Rel m -> + [], if m <= lift_amount then C.Rel m else C.Rel (m+1) + + | C.Prod (nn, s, t) -> + let l1, lifted_s = + betaexpand_term metasenv context ugraph table lift_amount s in + let l2, lifted_t = + betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t in + let l1' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1 + and l2' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in + l1' @ l2', C.Prod (nn, lifted_s, lifted_t) + + | C.Lambda (nn, s, t) -> + let l1, lifted_s = + betaexpand_term metasenv context ugraph table lift_amount s in + let l2, lifted_t = + betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t in + let l1' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1 + and l2' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in + l1' @ l2', C.Lambda (nn, lifted_s, lifted_t) + + | C.Appl l -> + let l', lifted_l = + List.fold_right + (fun arg (res, lifted_tl) -> + let arg_res, lifted_arg = + betaexpand_term metasenv context ugraph table lift_amount arg + in + let l1 = + List.map + (fun (a, s, m, ug, eq_found) -> + a::lifted_tl, s, m, ug, eq_found) + arg_res + in + (l1 @ + (List.map + (fun (r, s, m, ug, eq_found) -> + lifted_arg::r, s, m, ug, eq_found) + res), + lifted_arg::lifted_tl) + ) l ([], []) + in + (List.map + (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l', + C.Appl lifted_l) + + | t -> [], (S.lift lift_amount t) + in + match term with + | C.Meta (i, l) -> res, lifted_term + | term -> + let termty, ugraph = + C.Implicit None, ugraph +(* CicTypeChecker.type_of_aux' metasenv context term ugraph *) + in + let r = + find_all_matches + metasenv context ugraph lift_amount term termty candidates + in + r @ res, lifted_term +;; + + +let sup_l_counter = ref 1;; + +(** + superposition_left + returns a list of new clauses inferred with a left superposition step + the negative equation "target" and one of the positive equations in "table" +*) +let superposition_left newmeta (metasenv, context, ugraph) table target = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let module CR = CicReduction in + let module U = Utils in + let weight, proof, (eq_ty, left, right, ordering), menv, _ = target in + let expansions, _ = + let term = if ordering = U.Gt then left else right in + betaexpand_term metasenv context ugraph table 0 term + in + let maxmeta = ref newmeta in + let build_new (bo, s, m, ug, (eq_found, eq_URI)) = + +(* debug_print (lazy "\nSUPERPOSITION LEFT\n"); *) + + let time1 = Unix.gettimeofday () in + + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let newgoal, newproof = + let bo' = U.guarded_simpl context (apply_subst s (S.subst other bo)) in + let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in + incr sup_l_counter; + let bo'' = + let l, r = + if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); + S.lift 1 eq_ty; l; r] + in + incr maxmeta; + let metaproof = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + C.Meta (!maxmeta, irl) + in + let eq_found = + let proof' = + let termlist = + if pos = Utils.Left then [ty; what; other] + else [ty; other; what] + in + Inference.ProofSymBlock (termlist, proof') + in + let what, other = + if pos = Utils.Left then what, other else other, what + in + pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') + in + let target_proof = + let pb = + Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, + Inference.BasicProof metaproof) + in + match proof with + | Inference.BasicProof _ -> +(* debug_print (lazy "replacing a BasicProof"); *) + pb + | Inference.ProofGoalBlock (_, parent_proof) -> +(* debug_print (lazy "replacing another ProofGoalBlock"); *) + Inference.ProofGoalBlock (pb, parent_proof) + | _ -> assert false + in + let refl = + C.Appl [C.MutConstruct (* reflexivity *) + (LibraryObjects.eq_URI (), 0, 1, []); + eq_ty; if ordering = U.Gt then right else left] + in + (bo', + Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) + in + let left, right = + if ordering = U.Gt then newgoal, right else left, newgoal in + let neworder = !Utils.compare_terms left right in + + let time2 = Unix.gettimeofday () in + build_newtarget_time := !build_newtarget_time +. (time2 -. time1); + + let res = + let w = Utils.compute_equality_weight eq_ty left right in + (w, newproof, (eq_ty, left, right, neworder), menv @ menv', []) + in + res + in + !maxmeta, List.map build_new expansions +;; + + +let sup_r_counter = ref 1;; + +(** + superposition_right + returns a list of new clauses inferred with a right superposition step + between the positive equation "target" and one in the "table" "newmeta" is + the first free meta index, i.e. the first number above the highest meta + index: its updated value is also returned +*) +let superposition_right newmeta (metasenv, context, ugraph) table target = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let module CR = CicReduction in + let module U = Utils in + let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in + let metasenv' = metasenv @ newmetas in + let maxmeta = ref newmeta in + let res1, res2 = + match ordering with + | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), [] + | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right) + | _ -> + let res l r = + List.filter + (fun (_, subst, _, _, _) -> + let subst = apply_subst subst in + let o = !Utils.compare_terms (subst l) (subst r) in + o <> U.Lt && o <> U.Le) + (fst (betaexpand_term metasenv' context ugraph table 0 l)) + in + (res left right), (res right left) + in + let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) = + + let time1 = Unix.gettimeofday () in + + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let newgoal, newproof = + (* qua *) + let bo' = Utils.guarded_simpl context (apply_subst s (S.subst other bo)) in + let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in + incr sup_r_counter; + let bo'' = + let l, r = + if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); + S.lift 1 eq_ty; l; r] + in + bo', + Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, eqproof) + in + let newmeta, newequality = + let left, right = + if ordering = U.Gt then newgoal, apply_subst s right + else apply_subst s left, newgoal in + let neworder = !Utils.compare_terms left right + and newmenv = newmetas @ menv' + and newargs = args @ args' in + let eq' = + let w = Utils.compute_equality_weight eq_ty left right in + (w, newproof, (eq_ty, left, right, neworder), newmenv, newargs) in + let newm, eq' = Inference.fix_metas !maxmeta eq' in + newm, eq' + in + maxmeta := newmeta; + + let time2 = Unix.gettimeofday () in + build_newtarget_time := !build_newtarget_time +. (time2 -. time1); + + newequality + in + let new1 = List.map (build_new U.Gt) res1 + and new2 = List.map (build_new U.Lt) res2 in +(* + let ok e = not (Inference.is_identity (metasenv, context, ugraph) e) in +*) + let ok e = not (Inference.is_identity (metasenv', context, ugraph) e) in + (!maxmeta, + (List.filter ok (new1 @ new2))) +;; + + +(** demodulation, when the target is a goal *) +let rec demodulation_goal newmeta env table goal = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let metasenv, context, ugraph = env in + let maxmeta = ref newmeta in + let proof, metas, term = goal in + let term = Utils.guarded_simpl (~debug:true) context term in + let goal = proof, metas, term in + let metasenv' = metasenv @ metas in + + let build_newgoal (t, subst, menv, ug, (eq_found, eq_URI)) = + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let ty = + try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) + with CicUtil.Meta_not_found _ -> ty + in + let newterm, newproof = + (* qua *) + let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in + let bo' = apply_subst subst t in + let name = C.Name ("x_DemodGoal_" ^ (string_of_int !demod_counter)) in + incr demod_counter; + let metaproof = + incr maxmeta; + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in +(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) + C.Meta (!maxmeta, irl) + in + let eq_found = + let proof' = + let termlist = + if pos = Utils.Left then [ty; what; other] + else [ty; other; what] + in + Inference.ProofSymBlock (termlist, proof') + in + let what, other = + if pos = Utils.Left then what, other else other, what + in + pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') + in + let goal_proof = + let pb = + Inference.ProofBlock (subst, eq_URI, (name, ty), bo', + eq_found, Inference.BasicProof metaproof) + in + let rec repl = function + | Inference.NoProof -> +(* debug_print (lazy "replacing a NoProof"); *) + pb + | Inference.BasicProof _ -> +(* debug_print (lazy "replacing a BasicProof"); *) + pb + | Inference.ProofGoalBlock (_, parent_proof) -> +(* debug_print (lazy "replacing another ProofGoalBlock"); *) + Inference.ProofGoalBlock (pb, parent_proof) + | Inference.SubProof (term, meta_index, p) -> + Inference.SubProof (term, meta_index, repl p) + | _ -> assert false + in repl proof + in + bo, Inference.ProofGoalBlock (Inference.NoProof, goal_proof) + in + let m = Inference.metas_of_term newterm in + (* QUA *) + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (menv @ menv')in + !maxmeta, (newproof, newmetasenv, newterm) + in + let res = + demodulation_aux ~typecheck:true metasenv' context ugraph table 0 term + in + match res with + | Some t -> + let newmeta, newgoal = build_newgoal t in + let _, _, newg = newgoal in + if Inference.meta_convertibility term newg then + newmeta, newgoal + else + demodulation_goal newmeta env table newgoal + | None -> + newmeta, goal +;; + + +(** demodulation, when the target is a theorem *) +let rec demodulation_theorem newmeta env table theorem = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let metasenv, context, ugraph = env in + let maxmeta = ref newmeta in + let term, termty, metas = theorem in + let metasenv' = metasenv @ metas in + + let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) = + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let newterm, newty = + (* qua *) + let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in + let bo' = apply_subst subst t in + let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in + incr demod_counter; + let newproof = + Inference.ProofBlock (subst, eq_URI, (name, ty), bo', eq_found, + Inference.BasicProof term) + in + (Inference.build_proof_term newproof, bo) + in + + let m = Inference.metas_of_term newterm in + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') in + !maxmeta, (newterm, newty, newmetasenv) + in + let res = + demodulation_aux ~typecheck:true metasenv' context ugraph table 0 termty + in + match res with + | Some t -> + let newmeta, newthm = build_newtheorem t in + let newt, newty, _ = newthm in + if Inference.meta_convertibility termty newty then + newmeta, newthm + else + demodulation_theorem newmeta env table newthm + | None -> + newmeta, theorem +;; + diff --git a/helm/software/components/tactics/paramodulation/indexing.mli b/helm/software/components/tactics/paramodulation/indexing.mli new file mode 100644 index 000000000..8a6f9c2b6 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/indexing.mli @@ -0,0 +1,86 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +module Index : + sig + module PosEqSet : Set.S + with type elt = Utils.pos * Inference.equality + and type t = Equality_indexing.DT.PosEqSet.t + type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + type key = Cic.term + end + +val index : Index.t -> Inference.equality -> Index.t +val remove_index : Index.t -> Inference.equality -> Index.t +val in_index : Index.t -> Inference.equality -> bool +val empty : Index.t +val match_unif_time_ok : float ref +val match_unif_time_no : float ref +val indexing_retrieval_time : float ref +val init_index : unit -> unit +val build_newtarget_time : float ref +val subsumption : + Cic.metasenv * Cic.context * CicUniv.universe_graph -> + Index.t -> + 'a * 'b * ('c * Index.key * Index.key * 'd) * Cic.metasenv * 'e -> + bool * Cic.substitution +val superposition_left : + int -> + Cic.metasenv * Cic.context * CicUniv.universe_graph -> + Index.t -> + 'a * Inference.proof * + (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv * 'c -> + int * + (int * Inference.proof * + (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv * + 'e list) + list +val superposition_right : + int -> + Cic.metasenv * Cic.context * CicUniv.universe_graph -> + Index.t -> + 'a * Inference.proof * + (Cic.term * Index.key * Index.key * Utils.comparison) * + Cic.metasenv * Cic.term list -> int * Inference.equality list +val demodulation_equality : + int -> + Cic.metasenv * Cic.context * CicUniv.universe_graph -> + Index.t -> + Utils.equality_sign -> Inference.equality -> int * Inference.equality +val demodulation_goal : + int -> + Cic.metasenv * Cic.context * CicUniv.universe_graph -> + Index.t -> + Inference.proof * Cic.metasenv * Index.key -> + int * (Inference.proof * Cic.metasenv * Index.key) +val demodulation_theorem : + 'a -> + Cic.metasenv * Cic.context * CicUniv.universe_graph -> + Index.t -> + Cic.term * Index.key * Cic.metasenv -> + 'a * (Cic.term * Index.key * Cic.metasenv) + diff --git a/helm/software/components/tactics/paramodulation/inference.ml b/helm/software/components/tactics/paramodulation/inference.ml new file mode 100644 index 000000000..dfb67583e --- /dev/null +++ b/helm/software/components/tactics/paramodulation/inference.ml @@ -0,0 +1,1005 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +open Utils;; + + +type equality = + int * (* weight *) + proof * + (Cic.term * (* type *) + Cic.term * (* left side *) + Cic.term * (* right side *) + Utils.comparison) * (* ordering *) + Cic.metasenv * (* environment for metas *) + Cic.term list (* arguments *) + +and proof = + | NoProof (* term is the goal missing a proof *) + | BasicProof of Cic.term + | ProofBlock of + Cic.substitution * UriManager.uri * + (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof + | ProofGoalBlock of proof * proof + | ProofSymBlock of Cic.term list * proof + | SubProof of Cic.term * int * proof +;; + + +let string_of_equality ?env = + match env with + | None -> ( + function + | w, _, (ty, left, right, o), _, _ -> + Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty) + (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right) + ) + | Some (_, context, _) -> ( + let names = names_of_context context in + function + | w, _, (ty, left, right, o), _, _ -> + Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names) + (CicPp.pp left names) (string_of_comparison o) + (CicPp.pp right names) + ) +;; + + +let rec string_of_proof = function + | NoProof -> "NoProof " + | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t) + | SubProof (t, i, p) -> + Printf.sprintf "SubProof(%s, %s, %s)" + (CicPp.ppterm t) (string_of_int i) (string_of_proof p) + | ProofSymBlock _ -> "ProofSymBlock" + | ProofBlock _ -> "ProofBlock" + | ProofGoalBlock (p1, p2) -> + Printf.sprintf "ProofGoalBlock(%s, %s)" + (string_of_proof p1) (string_of_proof p2) +;; + + +(* returns an explicit named subst and a list of arguments for sym_eq_URI *) +let build_ens_for_sym_eq sym_eq_URI termlist = + let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in + match obj with + | Cic.Constant (_, _, _, uris, _) -> + assert (List.length uris <= List.length termlist); + let rec aux = function + | [], tl -> [], tl + | (uri::uris), (term::tl) -> + let ens, args = aux (uris, tl) in + (uri, term)::ens, args + | _, _ -> assert false + in + aux (uris, termlist) + | _ -> assert false +;; + + +let build_proof_term ?(noproof=Cic.Implicit None) proof = + let rec do_build_proof proof = + match proof with + | NoProof -> + Printf.fprintf stderr "WARNING: no proof!\n"; + noproof + | BasicProof term -> term + | ProofGoalBlock (proofbit, proof) -> + print_endline "found ProofGoalBlock, going up..."; + do_build_goal_proof proofbit proof + | ProofSymBlock (termlist, proof) -> + let proof = do_build_proof proof in + let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in + Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof]) + | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) -> + let t' = Cic.Lambda (name, ty, bo) in + let proof' = + let _, proof', _, _, _ = eq in + do_build_proof proof' + in + let eqproof = do_build_proof eqproof in + let _, _, (ty, what, other, _), menv', args' = eq in + let what, other = + if pos = Utils.Left then what, other else other, what + in + CicMetaSubst.apply_subst subst + (Cic.Appl [Cic.Const (eq_URI, []); ty; + what; t'; eqproof; other; proof']) + | SubProof (term, meta_index, proof) -> + let proof = do_build_proof proof in + let eq i = function + | Cic.Meta (j, _) -> i = j + | _ -> false + in + ProofEngineReduction.replace + ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term + + and do_build_goal_proof proofbit proof = + match proof with + | ProofGoalBlock (pb, p) -> + do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p)) + | _ -> do_build_proof (replace_proof proofbit proof) + + and replace_proof newproof = function + | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) -> + let eqproof' = replace_proof newproof eqproof in + ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof') + | ProofGoalBlock (pb, p) -> + let pb' = replace_proof newproof pb in + ProofGoalBlock (pb', p) + | BasicProof _ -> newproof + | SubProof (term, meta_index, p) -> + SubProof (term, meta_index, replace_proof newproof p) + | p -> p + in + do_build_proof proof +;; + + +let rec metas_of_term = function + | Cic.Meta (i, c) -> [i] + | Cic.Var (_, ens) + | Cic.Const (_, ens) + | Cic.MutInd (_, _, ens) + | Cic.MutConstruct (_, _, _, ens) -> + List.flatten (List.map (fun (u, t) -> metas_of_term t) ens) + | Cic.Cast (s, t) + | Cic.Prod (_, s, t) + | Cic.Lambda (_, s, t) + | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t) + | Cic.Appl l -> List.flatten (List.map metas_of_term l) + | Cic.MutCase (uri, i, s, t, l) -> + (metas_of_term s) @ (metas_of_term t) @ + (List.flatten (List.map metas_of_term l)) + | Cic.Fix (i, il) -> + List.flatten + (List.map (fun (s, i, t1, t2) -> + (metas_of_term t1) @ (metas_of_term t2)) il) + | Cic.CoFix (i, il) -> + List.flatten + (List.map (fun (s, t1, t2) -> + (metas_of_term t1) @ (metas_of_term t2)) il) + | _ -> [] +;; + + +exception NotMetaConvertible;; + +let meta_convertibility_aux table t1 t2 = + let module C = Cic in + let rec aux ((table_l, table_r) as table) t1 t2 = + match t1, t2 with + | C.Meta (m1, tl1), C.Meta (m2, tl2) -> + let m1_binding, table_l = + try List.assoc m1 table_l, table_l + with Not_found -> m2, (m1, m2)::table_l + and m2_binding, table_r = + try List.assoc m2 table_r, table_r + with Not_found -> m1, (m2, m1)::table_r + in + if (m1_binding <> m2) || (m2_binding <> m1) then + raise NotMetaConvertible + else ( + try + List.fold_left2 + (fun res t1 t2 -> + match t1, t2 with + | None, Some _ | Some _, None -> raise NotMetaConvertible + | None, None -> res + | Some t1, Some t2 -> (aux res t1 t2)) + (table_l, table_r) tl1 tl2 + with Invalid_argument _ -> + raise NotMetaConvertible + ) + | C.Var (u1, ens1), C.Var (u2, ens2) + | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) -> + aux_ens table ens1 ens2 + | C.Cast (s1, t1), C.Cast (s2, t2) + | C.Prod (_, s1, t1), C.Prod (_, s2, t2) + | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2) + | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) -> + let table = aux table s1 s2 in + aux table t1 t2 + | C.Appl l1, C.Appl l2 -> ( + try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2) + when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2 + | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2) + when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 -> + aux_ens table ens1 ens2 + | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2) + when (UriManager.eq u1 u2) && i1 = i2 -> + let table = aux table s1 s2 in + let table = aux table t1 t2 in ( + try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> ( + try + List.fold_left2 + (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) -> + if i1 <> i2 then raise NotMetaConvertible + else + let res = (aux res s1 s2) in aux res t1 t2) + table il1 il2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> ( + try + List.fold_left2 + (fun res (n1, s1, t1) (n2, s2, t2) -> + let res = aux res s1 s2 in aux res t1 t2) + table il1 il2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | t1, t2 when t1 = t2 -> table + | _, _ -> raise NotMetaConvertible + + and aux_ens table ens1 ens2 = + let cmp (u1, t1) (u2, t2) = + compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) + in + let ens1 = List.sort cmp ens1 + and ens2 = List.sort cmp ens2 in + try + List.fold_left2 + (fun res (u1, t1) (u2, t2) -> + if not (UriManager.eq u1 u2) then raise NotMetaConvertible + else aux res t1 t2) + table ens1 ens2 + with Invalid_argument _ -> raise NotMetaConvertible + in + aux table t1 t2 +;; + + +let meta_convertibility_eq eq1 eq2 = + let _, _, (ty, left, right, _), _, _ = eq1 + and _, _, (ty', left', right', _), _, _ = eq2 in + if ty <> ty' then + false + else if (left = left') && (right = right') then + true + else if (left = right') && (right = left') then + true + else + try + let table = meta_convertibility_aux ([], []) left left' in + let _ = meta_convertibility_aux table right right' in + true + with NotMetaConvertible -> + try + let table = meta_convertibility_aux ([], []) left right' in + let _ = meta_convertibility_aux table right left' in + true + with NotMetaConvertible -> + false +;; + + +let meta_convertibility t1 t2 = + if t1 = t2 then + true + else + try + ignore(meta_convertibility_aux ([], []) t1 t2); + true + with NotMetaConvertible -> + false +;; + + +let rec check_irl start = function + | [] -> true + | None::tl -> check_irl (start+1) tl + | (Some (Cic.Rel x))::tl -> + if x = start then check_irl (start+1) tl else false + | _ -> false +;; + + +let rec is_simple_term = function + | Cic.Appl ((Cic.Meta _)::_) -> false + | Cic.Appl l -> List.for_all is_simple_term l + | Cic.Meta (i, l) -> check_irl 1 l + | Cic.Rel _ -> true + | Cic.Const _ -> true + | Cic.MutInd (_, _, []) -> true + | Cic.MutConstruct (_, _, _, []) -> true + | _ -> false +;; + + +let lookup_subst meta subst = + match meta with + | Cic.Meta (i, _) -> ( + try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t + with Not_found -> meta + ) + | _ -> assert false +;; + + +let unification_simple metasenv context t1 t2 ugraph = + let module C = Cic in + let module M = CicMetaSubst in + let module U = CicUnification in + let lookup = lookup_subst in + let rec occurs_check subst what where = + match where with + | t when what = t -> true + | C.Appl l -> List.exists (occurs_check subst what) l + | C.Meta _ -> + let t = lookup where subst in + if t <> where then occurs_check subst what t else false + | _ -> false + in + let rec unif subst menv s t = + let s = match s with C.Meta _ -> lookup s subst | _ -> s + and t = match t with C.Meta _ -> lookup t subst | _ -> t + in + match s, t with + | s, t when s = t -> subst, menv + | C.Meta (i, _), C.Meta (j, _) when i > j -> + unif subst menv t s + | C.Meta _, t when occurs_check subst s t -> + raise + (U.UnificationFailure (lazy "Inference.unification.unif")) + | C.Meta (i, l), t -> ( + try + let _, _, ty = CicUtil.lookup_meta i menv in + let subst = + if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst + else subst + in + let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *) + subst, menv + with CicUtil.Meta_not_found m -> + let names = names_of_context context in + debug_print + (lazy + (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m + (CicPp.pp t1 names) (CicPp.pp t2 names) + (print_metasenv menv) (print_metasenv metasenv))); + assert false + ) + | _, C.Meta _ -> unif subst menv t s + | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt -> + raise (U.UnificationFailure (lazy "Inference.unification.unif")) + | C.Appl (hds::tls), C.Appl (hdt::tlt) -> ( + try + List.fold_left2 + (fun (subst', menv) s t -> unif subst' menv s t) + (subst, menv) tls tlt + with Invalid_argument _ -> + raise (U.UnificationFailure (lazy "Inference.unification.unif")) + ) + | _, _ -> + raise (U.UnificationFailure (lazy "Inference.unification.unif")) + in + let subst, menv = unif [] metasenv t1 t2 in + let menv = + List.filter + (fun (m, _, _) -> + try let _ = List.find (fun (i, _) -> m = i) subst in false + with Not_found -> true) + menv + in + List.rev subst, menv, ugraph +;; + + +let unification metasenv context t1 t2 ugraph = + let subst, menv, ug = + if not (is_simple_term t1) || not (is_simple_term t2) then ( + debug_print + (lazy + (Printf.sprintf "NOT SIMPLE TERMS: %s %s" + (CicPp.ppterm t1) (CicPp.ppterm t2))); + CicUnification.fo_unif metasenv context t1 t2 ugraph + ) else + unification_simple metasenv context t1 t2 ugraph + in + let rec fix_term = function + | (Cic.Meta (i, l) as t) -> + let t' = lookup_subst t subst in + if t <> t' then fix_term t' else t + | Cic.Appl l -> Cic.Appl (List.map fix_term l) + | t -> t + in + let rec fix_subst = function + | [] -> [] + | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl) + in + fix_subst subst, menv, ug +;; + + +let unification = CicUnification.fo_unif;; + +exception MatchingFailure;; + + +(* +let matching_simple metasenv context t1 t2 ugraph = + let module C = Cic in + let module M = CicMetaSubst in + let module U = CicUnification in + let lookup meta subst = + match meta with + | C.Meta (i, _) -> ( + try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t + with Not_found -> meta + ) + | _ -> assert false + in + let rec do_match subst menv s t = + match s, t with + | s, t when s = t -> subst, menv + | s, C.Meta (i, l) -> + let filter_menv i menv = + List.filter (fun (m, _, _) -> i <> m) menv + in + let subst, menv = + let value = lookup t subst in + match value with + | value when value = t -> + let _, _, ty = CicUtil.lookup_meta i menv in + (i, (context, s, ty))::subst, filter_menv i menv + | value when value <> s -> + raise MatchingFailure + | value -> do_match subst menv s value + in + subst, menv + | C.Appl ls, C.Appl lt -> ( + try + List.fold_left2 + (fun (subst, menv) s t -> do_match subst menv s t) + (subst, menv) ls lt + with Invalid_argument _ -> + raise MatchingFailure + ) + | _, _ -> + raise MatchingFailure + in + let subst, menv = do_match [] metasenv t1 t2 in + subst, menv, ugraph +;; +*) + + +let matching metasenv context t1 t2 ugraph = + try + let subst, metasenv, ugraph = +try + unification metasenv context t1 t2 ugraph +with CicUtil.Meta_not_found _ as exn -> + Printf.eprintf "t1 == %s\nt2 = %s\nmetasenv == %s\n%!" + (CicPp.ppterm t1) (CicPp.ppterm t2) (CicMetaSubst.ppmetasenv [] metasenv); + raise exn + in + let t' = CicMetaSubst.apply_subst subst t1 in + if not (meta_convertibility t1 t') then + raise MatchingFailure + else + let metas = metas_of_term t1 in + let fix_subst = function + | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas -> + (j, (c, Cic.Meta (i, lc), ty)) + | s -> s + in + let subst = List.map fix_subst subst in + subst, metasenv, ugraph + with + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + raise MatchingFailure +;; + + +let find_equalities context proof = + let module C = Cic in + let module S = CicSubstitution in + let module T = CicTypeChecker in + let eq_uri = LibraryObjects.eq_URI () in + let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in + let ok_types ty menv = + List.for_all (fun (_, _, mt) -> mt = ty) menv + in + let rec aux index newmeta = function + | [] -> [], newmeta + | (Some (_, C.Decl (term)))::tl -> + let do_find context term = + match term with + | C.Prod (name, s, t) -> + let (head, newmetas, args, newmeta) = + ProofEngineHelpers.saturate_term newmeta [] + context (S.lift index term) 0 + in + let p = + if List.length args = 0 then + C.Rel index + else + C.Appl ((C.Rel index)::args) + in ( + match head with + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) -> + debug_print + (lazy + (Printf.sprintf "OK: %s" (CicPp.ppterm term))); + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let proof = BasicProof p in + let e = (w, proof, (ty, t1, t2, o), newmetas, args) in + Some e, (newmeta+1) + | _ -> None, newmeta + ) + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when UriManager.eq uri eq_uri -> + let t1 = S.lift index t1 + and t2 = S.lift index t2 in + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in + Some e, (newmeta+1) + | _ -> None, newmeta + in ( + match do_find context term with + | Some p, newmeta -> + let tl, newmeta' = (aux (index+1) newmeta tl) in + if newmeta' < newmeta then + prerr_endline "big trouble"; + (index, p)::tl, newmeta' (* max???? *) + | None, _ -> + aux (index+1) newmeta tl + ) + | _::tl -> + aux (index+1) newmeta tl + in + let il, maxm = aux 1 newmeta context in + let indexes, equalities = List.split il in + indexes, equalities, maxm +;; + + +(* +let equations_blacklist = + List.fold_left + (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s) + UriManager.UriSet.empty [ + "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; + "cic:/Coq/Init/Logic/trans_eq.con"; + "cic:/Coq/Init/Logic/f_equal.con"; + "cic:/Coq/Init/Logic/f_equal2.con"; + "cic:/Coq/Init/Logic/f_equal3.con"; + "cic:/Coq/Init/Logic/f_equal4.con"; + "cic:/Coq/Init/Logic/f_equal5.con"; + "cic:/Coq/Init/Logic/sym_eq.con"; + "cic:/Coq/Init/Logic/eq_ind.con"; + "cic:/Coq/Init/Logic/eq_ind_r.con"; + "cic:/Coq/Init/Logic/eq_rec.con"; + "cic:/Coq/Init/Logic/eq_rec_r.con"; + "cic:/Coq/Init/Logic/eq_rect.con"; + "cic:/Coq/Init/Logic/eq_rect_r.con"; + "cic:/Coq/Logic/Eqdep/UIP.con"; + "cic:/Coq/Logic/Eqdep/UIP_refl.con"; + "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"; + "cic:/Coq/ZArith/Zcompare/rename.con"; + (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`... + perche' questo cacchio di teorema rompe le scatole :'( *) + "cic:/Rocq/SUBST/comparith/mult_n_2.con"; + + "cic:/matita/logic/equality/eq_f.con"; + "cic:/matita/logic/equality/eq_f2.con"; + "cic:/matita/logic/equality/eq_rec.con"; + "cic:/matita/logic/equality/eq_rect.con"; + ] +;; +*) +let equations_blacklist = UriManager.UriSet.empty;; + + +let find_library_equalities dbd context status maxmeta = + let module C = Cic in + let module S = CicSubstitution in + let module T = CicTypeChecker in + let blacklist = + List.fold_left + (fun s u -> UriManager.UriSet.add u s) + equations_blacklist + [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); + eq_ind_r_URI ()] + in + let candidates = + List.fold_left + (fun l uri -> + if UriManager.UriSet.mem uri blacklist then + l + else + let t = CicUtil.term_of_uri uri in + let ty, _ = + CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph + in + (uri, t, ty)::l) + [] + (let t1 = Unix.gettimeofday () in + let eqs = (MetadataQuery.equations_for_goal ~dbd status) in + let t2 = Unix.gettimeofday () in + (debug_print + (lazy + (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n" + (t2 -. t1)))); + eqs) + in + let eq_uri1 = eq_XURI () + and eq_uri2 = LibraryObjects.eq_URI () in + let iseq uri = + (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2) + in + let ok_types ty menv = + List.for_all (fun (_, _, mt) -> mt = ty) menv + in + let rec has_vars = function + | C.Meta _ | C.Rel _ | C.Const _ -> false + | C.Var _ -> true + | C.Appl l -> List.exists has_vars l + | C.Prod (_, s, t) | C.Lambda (_, s, t) + | C.LetIn (_, s, t) | C.Cast (s, t) -> + (has_vars s) || (has_vars t) + | _ -> false + in + let rec aux newmeta = function + | [] -> [], newmeta + | (uri, term, termty)::tl -> + debug_print + (lazy + (Printf.sprintf "Examining: %s (%s)" + (CicPp.ppterm term) (CicPp.ppterm termty))); + let res, newmeta = + match termty with + | C.Prod (name, s, t) when not (has_vars termty) -> + let head, newmetas, args, newmeta = + ProofEngineHelpers.saturate_term newmeta [] context termty 0 + in + let p = + if List.length args = 0 then + term + else + C.Appl (term::args) + in ( + match head with + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when (iseq uri) && (ok_types ty newmetas) -> + debug_print + (lazy + (Printf.sprintf "OK: %s" (CicPp.ppterm term))); + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let proof = BasicProof p in + let e = (w, proof, (ty, t1, t2, o), newmetas, args) in + Some e, (newmeta+1) + | _ -> None, newmeta + ) + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when iseq uri && not (has_vars termty) -> + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in + Some e, (newmeta+1) + | _ -> None, newmeta + in + match res with + | Some e -> + let tl, newmeta' = aux newmeta tl in + if newmeta' < newmeta then + prerr_endline "big trouble"; + (uri, e)::tl, newmeta' (* max???? *) + | None -> + aux newmeta tl + in + let found, maxm = aux maxmeta candidates in + let uriset, eqlist = + (List.fold_left + (fun (s, l) (u, e) -> + if List.exists (meta_convertibility_eq e) (List.map snd l) then ( + debug_print + (lazy + (Printf.sprintf "NO!! %s already there!" + (string_of_equality e))); + (UriManager.UriSet.add u s, l) + ) else (UriManager.UriSet.add u s, (u, e)::l)) + (UriManager.UriSet.empty, []) found) + in + uriset, eqlist, maxm +;; + + +let find_library_theorems dbd env status equalities_uris = + let module C = Cic in + let module S = CicSubstitution in + let module T = CicTypeChecker in + let blacklist = + let refl_equal = + UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in + let s = + UriManager.UriSet.remove refl_equal + (UriManager.UriSet.union equalities_uris equations_blacklist) + in + List.fold_left + (fun s u -> UriManager.UriSet.add u s) + s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); + eq_ind_r_URI ()] + in + let metasenv, context, ugraph = env in + let candidates = + List.fold_left + (fun l uri -> + if UriManager.UriSet.mem uri blacklist then l + else + let t = CicUtil.term_of_uri uri in + let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in + (t, ty, [])::l) + [] (MetadataQuery.signature_of_goal ~dbd status) + in + let refl_equal = + let u = eq_XURI () in + let t = CicUtil.term_of_uri u in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + (t, ty, []) + in + refl_equal::candidates +;; + + +let find_context_hypotheses env equalities_indexes = + let metasenv, context, ugraph = env in + let _, res = + List.fold_left + (fun (n, l) entry -> + match entry with + | None -> (n+1, l) + | Some _ -> + if List.mem n equalities_indexes then + (n+1, l) + else + let t = Cic.Rel n in + let ty, _ = + CicTypeChecker.type_of_aux' metasenv context t ugraph in + (n+1, (t, ty, [])::l)) + (1, []) context + in + res +;; + + +let fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) = + let table = Hashtbl.create (List.length args) in + + let newargs, newmeta = + List.fold_right + (fun t (newargs, index) -> + match t with + | Cic.Meta (i, l) -> + if Hashtbl.mem table i then + let idx = Hashtbl.find table i in + ((Cic.Meta (idx, l))::newargs, index+1) + else + let _ = Hashtbl.add table i index in + ((Cic.Meta (index, l))::newargs, index+1) + | _ -> assert false) + args ([], newmeta+1) + in + + let repl where = + ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs + ~where + in + let menv' = + List.fold_right + (fun (i, context, term) menv -> + try + let index = Hashtbl.find table i in + (index, context, term)::menv + with Not_found -> + (i, context, term)::menv) + menv [] + in + let ty = repl ty + and left = repl left + and right = repl right in + let metas = (metas_of_term left) @ (metas_of_term right) @ (metas_of_term ty) in + let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in + let newargs = + List.filter + (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs + in + let _ = + if List.length metas > 0 then + let first = List.hd metas in + (* this new equality might have less variables than its parents: here + we fill the gap with a dummy arg. Example: + with (f X Y) = X we can simplify + (g X) = (f X Y) in + (g X) = X. + So the new equation has only one variable, but it still has type like + \lambda X,Y:..., so we need to pass a dummy arg for Y + (I hope this makes some sense...) + *) + Hashtbl.iter + (fun k v -> + if not (List.exists + (function Cic.Meta (i, _) -> i = v | _ -> assert false) + newargs) then + Hashtbl.replace table k first) + (Hashtbl.copy table) + in + let rec fix_proof = function + | NoProof -> NoProof + | BasicProof term -> BasicProof (repl term) + | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) -> + let subst' = + List.fold_left + (fun s arg -> + match arg with + | Cic.Meta (i, l) -> ( + try + let j = Hashtbl.find table i in + if List.mem_assoc i subst then + s + else + let _, context, ty = CicUtil.lookup_meta i menv in + (i, (context, Cic.Meta (j, l), ty))::s + with Not_found | CicUtil.Meta_not_found _ -> + s + ) + | _ -> assert false) + [] args + in + ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p) + | p -> assert false + in + let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in + (newmeta +1, neweq) +;; + + +let relocate newmeta menv = + let subst, metasenv, newmeta = + List.fold_right + (fun (i, context, ty) (subst, menv, maxmeta) -> + let irl=CicMkImplicit.identity_relocation_list_for_metavariable context in + let newsubst = (i, (context, (Cic.Meta (maxmeta, irl)), ty)) in + let newmeta = maxmeta, context, ty in + newsubst::subst, newmeta::menv, maxmeta+1) + menv ([], [], newmeta+1) + in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + let subst = + List.map + (fun (i, (context, term, ty)) -> + let context = CicMetaSubst.apply_subst_context subst context in + let term = CicMetaSubst.apply_subst subst term in + let ty = CicMetaSubst.apply_subst subst ty in + (i, (context, term, ty))) subst in + subst, metasenv, newmeta + + +let fix_metas newmeta (w, p, (ty, left, right, o), menv, args) = + (* debug + let _ , eq = + fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) in + prerr_endline (string_of_equality eq); *) + let subst, metasenv, newmeta = relocate newmeta menv in + let ty = CicMetaSubst.apply_subst subst ty in + let left = CicMetaSubst.apply_subst subst left in + let right = CicMetaSubst.apply_subst subst right in + let args = List.map (CicMetaSubst.apply_subst subst) args in + let rec fix_proof = function + | NoProof -> NoProof + | BasicProof term -> BasicProof (CicMetaSubst.apply_subst subst term) + | ProofBlock (subst', eq_URI, namety, bo, (pos, eq), p) -> + ProofBlock (subst' @ subst, eq_URI, namety, bo, (pos, eq), p) + | p -> assert false + in + let metas = (metas_of_term left)@(metas_of_term right)@(metas_of_term ty) in + let metasenv = List.filter (fun (i, _, _) -> List.mem i metas) metasenv in + let eq = (w, fix_proof p, (ty, left, right, o), metasenv, args) in + (* debug prerr_endline (string_of_equality eq); *) + newmeta, eq + +let term_is_equality term = + let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in + match term with + | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true + | _ -> false +;; + + +exception TermIsNotAnEquality;; + +let equality_of_term proof term = + let eq_uri = LibraryObjects.eq_URI () in + let iseq uri = UriManager.eq uri eq_uri in + match term with + | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri -> + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in + e + | _ -> + raise TermIsNotAnEquality +;; + + +type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;; + +let is_weak_identity (metasenv, context, ugraph) = function + | (_, _, (ty, left, right, _), menv, _) -> + (left = right || + (meta_convertibility left right)) + (* the test below is not a good idea since it stops + demodulation too early *) + (* (fst (CicReduction.are_convertible + ~metasenv:(metasenv @ menv) context left right ugraph)))*) +;; + +let is_identity (metasenv, context, ugraph) = function + | (_, _, (ty, left, right, _), menv, _) -> + (left = right || + (* (meta_convertibility left right)) *) + (fst (CicReduction.are_convertible + ~metasenv:(metasenv @ menv) context left right ugraph))) +;; + + +let term_of_equality equality = + let _, _, (ty, left, right, _), menv, args = equality in + let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in + let argsno = List.length args in + let t = + CicSubstitution.lift argsno + (Cic.Appl [Cic.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right]) + in + snd ( + List.fold_right + (fun a (n, t) -> + match a with + | Cic.Meta (i, _) -> + let name = Cic.Name ("X" ^ (string_of_int n)) in + let _, _, ty = CicUtil.lookup_meta i menv in + let t = + ProofEngineReduction.replace + ~equality:eq ~what:[i] + ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t + in + (n-1, Cic.Prod (name, ty, t)) + | _ -> assert false) + args (argsno, t)) +;; diff --git a/helm/software/components/tactics/paramodulation/inference.mli b/helm/software/components/tactics/paramodulation/inference.mli new file mode 100644 index 000000000..b31d8bacf --- /dev/null +++ b/helm/software/components/tactics/paramodulation/inference.mli @@ -0,0 +1,134 @@ +(* Copyright (C) 2005, 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/. + *) + +type equality = + int * (* weight *) + proof * (* proof *) + (Cic.term * (* type *) + Cic.term * (* left side *) + Cic.term * (* right side *) + Utils.comparison) * (* ordering *) + Cic.metasenv * (* environment for metas *) + Cic.term list (* arguments *) + +and proof = + | NoProof (* no proof *) + | BasicProof of Cic.term (* already a proof of a goal *) + | ProofBlock of (* proof of a rewrite step *) + Cic.substitution * UriManager.uri * (* eq_ind or eq_ind_r *) + (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof + | ProofGoalBlock of proof * proof + (* proof of the new meta, proof of the goal from which this comes *) + | ProofSymBlock of Cic.term list * proof (* expl.named subst, proof *) + | SubProof of Cic.term * int * proof + (* parent proof, subgoal, proof of the subgoal *) + +type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph + +(** builds the Cic.term encoded by proof *) +val build_proof_term: ?noproof:Cic.term -> proof -> Cic.term + +val string_of_proof: proof -> string + +exception MatchingFailure + +(** matching between two terms. Can raise MatchingFailure *) +val matching: + Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> + CicUniv.universe_graph -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph + +(** + special unification that checks if the two terms are "simple", and in + such case should be significantly faster than CicUnification.fo_unif +*) +val unification: + Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> + CicUniv.universe_graph -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph + + +(** + scans the context to find all Declarations "left = right"; returns a + list of tuples (proof, (type, left, right), newmetas). Uses + PrimitiveTactics.new_metasenv_for_apply to replace bound variables with + fresh metas... +*) +val find_equalities: + Cic.context -> ProofEngineTypes.proof -> int list * equality list * int + +(** + searches the library for equalities that can be applied to the current goal +*) +val find_library_equalities: + HMysql.dbd -> Cic.context -> ProofEngineTypes.status -> int -> + UriManager.UriSet.t * (UriManager.uri * equality) list * int + +(** + searches the library for theorems that are not equalities (returned by the + function above) +*) +val find_library_theorems: + HMysql.dbd -> environment -> ProofEngineTypes.status -> UriManager.UriSet.t -> + (Cic.term * Cic.term * Cic.metasenv) list + +(** + searches the context for hypotheses that are not equalities +*) +val find_context_hypotheses: + environment -> int list -> (Cic.term * Cic.term * Cic.metasenv) list + + +exception TermIsNotAnEquality;; + +(** + raises TermIsNotAnEquality if term is not an equation. + The first Cic.term is a proof of the equation +*) +val equality_of_term: Cic.term -> Cic.term -> equality + +(** + Re-builds the term corresponding to this equality +*) +val term_of_equality: equality -> Cic.term + +val term_is_equality: Cic.term -> bool + +(** tests a sort of alpha-convertibility between the two terms, but on the + metavariables *) +val meta_convertibility: Cic.term -> Cic.term -> bool + +(** meta convertibility between two equations *) +val meta_convertibility_eq: equality -> equality -> bool + +val is_weak_identity: environment -> equality -> bool +val is_identity: environment -> equality -> bool + +val string_of_equality: ?env:environment -> equality -> string + +val metas_of_term: Cic.term -> int list + +(** ensures that metavariables in equality are unique *) +val fix_metas: int -> equality -> int * equality diff --git a/helm/software/components/tactics/paramodulation/saturate_main.ml b/helm/software/components/tactics/paramodulation/saturate_main.ml new file mode 100644 index 000000000..efcfca4ed --- /dev/null +++ b/helm/software/components/tactics/paramodulation/saturate_main.ml @@ -0,0 +1,166 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +module Trivial_disambiguate: +sig + exception Ambiguous_term of string Lazy.t + (** disambiguate an _unanmbiguous_ term using dummy callbacks which fail if a + * choice from the user is needed to disambiguate the term + * @raise Ambiguous_term for ambiguous term *) + val disambiguate_string: + dbd:HMysql.dbd -> + ?context:Cic.context -> + ?metasenv:Cic.metasenv -> + ?initial_ugraph:CicUniv.universe_graph -> + ?aliases:DisambiguateTypes.environment ->(* previous interpretation status*) + string -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * + Cic.metasenv * (* new metasenv *) + Cic.term * + CicUniv.universe_graph) list (* disambiguated term *) +end += +struct + exception Ambiguous_term of string Lazy.t + exception Exit + module Callbacks = + struct + let non p x = not (p x) + let interactive_user_uri_choice ~selection_mode ?ok + ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = + List.filter (non UriManager.uri_is_var) uris + let interactive_interpretation_choice interp = raise Exit + let input_or_locate_uri ~(title:string) ?id = raise Exit + end + module Disambiguator = Disambiguate.Make (Callbacks) + let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph + ?(aliases = DisambiguateTypes.Environment.empty) term + = + let ast = + CicNotationParser.parse_level2_ast (Ulexing.from_utf8_string term) + in + try + fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast + ?initial_ugraph ~aliases ~universe:None) + with Exit -> raise (Ambiguous_term (lazy term)) +end + +let configuration_file = ref "../../../matita/matita.conf.xml";; + +let core_notation_script = "../../../matita/core_notation.moo";; + +let get_from_user ~(dbd:HMysql.dbd) = + let rec get () = + match read_line () with + | "" -> [] + | t -> t::(get ()) + in + let term_string = String.concat "\n" (get ()) in + let env, metasenv, term, ugraph = + List.nth (Trivial_disambiguate.disambiguate_string dbd term_string) 0 + in + term, metasenv, ugraph +;; + +let full = ref false;; + +let retrieve_only = ref false;; + +let demod_equalities = ref false;; + +let main () = + let module S = Saturation in + let set_ratio v = S.weight_age_ratio := v; S.weight_age_counter := v + and set_sel v = S.symbols_ratio := v; S.symbols_counter := v; + and set_conf f = configuration_file := f + and set_ordering o = + match o with + | "lpo" -> Utils.compare_terms := Utils.lpo + | "kbo" -> Utils.compare_terms := Utils.kbo + | "nr-kbo" -> Utils.compare_terms := Utils.nonrec_kbo + | "ao" -> Utils.compare_terms := Utils.ao + | o -> raise (Arg.Bad ("Unknown term ordering: " ^ o)) + and set_fullred b = S.use_fullred := b + and set_time_limit v = S.time_limit := float_of_int v + and set_width w = S.maxwidth := w + and set_depth d = S.maxdepth := d + and set_full () = full := true + and set_retrieve () = retrieve_only := true + and set_demod_equalities () = demod_equalities := true + in + Arg.parse [ + "-full", Arg.Unit set_full, "Enable full mode"; + "-f", Arg.Bool set_fullred, + "Enable/disable full-reduction strategy (default: enabled)"; + + "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 4)"; + + "-s", Arg.Int set_sel, + "symbols-based selection ratio (relative to the weight ratio, default: 0)"; + + "-c", Arg.String set_conf, "Configuration file (for the db connection)"; + + "-o", Arg.String set_ordering, + "Term ordering. Possible values are:\n" ^ + "\tkbo: Knuth-Bendix ordering\n" ^ + "\tnr-kbo: Non-recursive variant of kbo (default)\n" ^ + "\tlpo: Lexicographic path ordering"; + + "-l", Arg.Int set_time_limit, "Time limit in seconds (default: no limit)"; + + "-w", Arg.Int set_width, + Printf.sprintf "Maximal width (default: %d)" !Saturation.maxwidth; + + "-d", Arg.Int set_depth, + Printf.sprintf "Maximal depth (default: %d)" !Saturation.maxdepth; + + "-retrieve", Arg.Unit set_retrieve, "retrieve only"; + "-demod-equalities", Arg.Unit set_demod_equalities, "demod equalities"; + ] (fun a -> ()) "Usage:"; + Helm_registry.load_from !configuration_file; + ignore (CicNotation2.load_notation [] core_notation_script); + ignore (CicNotation2.load_notation [] "../../../matita/library/legacy/coq.ma"); + let dbd = HMysql.quick_connect + ~host:(Helm_registry.get "db.host") + ~user:(Helm_registry.get "db.user") + ~database:(Helm_registry.get "db.database") + () + in + let term, metasenv, ugraph = get_from_user ~dbd in + if !retrieve_only then + Saturation.retrieve_and_print dbd term metasenv ugraph + else if !demod_equalities then + Saturation.main_demod_equalities dbd term metasenv ugraph + else + Saturation.main dbd !full term metasenv ugraph +;; + +let _ = + (*try*) + main () + (*with exn -> prerr_endline (Printexc.to_string exn)*) + diff --git a/helm/software/components/tactics/paramodulation/saturation.ml b/helm/software/components/tactics/paramodulation/saturation.ml new file mode 100644 index 000000000..6a700d868 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/saturation.ml @@ -0,0 +1,2366 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +open Inference;; +open Utils;; + +(* +for debugging +let check_equation env equation msg = + let w, proof, (eq_ty, left, right, order), metas, args = equation in + let metasenv, context, ugraph = env in + let metasenv' = metasenv @ metas in + try + CicTypeChecker.type_of_aux' metasenv' context left ugraph; + CicTypeChecker.type_of_aux' metasenv' context right ugraph; + () + with + CicUtil.Meta_not_found _ as exn -> + begin + prerr_endline msg; + prerr_endline (CicPp.ppterm left); + prerr_endline (CicPp.ppterm right); + raise exn + end +*) + +(* set to false to disable paramodulation inside auto_tac *) +let connect_to_auto = true;; + + +(* profiling statistics... *) +let infer_time = ref 0.;; +let forward_simpl_time = ref 0.;; +let forward_simpl_new_time = ref 0.;; +let backward_simpl_time = ref 0.;; +let passive_maintainance_time = ref 0.;; + +(* limited-resource-strategy related globals *) +let processed_clauses = ref 0;; (* number of equalities selected so far... *) +let time_limit = ref 0.;; (* in seconds, settable by the user... *) +let start_time = ref 0.;; (* time at which the execution started *) +let elapsed_time = ref 0.;; +(* let maximal_weight = ref None;; *) +let maximal_retained_equality = ref None;; + +(* equality-selection related globals *) +let use_fullred = ref true;; +let weight_age_ratio = ref (* 5 *) 4;; (* settable by the user *) +let weight_age_counter = ref !weight_age_ratio;; +let symbols_ratio = ref (* 0 *) 3;; +let symbols_counter = ref 0;; + +(* non-recursive Knuth-Bendix term ordering by default *) +(* Utils.compare_terms := Utils.rpo;; *) +(* Utils.compare_terms := Utils.nonrec_kbo;; *) +(* Utils.compare_terms := Utils.ao;; *) + +(* statistics... *) +let derived_clauses = ref 0;; +let kept_clauses = ref 0;; + +(* index of the greatest Cic.Meta created - TODO: find a better way! *) +let maxmeta = ref 0;; + +(* varbiables controlling the search-space *) +let maxdepth = ref 3;; +let maxwidth = ref 3;; + + +type result = + | ParamodulationFailure + | ParamodulationSuccess of Inference.proof option * environment +;; + +type goal = proof * Cic.metasenv * Cic.term;; + +type theorem = Cic.term * Cic.term * Cic.metasenv;; + +let symbols_of_equality (_, _, (_, left, right, _), _, _) = + let m1 = symbols_of_term left in + let m = + TermMap.fold + (fun k v res -> + try + let c = TermMap.find k res in + TermMap.add k (c+v) res + with Not_found -> + TermMap.add k v res) + (symbols_of_term right) m1 + in + m +;; + +module OrderedEquality = struct + type t = Inference.equality + + let compare eq1 eq2 = + match meta_convertibility_eq eq1 eq2 with + | true -> 0 + | false -> + let w1, _, (ty, left, right, _), _, a = eq1 + and w2, _, (ty', left', right', _), _, a' = eq2 in + match Pervasives.compare w1 w2 with + | 0 -> + let res = (List.length a) - (List.length a') in + if res <> 0 then res else ( + try + let res = Pervasives.compare (List.hd a) (List.hd a') in + if res <> 0 then res else Pervasives.compare eq1 eq2 + with Failure "hd" -> Pervasives.compare eq1 eq2 + ) + | res -> res +end + +module EqualitySet = Set.Make(OrderedEquality);; + + +(** + selects one equality from passive. The selection strategy is a combination + of weight, age and goal-similarity +*) +let select env goals passive (active, _) = + processed_clauses := !processed_clauses + 1; + let goal = + match (List.rev goals) with (_, goal::_)::_ -> goal | _ -> assert false + in + let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in + let remove eq l = + List.filter (fun e -> e <> eq) l + in + if !weight_age_ratio > 0 then + weight_age_counter := !weight_age_counter - 1; + match !weight_age_counter with + | 0 -> ( + weight_age_counter := !weight_age_ratio; + match neg_list, pos_list with + | hd::tl, pos -> + (* Negatives aren't indexed, no need to remove them... *) + (Negative, hd), + ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table) + | [], (hd:EqualitySet.elt)::tl -> + let passive_table = + Indexing.remove_index passive_table hd + in + (Positive, hd), + (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table) + | _, _ -> assert false + ) + | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> ( + symbols_counter := !symbols_counter - 1; + let cardinality map = + TermMap.fold (fun k v res -> res + v) map 0 + in + let symbols = + let _, _, term = goal in + symbols_of_term term + in + let card = cardinality symbols in + let foldfun k v (r1, r2) = + if TermMap.mem k symbols then + let c = TermMap.find k symbols in + let c1 = abs (c - v) in + let c2 = v - c1 in + r1 + c2, r2 + c1 + else + r1, r2 + v + in + let f equality (i, e) = + let common, others = + TermMap.fold foldfun (symbols_of_equality equality) (0, 0) + in + let c = others + (abs (common - card)) in + if c < i then (c, equality) + else (i, e) + in + let e1 = EqualitySet.min_elt pos_set in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality e1) (0, 0) + in + (others + (abs (common - card))), e1 + in + let _, current = EqualitySet.fold f pos_set initial in + let passive_table = + Indexing.remove_index passive_table current + in + (Positive, current), + (([], neg_set), + (remove current pos_list, EqualitySet.remove current pos_set), + passive_table) + ) + | _ -> + symbols_counter := !symbols_ratio; + let set_selection set = EqualitySet.min_elt set in + if EqualitySet.is_empty neg_set then + let current = set_selection pos_set in + let passive = + (neg_list, neg_set), + (remove current pos_list, EqualitySet.remove current pos_set), + Indexing.remove_index passive_table current + in + (Positive, current), passive + else + let current = set_selection neg_set in + let passive = + (remove current neg_list, EqualitySet.remove current neg_set), + (pos_list, pos_set), + passive_table + in + (Negative, current), passive +;; + + +(* initializes the passive set of equalities *) +let make_passive neg pos = + let set_of equalities = + List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities + in + let table = + List.fold_left (fun tbl e -> Indexing.index tbl e) Indexing.empty pos + in + (neg, set_of neg), + (pos, set_of pos), + table +;; + + +let make_active () = + [], Indexing.empty +;; + + +(* adds to passive a list of equalities: new_neg is a list of negative + equalities, new_pos a list of positive equalities *) +let add_to_passive passive (new_neg, new_pos) = + let (neg_list, neg_set), (pos_list, pos_set), table = passive in + let ok set equality = not (EqualitySet.mem equality set) in + let neg = List.filter (ok neg_set) new_neg + and pos = List.filter (ok pos_set) new_pos in + let table = + List.fold_left (fun tbl e -> Indexing.index tbl e) table pos + in + let add set equalities = + List.fold_left (fun s e -> EqualitySet.add e s) set equalities + in + (neg @ neg_list, add neg_set neg), + (pos_list @ pos, add pos_set pos), + table +;; + + +let passive_is_empty = function + | ([], _), ([], _), _ -> true + | _ -> false +;; + + +let size_of_passive ((_, ns), (_, ps), _) = + (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps) +;; + + +let size_of_active (active_list, _) = + List.length active_list +;; + + +(* removes from passive equalities that are estimated impossible to activate + within the current time limit *) +let prune_passive howmany (active, _) passive = + let (nl, ns), (pl, ps), tbl = passive in + let howmany = float_of_int howmany + and ratio = float_of_int !weight_age_ratio in + let round v = + let t = ceil v in + int_of_float (if t -. v < 0.5 then t else v) + in + let in_weight = round (howmany *. ratio /. (ratio +. 1.)) + and in_age = round (howmany /. (ratio +. 1.)) in + debug_print + (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age)); + let symbols, card = + match active with + | (Negative, e)::_ -> + let symbols = symbols_of_equality e in + let card = TermMap.fold (fun k v res -> res + v) symbols 0 in + Some symbols, card + | _ -> None, 0 + in + let counter = ref !symbols_ratio in + let rec pickw w ns ps = + if w > 0 then + if not (EqualitySet.is_empty ns) then + let e = EqualitySet.min_elt ns in + let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in + EqualitySet.add e ns', ps + else if !counter > 0 then + let _ = + counter := !counter - 1; + if !counter = 0 then counter := !symbols_ratio + in + match symbols with + | None -> + let e = EqualitySet.min_elt ps in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + | Some symbols -> + let foldfun k v (r1, r2) = + if TermMap.mem k symbols then + let c = TermMap.find k symbols in + let c1 = abs (c - v) in + let c2 = v - c1 in + r1 + c2, r2 + c1 + else + r1, r2 + v + in + let f equality (i, e) = + let common, others = + TermMap.fold foldfun (symbols_of_equality equality) (0, 0) + in + let c = others + (abs (common - card)) in + if c < i then (c, equality) + else (i, e) + in + let e1 = EqualitySet.min_elt ps in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality e1) (0, 0) + in + (others + (abs (common - card))), e1 + in + let _, e = EqualitySet.fold f ps initial in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + else + let e = EqualitySet.min_elt ps in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + else + EqualitySet.empty, EqualitySet.empty + in + let ns, ps = pickw in_weight ns ps in + let rec picka w s l = + if w > 0 then + match l with + | [] -> w, s, [] + | hd::tl when not (EqualitySet.mem hd s) -> + let w, s, l = picka (w-1) s tl in + w, EqualitySet.add hd s, hd::l + | hd::tl -> + let w, s, l = picka w s tl in + w, s, hd::l + else + 0, s, l + in + let in_age, ns, nl = picka in_age ns nl in + let _, ps, pl = picka in_age ps pl in + if not (EqualitySet.is_empty ps) then + maximal_retained_equality := Some (EqualitySet.max_elt ps); + let tbl = + EqualitySet.fold + (fun e tbl -> Indexing.index tbl e) ps Indexing.empty + in + (nl, ns), (pl, ps), tbl +;; + + +(** inference of new equalities between current and some in active *) +let infer env sign current (active_list, active_table) = + let new_neg, new_pos = + match sign with + | Negative -> + let maxm, res = + Indexing.superposition_left !maxmeta env active_table current in + maxmeta := maxm; + res, [] + | Positive -> + let maxm, res = + Indexing.superposition_right !maxmeta env active_table current in + maxmeta := maxm; + let rec infer_positive table = function + | [] -> [], [] + | (Negative, equality)::tl -> + let maxm, res = + Indexing.superposition_left !maxmeta env table equality in + maxmeta := maxm; + let neg, pos = infer_positive table tl in + res @ neg, pos + | (Positive, equality)::tl -> + let maxm, res = + Indexing.superposition_right !maxmeta env table equality in + maxmeta := maxm; + let neg, pos = infer_positive table tl in + neg, res @ pos + in + let curr_table = Indexing.index Indexing.empty current in + let neg, pos = infer_positive curr_table active_list in + neg, res @ pos + in + derived_clauses := !derived_clauses + (List.length new_neg) + + (List.length new_pos); + match !maximal_retained_equality with + | None -> new_neg, new_pos + | Some eq -> + (* if we have a maximal_retained_equality, we can discard all equalities + "greater" than it, as they will never be reached... An equality is + greater than maximal_retained_equality if it is bigger + wrt. OrderedEquality.compare and it is less similar than + maximal_retained_equality to the current goal *) + let symbols, card = + match active_list with + | (Negative, e)::_ -> + let symbols = symbols_of_equality e in + let card = TermMap.fold (fun k v res -> res + v) symbols 0 in + Some symbols, card + | _ -> None, 0 + in + let new_pos = + match symbols with + | None -> + List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos + | Some symbols -> + let filterfun e = + if OrderedEquality.compare e eq <= 0 then + true + else + let foldfun k v (r1, r2) = + if TermMap.mem k symbols then + let c = TermMap.find k symbols in + let c1 = abs (c - v) in + let c2 = v - c1 in + r1 + c2, r2 + c1 + else + r1, r2 + v + in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality eq) (0, 0) in + others + (abs (common - card)) + in + let common, others = + TermMap.fold foldfun (symbols_of_equality e) (0, 0) in + let c = others + (abs (common - card)) in + if c < initial then true else false + in + List.filter filterfun new_pos + in + new_neg, new_pos +;; + + +let contains_empty env (negative, positive) = + let metasenv, context, ugraph = env in + try + let found = + List.find + (fun (w, proof, (ty, left, right, ordering), m, a) -> + fst (CicReduction.are_convertible context left right ugraph)) + negative + in + true, Some found + with Not_found -> + false, None +;; + + +(** simplifies current using active and passive *) +let forward_simplify env (sign, current) ?passive (active_list, active_table) = + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + let all = if pl = [] then active_list else active_list @ pl in + + let demodulate table current = + let newmeta, newcurrent = + Indexing.demodulation_equality !maxmeta env table sign current in + maxmeta := newmeta; + if is_identity env newcurrent then + if sign = Negative then Some (sign, newcurrent) + else ( +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "\ncurrent was: %s\nnewcurrent is: %s\n" *) +(* (string_of_equality current) *) +(* (string_of_equality newcurrent))); *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "active is: %s" *) +(* (String.concat "\n" *) +(* (List.map (fun (_, e) -> (string_of_equality e)) active_list)))); *) + None + ) + else + Some (sign, newcurrent) + in + let res = + let res = demodulate active_table current in + match res with + | None -> None + | Some (sign, newcurrent) -> + match passive_table with + | None -> res + | Some passive_table -> demodulate passive_table newcurrent + in + match res with + | None -> None + | Some (Negative, c) -> + let ok = not ( + List.exists + (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c) + all) + in + if ok then res else None + | Some (Positive, c) -> + if Indexing.in_index active_table c then + None + else + match passive_table with + | None -> + if fst (Indexing.subsumption env active_table c) then + None + else + res + | Some passive_table -> + if Indexing.in_index passive_table c then None + else + let r1, _ = Indexing.subsumption env active_table c in + if r1 then None else + let r2, _ = Indexing.subsumption env passive_table c in + if r2 then None else res +;; + +type fs_time_info_t = { + mutable build_all: float; + mutable demodulate: float; + mutable subsumption: float; +};; + +let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };; + + +(** simplifies new using active and passive *) +let forward_simplify_new env (new_neg, new_pos) ?passive active = + let t1 = Unix.gettimeofday () in + + let active_list, active_table = active in + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + + let t2 = Unix.gettimeofday () in + fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1); + + let demodulate sign table target = + let newmeta, newtarget = + Indexing.demodulation_equality !maxmeta env table sign target in + maxmeta := newmeta; + newtarget + in + let t1 = Unix.gettimeofday () in + + let new_neg, new_pos = + let new_neg = List.map (demodulate Negative active_table) new_neg + and new_pos = List.map (demodulate Positive active_table) new_pos in + new_neg,new_pos + +(* PROVA + match passive_table with + | None -> new_neg, new_pos + | Some passive_table -> + List.map (demodulate Negative passive_table) new_neg, + List.map (demodulate Positive passive_table) new_pos *) + in + + let t2 = Unix.gettimeofday () in + fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1); + + let new_pos_set = + List.fold_left + (fun s e -> + if not (Inference.is_identity env e) then + if EqualitySet.mem e s then s + else EqualitySet.add e s + else s) + EqualitySet.empty new_pos + in + let new_pos = EqualitySet.elements new_pos_set in + + let subs = + match passive_table with + | None -> + (fun e -> not (fst (Indexing.subsumption env active_table e))) + | Some passive_table -> + (fun e -> not ((fst (Indexing.subsumption env active_table e)) || + (fst (Indexing.subsumption env passive_table e)))) + in +(* let t1 = Unix.gettimeofday () in *) +(* let t2 = Unix.gettimeofday () in *) +(* fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); *) + let is_duplicate = + match passive_table with + | None -> + (fun e -> not (Indexing.in_index active_table e)) + | Some passive_table -> + (fun e -> + not ((Indexing.in_index active_table e) || + (Indexing.in_index passive_table e))) + in + new_neg, List.filter subs (List.filter is_duplicate new_pos) +;; + + +(** simplifies active usign new *) +let backward_simplify_active env new_pos new_table min_weight active = + let active_list, active_table = active in + let active_list, newa = + List.fold_right + (fun (s, equality) (res, newn) -> + let ew, _, _, _, _ = equality in + if ew < min_weight then + (s, equality)::res, newn + else + match forward_simplify env (s, equality) (new_pos, new_table) with + | None -> res, newn + | Some (s, e) -> + if equality = e then + (s, e)::res, newn + else + res, (s, e)::newn) + active_list ([], []) + in + let find eq1 where = + List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where + in + let active, newa = + List.fold_right + (fun (s, eq) (res, tbl) -> + if List.mem (s, eq) res then + res, tbl + else if (is_identity env eq) || (find eq res) then ( + res, tbl + ) + else + (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq) + active_list ([], Indexing.empty), + List.fold_right + (fun (s, eq) (n, p) -> + if (s <> Negative) && (is_identity env eq) then ( + (n, p) + ) else + if s = Negative then eq::n, p + else n, eq::p) + newa ([], []) + in + match newa with + | [], [] -> active, None + | _ -> active, Some newa +;; + + +(** simplifies passive using new *) +let backward_simplify_passive env new_pos new_table min_weight passive = + let (nl, ns), (pl, ps), passive_table = passive in + let f sign equality (resl, ress, newn) = + let ew, _, _, _, _ = equality in + if ew < min_weight then + equality::resl, ress, newn + else + match forward_simplify env (sign, equality) (new_pos, new_table) with + | None -> resl, EqualitySet.remove equality ress, newn + | Some (s, e) -> + if equality = e then + equality::resl, ress, newn + else + let ress = EqualitySet.remove equality ress in + resl, ress, e::newn + in + let nl, ns, newn = List.fold_right (f Negative) nl ([], ns, []) + and pl, ps, newp = List.fold_right (f Positive) pl ([], ps, []) in + let passive_table = + List.fold_left + (fun tbl e -> Indexing.index tbl e) Indexing.empty pl + in + match newn, newp with + | [], [] -> ((nl, ns), (pl, ps), passive_table), None + | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp) +;; + + +let backward_simplify env new' ?passive active = + let new_pos, new_table, min_weight = + List.fold_left + (fun (l, t, w) e -> + let ew, _, _, _, _ = e in + (Positive, e)::l, Indexing.index t e, min ew w) + ([], Indexing.empty, 1000000) (snd new') + in + let active, newa = + backward_simplify_active env new_pos new_table min_weight active in + match passive with + | None -> + active, (make_passive [] []), newa, None + | Some passive -> + let passive, newp = + backward_simplify_passive env new_pos new_table min_weight passive in + active, passive, newa, newp +;; + + +(* returns an estimation of how many equalities in passive can be activated + within the current time limit *) +let get_selection_estimate () = + elapsed_time := (Unix.gettimeofday ()) -. !start_time; + (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *) + int_of_float ( + ceil ((float_of_int !processed_clauses) *. + ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.))) +;; + + +(** initializes the set of goals *) +let make_goals goal = + let active = [] + and passive = [0, [goal]] in + active, passive +;; + + +(** initializes the set of theorems *) +let make_theorems theorems = + theorems, [] +;; + + +let activate_goal (active, passive) = + match passive with + | goal_conj::tl -> true, (goal_conj::active, tl) + | [] -> false, (active, passive) +;; + + +let activate_theorem (active, passive) = + match passive with + | theorem::tl -> true, (theorem::active, tl) + | [] -> false, (active, passive) +;; + + +(** simplifies a goal with equalities in active and passive *) +let simplify_goal env goal ?passive (active_list, active_table) = + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + + let demodulate table goal = + let newmeta, newgoal = + Indexing.demodulation_goal !maxmeta env table goal in + maxmeta := newmeta; + goal != newgoal, newgoal + in + let changed, goal = + match passive_table with + | None -> demodulate active_table goal + | Some passive_table -> + let changed, goal = demodulate active_table goal in + let changed', goal = demodulate passive_table goal in + (changed || changed'), goal + in + changed, goal +;; + + +let simplify_goals env goals ?passive active = + let a_goals, p_goals = goals in + let p_goals = + List.map + (fun (d, gl) -> + let gl = + List.map (fun g -> snd (simplify_goal env g ?passive active)) gl in + d, gl) + p_goals + in + let goals = + List.fold_left + (fun (a, p) (d, gl) -> + let changed = ref false in + let gl = + List.map + (fun g -> + let c, g = simplify_goal env g ?passive active in + changed := !changed || c; g) gl in + if !changed then (a, (d, gl)::p) else ((d, gl)::a, p)) + ([], p_goals) a_goals + in + goals +;; + + +let simplify_theorems env theorems ?passive (active_list, active_table) = + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + let a_theorems, p_theorems = theorems in + let demodulate table theorem = + let newmeta, newthm = + Indexing.demodulation_theorem !maxmeta env table theorem in + maxmeta := newmeta; + theorem != newthm, newthm + in + let foldfun table (a, p) theorem = + let changed, theorem = demodulate table theorem in + if changed then (a, theorem::p) else (theorem::a, p) + in + let mapfun table theorem = snd (demodulate table theorem) in + match passive_table with + | None -> + let p_theorems = List.map (mapfun active_table) p_theorems in + List.fold_left (foldfun active_table) ([], p_theorems) a_theorems + | Some passive_table -> + let p_theorems = List.map (mapfun active_table) p_theorems in + let p_theorems, a_theorems = + List.fold_left (foldfun active_table) ([], p_theorems) a_theorems in + let p_theorems = List.map (mapfun passive_table) p_theorems in + List.fold_left (foldfun passive_table) ([], p_theorems) a_theorems +;; + + +let rec simpl env e others others_simpl = + let active = others @ others_simpl in + let tbl = + List.fold_left + (fun t (_, e) -> Indexing.index t e) + Indexing.empty active + in + let res = forward_simplify env e (active, tbl) in + match others with + | hd::tl -> ( + match res with + | None -> simpl env hd tl others_simpl + | Some e -> simpl env hd tl (e::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> e::others_simpl + ) +;; + +let simplify_equalities env equalities = + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "SIMPLYFYING EQUALITIES..."); + match equalities with + | [] -> [] + | hd::tl -> + let others = List.map (fun e -> (Positive, e)) tl in + let res = + List.rev (List.map snd (simpl env (Positive, hd) others [])) + in + debug_print + (lazy + (Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res)))); + res +;; + +(* applies equality to goal to see if the goal can be closed *) +let apply_equality_to_goal env equality goal = + let module C = Cic in + let module HL = HelmLibraryObjects in + let module I = Inference in + let metasenv, context, ugraph = env in + let _, proof, (ty, left, right, _), metas, args = equality in + let eqterm = + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right] in + let gproof, gmetas, gterm = goal in +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "APPLY EQUALITY TO GOAL: %s, %s" *) +(* (string_of_equality equality) (CicPp.ppterm gterm))); *) + try + let subst, metasenv', _ = + let menv = metasenv @ metas @ gmetas in + Inference.unification menv context eqterm gterm ugraph + in + let newproof = + match proof with + | I.BasicProof t -> I.BasicProof (CicMetaSubst.apply_subst subst t) + | I.ProofBlock (s, uri, nt, t, pe, p) -> + I.ProofBlock (subst @ s, uri, nt, t, pe, p) + | _ -> assert false + in + let newgproof = + let rec repl = function + | I.ProofGoalBlock (_, gp) -> I.ProofGoalBlock (newproof, gp) + | I.NoProof -> newproof + | I.BasicProof p -> newproof + | I.SubProof (t, i, p) -> I.SubProof (t, i, repl p) + | _ -> assert false + in + repl gproof + in + true, subst, newgproof + with CicUnification.UnificationFailure _ -> + false, [], I.NoProof +;; + + + +let new_meta metasenv = + let m = CicMkImplicit.new_meta metasenv [] in + incr maxmeta; + while !maxmeta <= m do incr maxmeta done; + !maxmeta +;; + + +(* applies a theorem or an equality to goal, returning a list of subgoals or + an indication of failure *) +let apply_to_goal env theorems ?passive active goal = + let metasenv, context, ugraph = env in + let proof, metas, term = goal in + (* debug_print *) + (* (lazy *) + (* (Printf.sprintf "apply_to_goal with goal: %s" *) + (* (\* (string_of_proof proof) *\)(CicPp.ppterm term))); *) + let status = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + let proof', newmeta = + let rec get_meta = function + | SubProof (t, i, p) -> + let t', i' = get_meta p in + if i' = -1 then t, i else t', i' + | ProofGoalBlock (_, p) -> get_meta p + | _ -> Cic.Implicit None, -1 + in + let p, m = get_meta proof in + if m = -1 then + let n = new_meta (metasenv @ metas) in + Cic.Meta (n, irl), n + else + p, m + in + let metasenv = (newmeta, context, term)::metasenv @ metas in + let bit = new_meta metasenv, context, term in + let metasenv' = bit::metasenv in + ((None, metasenv', Cic.Meta (newmeta, irl), term), newmeta) + in + let rec aux = function + | [] -> `No + | (theorem, thmty, _)::tl -> + try + let subst, (newproof, newgoals) = + PrimitiveTactics.apply_tac_verbose_with_subst ~term:theorem status + in + if newgoals = [] then + let _, _, p, _ = newproof in + let newp = + let rec repl = function + | Inference.ProofGoalBlock (_, gp) -> + Inference.ProofGoalBlock (Inference.BasicProof p, gp) + | Inference.NoProof -> Inference.BasicProof p + | Inference.BasicProof _ -> Inference.BasicProof p + | Inference.SubProof (t, i, p2) -> + Inference.SubProof (t, i, repl p2) + | _ -> assert false + in + repl proof + in + let _, m = status in + let subst = List.filter (fun (i, _) -> i = m) subst in + `Ok (subst, [newp, metas, term]) + else + let _, menv, p, _ = newproof in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context + in + let goals = + List.map + (fun i -> + let _, _, ty = CicUtil.lookup_meta i menv in + let p' = + let rec gp = function + | SubProof (t, i, p) -> + SubProof (t, i, gp p) + | ProofGoalBlock (sp1, sp2) -> + ProofGoalBlock (sp1, gp sp2) + | BasicProof _ + | NoProof -> + SubProof (p, i, BasicProof (Cic.Meta (i, irl))) + | ProofSymBlock (s, sp) -> + ProofSymBlock (s, gp sp) + | ProofBlock (s, u, nt, t, pe, sp) -> + ProofBlock (s, u, nt, t, pe, gp sp) + in gp proof + in + (p', menv, ty)) + newgoals + in + let goals = + let weight t = + let w, m = weight_of_term t in + w + 2 * (List.length m) + in + List.sort + (fun (_, _, t1) (_, _, t2) -> + Pervasives.compare (weight t1) (weight t2)) + goals + in + let best = aux tl in + match best with + | `Ok (_, _) -> best + | `No -> `GoOn ([subst, goals]) + | `GoOn sl -> `GoOn ((subst, goals)::sl) + with ProofEngineTypes.Fail msg -> + aux tl + in + let r, s, l = + if Inference.term_is_equality term then + let rec appleq_a = function + | [] -> false, [], [] + | (Positive, equality)::tl -> + let ok, s, newproof = apply_equality_to_goal env equality goal in + if ok then true, s, [newproof, metas, term] else appleq_a tl + | _::tl -> appleq_a tl + in + let rec appleq_p = function + | [] -> false, [], [] + | equality::tl -> + let ok, s, newproof = apply_equality_to_goal env equality goal in + if ok then true, s, [newproof, metas, term] else appleq_p tl + in + let al, _ = active in + match passive with + | None -> appleq_a al + | Some (_, (pl, _), _) -> + let r, s, l = appleq_a al in if r then r, s, l else appleq_p pl + else + false, [], [] + in + if r = true then `Ok (s, l) else aux theorems +;; + + +(* sorts a conjunction of goals in order to detect earlier if it is + unsatisfiable. Non-predicate goals are placed at the end of the list *) +let sort_goal_conj (metasenv, context, ugraph) (depth, gl) = + let gl = + List.stable_sort + (fun (_, e1, g1) (_, e2, g2) -> + let ty1, _ = + CicTypeChecker.type_of_aux' (e1 @ metasenv) context g1 ugraph + and ty2, _ = + CicTypeChecker.type_of_aux' (e2 @ metasenv) context g2 ugraph + in + let prop1 = + let b, _ = + CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty1 ugraph + in + if b then 0 else 1 + and prop2 = + let b, _ = + CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty2 ugraph + in + if b then 0 else 1 + in + if prop1 = 0 && prop2 = 0 then + let e1 = if Inference.term_is_equality g1 then 0 else 1 + and e2 = if Inference.term_is_equality g2 then 0 else 1 in + e1 - e2 + else + prop1 - prop2) + gl + in + (depth, gl) +;; + + +let is_meta_closed goals = + List.for_all (fun (_, _, g) -> CicUtil.is_meta_closed g) goals +;; + + +(* applies a series of theorems/equalities to a conjunction of goals *) +let rec apply_to_goal_conj env theorems ?passive active (depth, goals) = + let aux (goal, r) tl = + let propagate_subst subst (proof, metas, term) = + let rec repl = function + | NoProof -> NoProof + | BasicProof t -> + BasicProof (CicMetaSubst.apply_subst subst t) + | ProofGoalBlock (p, pb) -> + let pb' = repl pb in + ProofGoalBlock (p, pb') + | SubProof (t, i, p) -> + let t' = CicMetaSubst.apply_subst subst t in + let p = repl p in + SubProof (t', i, p) + | ProofSymBlock (ens, p) -> ProofSymBlock (ens, repl p) + | ProofBlock (s, u, nty, t, pe, p) -> + ProofBlock (subst @ s, u, nty, t, pe, p) + in (repl proof, metas, term) + in + (* let r = apply_to_goal env theorems ?passive active goal in *) ( + match r with + | `No -> `No (depth, goals) + | `GoOn sl -> + let l = + List.map + (fun (s, gl) -> + let tl = List.map (propagate_subst s) tl in + sort_goal_conj env (depth+1, gl @ tl)) sl + in + `GoOn l + | `Ok (subst, gl) -> + if tl = [] then + `Ok (depth, gl) + else + let p, _, _ = List.hd gl in + let subproof = + let rec repl = function + | SubProof (_, _, p) -> repl p + | ProofGoalBlock (p1, p2) -> + ProofGoalBlock (repl p1, repl p2) + | p -> p + in + build_proof_term (repl p) + in + let i = + let rec get_meta = function + | SubProof (_, i, p) -> + let i' = get_meta p in + if i' = -1 then i else i' +(* max i (get_meta p) *) + | ProofGoalBlock (_, p) -> get_meta p + | _ -> -1 + in + get_meta p + in + let subst = + let _, (context, _, _) = List.hd subst in + [i, (context, subproof, Cic.Implicit None)] + in + let tl = List.map (propagate_subst subst) tl in + let conj = sort_goal_conj env (depth(* +1 *), tl) in + `GoOn ([conj]) + ) + in + if depth > !maxdepth || (List.length goals) > !maxwidth then + `No (depth, goals) + else + let rec search_best res = function + | [] -> res + | goal::tl -> + let r = apply_to_goal env theorems ?passive active goal in + match r with + | `Ok _ -> (goal, r) + | `No -> search_best res tl + | `GoOn l -> + let newres = + match res with + | _, `Ok _ -> assert false + | _, `No -> goal, r + | _, `GoOn l2 -> + if (List.length l) < (List.length l2) then goal, r else res + in + search_best newres tl + in + let hd = List.hd goals in + let res = hd, (apply_to_goal env theorems ?passive active hd) in + let best = + match res with + | _, `Ok _ -> res + | _, _ -> search_best res (List.tl goals) + in + let res = aux best (List.filter (fun g -> g != (fst best)) goals) in + match res with + | `GoOn ([conj]) when is_meta_closed (snd conj) && + (List.length (snd conj)) < (List.length goals)-> + apply_to_goal_conj env theorems ?passive active conj + | _ -> res +;; + + +(* +module OrderedGoals = struct + type t = int * (Inference.proof * Cic.metasenv * Cic.term) list + + let compare g1 g2 = + let d1, l1 = g1 + and d2, l2 = g2 in + let r = d2 - d1 in + if r <> 0 then r + else let r = (List.length l1) - (List.length l2) in + if r <> 0 then r + else + let res = ref 0 in + let _ = + List.exists2 + (fun (_, _, t1) (_, _, t2) -> + let r = Pervasives.compare t1 t2 in + if r <> 0 then ( + res := r; + true + ) else + false) l1 l2 + in !res +end + +module GoalsSet = Set.Make(OrderedGoals);; + + +exception SearchSpaceOver;; +*) + + +(* +let apply_to_goals env is_passive_empty theorems active goals = + debug_print (lazy "\n\n\tapply_to_goals\n\n"); + let add_to set goals = + List.fold_left (fun s g -> GoalsSet.add g s) set goals + in + let rec aux set = function + | [] -> + debug_print (lazy "HERE!!!"); + if is_passive_empty then raise SearchSpaceOver else false, set + | goals::tl -> + let res = apply_to_goal_conj env theorems active goals in + match res with + | `Ok newgoals -> + let _ = + let d, p, t = + match newgoals with + | (d, (p, _, t)::_) -> d, p, t + | _ -> assert false + in + debug_print + (lazy + (Printf.sprintf "\nOK!!!!\ndepth: %d\nProof: %s\ngoal: %s\n" + d (string_of_proof p) (CicPp.ppterm t))) + in + true, GoalsSet.singleton newgoals + | `GoOn newgoals -> + let set' = add_to set (goals::tl) in + let set' = add_to set' newgoals in + false, set' + | `No newgoals -> + aux set tl + in + let n = List.length goals in + let res, goals = aux (add_to GoalsSet.empty goals) goals in + let goals = GoalsSet.elements goals in + debug_print (lazy "\n\tapply_to_goals end\n"); + let m = List.length goals in + if m = n && is_passive_empty then + raise SearchSpaceOver + else + res, goals +;; +*) + + +(* sorts the list of passive goals to minimize the search for a proof (doesn't + work that well yet...) *) +let sort_passive_goals goals = + List.stable_sort + (fun (d1, l1) (d2, l2) -> + let r1 = d2 - d1 + and r2 = (List.length l1) - (List.length l2) in + let foldfun ht (_, _, t) = + let _ = List.map (fun i -> Hashtbl.replace ht i 1) (metas_of_term t) + in ht + in + let m1 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l1) + and m2 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l2) + in let r3 = m1 - m2 in + if r3 <> 0 then r3 + else if r2 <> 0 then r2 + else r1) + (* let _, _, g1 = List.hd l1 *) +(* and _, _, g2 = List.hd l2 in *) +(* let e1 = if Inference.term_is_equality g1 then 0 else 1 *) +(* and e2 = if Inference.term_is_equality g2 then 0 else 1 *) +(* in let r4 = e1 - e2 in *) +(* if r4 <> 0 then r3 else r1) *) + goals +;; + + +let print_goals goals = + (String.concat "\n" + (List.map + (fun (d, gl) -> + let gl' = + List.map + (fun (p, _, t) -> + (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl + in + Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals)) +;; + + +(* tries to prove the first conjunction in goals with applications of + theorems/equalities, returning new sub-goals or an indication of success *) +let apply_goal_to_theorems dbd env theorems ?passive active goals = + let theorems, _ = theorems in + let a_goals, p_goals = goals in + let goal = List.hd a_goals in + let not_in_active gl = + not + (List.exists + (fun (_, gl') -> + if (List.length gl) = (List.length gl') then + List.for_all2 (fun (_, _, g1) (_, _, g2) -> g1 = g2) gl gl' + else + false) + a_goals) + in + let aux theorems = + let res = apply_to_goal_conj env theorems ?passive active goal in + match res with + | `Ok newgoals -> + true, ([newgoals], []) + | `No _ -> + false, (a_goals, p_goals) + | `GoOn newgoals -> + let newgoals = + List.filter + (fun (d, gl) -> + (d <= !maxdepth) && (List.length gl) <= !maxwidth && + not_in_active gl) + newgoals in + let p_goals = newgoals @ p_goals in + let p_goals = sort_passive_goals p_goals in + false, (a_goals, p_goals) + in + aux theorems +;; + + +let apply_theorem_to_goals env theorems active goals = + let a_goals, p_goals = goals in + let theorem = List.hd (fst theorems) in + let theorems = [theorem] in + let rec aux p = function + | [] -> false, ([], p) + | goal::tl -> + let res = apply_to_goal_conj env theorems active goal in + match res with + | `Ok newgoals -> true, ([newgoals], []) + | `No _ -> aux p tl + | `GoOn newgoals -> aux (newgoals @ p) tl + in + let ok, (a, p) = aux p_goals a_goals in + if ok then + ok, (a, p) + else + let p_goals = + List.stable_sort + (fun (d1, l1) (d2, l2) -> + let r = d2 - d1 in + if r <> 0 then r + else let r = (List.length l1) - (List.length l2) in + if r <> 0 then r + else + let res = ref 0 in + let _ = + List.exists2 + (fun (_, _, t1) (_, _, t2) -> + let r = Pervasives.compare t1 t2 in + if r <> 0 then (res := r; true) else false) l1 l2 + in !res) + p + in + ok, (a_goals, p_goals) +;; + + +(* given-clause algorithm with lazy reduction strategy *) +let rec given_clause dbd env goals theorems passive active = + let goals = simplify_goals env goals active in + let ok, goals = activate_goal goals in + (* let theorems = simplify_theorems env theorems active in *) + if ok then + let ok, goals = apply_goal_to_theorems dbd env theorems active goals in + if ok then + let proof = + match (fst goals) with + | (_, [proof, _, _])::_ -> Some proof + | _ -> assert false + in + ParamodulationSuccess (proof, env) + else + given_clause_aux dbd env goals theorems passive active + else +(* let ok', theorems = activate_theorem theorems in *) + let ok', theorems = false, theorems in + if ok' then + let ok, goals = apply_theorem_to_goals env theorems active goals in + if ok then + let proof = + match (fst goals) with + | (_, [proof, _, _])::_ -> Some proof + | _ -> assert false + in + ParamodulationSuccess (proof, env) + else + given_clause_aux dbd env goals theorems passive active + else + if (passive_is_empty passive) then ParamodulationFailure + else given_clause_aux dbd env goals theorems passive active + +and given_clause_aux dbd env goals theorems passive active = + let time1 = Unix.gettimeofday () in + + let selection_estimate = get_selection_estimate () in + let kept = size_of_passive passive in + let passive = + if !time_limit = 0. || !processed_clauses = 0 then + passive + else if !elapsed_time > !time_limit then ( + debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time)); + make_passive [] [] + ) else if kept > selection_estimate then ( + debug_print + (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ + "(kept: %d, selection_estimate: %d)\n") + kept selection_estimate)); + prune_passive selection_estimate active passive + ) else + passive + in + + let time2 = Unix.gettimeofday () in + passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); + + kept_clauses := (size_of_passive passive) + (size_of_active active); + match passive_is_empty passive with + | true -> (* ParamodulationFailure *) + given_clause dbd env goals theorems passive active + | false -> + let (sign, current), passive = select env (fst goals) passive active in + let time1 = Unix.gettimeofday () in + let res = forward_simplify env (sign, current) ~passive active in + let time2 = Unix.gettimeofday () in + forward_simpl_time := !forward_simpl_time +. (time2 -. time1); + match res with + | None -> + given_clause dbd env goals theorems passive active + | Some (sign, current) -> + if (sign = Negative) && (is_identity env current) then ( + debug_print + (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) + (string_of_equality ~env current))); + let _, proof, _, _, _ = current in + ParamodulationSuccess (Some proof, env) + ) else ( + debug_print + (lazy "\n================================================"); + debug_print (lazy (Printf.sprintf "selected: %s %s" + (string_of_sign sign) + (string_of_equality ~env current))); + + let t1 = Unix.gettimeofday () in + let new' = infer env sign current active in + let t2 = Unix.gettimeofday () in + infer_time := !infer_time +. (t2 -. t1); + + let res, goal' = contains_empty env new' in + if res then + let proof = + match goal' with + | Some goal -> let _, proof, _, _, _ = goal in Some proof + | None -> None + in + ParamodulationSuccess (proof, env) + else + let t1 = Unix.gettimeofday () in + let new' = forward_simplify_new env new' active in + let t2 = Unix.gettimeofday () in + let _ = + forward_simpl_new_time := + !forward_simpl_new_time +. (t2 -. t1) + in + let active = + match sign with + | Negative -> active + | Positive -> + let t1 = Unix.gettimeofday () in + let active, _, newa, _ = + backward_simplify env ([], [current]) active + in + let t2 = Unix.gettimeofday () in + backward_simpl_time := + !backward_simpl_time +. (t2 -. t1); + match newa with + | None -> active + | Some (n, p) -> + let al, tbl = active in + let nn = List.map (fun e -> Negative, e) n in + let pp, tbl = + List.fold_right + (fun e (l, t) -> + (Positive, e)::l, + Indexing.index tbl e) + p ([], tbl) + in + nn @ al @ pp, tbl + in + match contains_empty env new' with + | false, _ -> + let active = + let al, tbl = active in + match sign with + | Negative -> (sign, current)::al, tbl + | Positive -> + al @ [(sign, current)], Indexing.index tbl current + in + let passive = add_to_passive passive new' in + given_clause dbd env goals theorems passive active + | true, goal -> + let proof = + match goal with + | Some goal -> + let _, proof, _, _, _ = goal in Some proof + | None -> None + in + ParamodulationSuccess (proof, env) + ) +;; + + +(** given-clause algorithm with full reduction strategy *) +let rec given_clause_fullred dbd env goals theorems passive active = + let goals = simplify_goals env goals ~passive active in + let ok, goals = activate_goal goals in +(* let theorems = simplify_theorems env theorems ~passive active in *) + if ok then +(* let _ = *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "\ngoals = \nactive\n%s\npassive\n%s\n" *) +(* (print_goals (fst goals)) (print_goals (snd goals)))); *) +(* let current = List.hd (fst goals) in *) +(* let p, _, t = List.hd (snd current) in *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "goal activated:\n%s\n%s\n" *) +(* (CicPp.ppterm t) (string_of_proof p))); *) +(* in *) + let ok, goals = + apply_goal_to_theorems dbd env theorems ~passive active goals + in + if ok then + let proof = + match (fst goals) with + | (_, [proof, _, _])::_ -> Some proof + | _ -> assert false + in + ParamodulationSuccess (proof, env) + else + given_clause_fullred_aux dbd env goals theorems passive active + else +(* let ok', theorems = activate_theorem theorems in *) +(* if ok' then *) +(* let ok, goals = apply_theorem_to_goals env theorems active goals in *) +(* if ok then *) +(* let proof = *) +(* match (fst goals) with *) +(* | (_, [proof, _, _])::_ -> Some proof *) +(* | _ -> assert false *) +(* in *) +(* ParamodulationSuccess (proof, env) *) +(* else *) +(* given_clause_fullred_aux env goals theorems passive active *) +(* else *) + if (passive_is_empty passive) then ParamodulationFailure + else given_clause_fullred_aux dbd env goals theorems passive active + +and given_clause_fullred_aux dbd env goals theorems passive active = + let time1 = Unix.gettimeofday () in + + let selection_estimate = get_selection_estimate () in + let kept = size_of_passive passive in + let passive = + if !time_limit = 0. || !processed_clauses = 0 then + passive + else if !elapsed_time > !time_limit then ( + debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time)); + make_passive [] [] + ) else if kept > selection_estimate then ( + debug_print + (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ + "(kept: %d, selection_estimate: %d)\n") + kept selection_estimate)); + prune_passive selection_estimate active passive + ) else + passive + in + + let time2 = Unix.gettimeofday () in + passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); + + kept_clauses := (size_of_passive passive) + (size_of_active active); + match passive_is_empty passive with + | true -> (* ParamodulationFailure *) + given_clause_fullred dbd env goals theorems passive active + | false -> + let (sign, current), passive = select env (fst goals) passive active in + let time1 = Unix.gettimeofday () in + let res = forward_simplify env (sign, current) ~passive active in + let time2 = Unix.gettimeofday () in + forward_simpl_time := !forward_simpl_time +. (time2 -. time1); + match res with + | None -> + given_clause_fullred dbd env goals theorems passive active + | Some (sign, current) -> + if (sign = Negative) && (is_identity env current) then ( + debug_print + (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) + (string_of_equality ~env current))); + let _, proof, _, _, _ = current in + ParamodulationSuccess (Some proof, env) + ) else ( + debug_print + (lazy "\n================================================"); + debug_print (lazy (Printf.sprintf "selected: %s %s" + (string_of_sign sign) + (string_of_equality ~env current))); + + let t1 = Unix.gettimeofday () in + let new' = infer env sign current active in + let t2 = Unix.gettimeofday () in + infer_time := !infer_time +. (t2 -. t1); + + let active = + if is_identity env current then active + else + let al, tbl = active in + match sign with + | Negative -> (sign, current)::al, tbl + | Positive -> + al @ [(sign, current)], Indexing.index tbl current + in + let rec simplify new' active passive = + let t1 = Unix.gettimeofday () in + let new' = forward_simplify_new env new' ~passive active in + let t2 = Unix.gettimeofday () in + forward_simpl_new_time := + !forward_simpl_new_time +. (t2 -. t1); + let t1 = Unix.gettimeofday () in + let active, passive, newa, retained = + backward_simplify env new' ~passive active in + let t2 = Unix.gettimeofday () in + backward_simpl_time := !backward_simpl_time +. (t2 -. t1); + match newa, retained with + | None, None -> active, passive, new' + | Some (n, p), None + | None, Some (n, p) -> + let nn, np = new' in + simplify (nn @ n, np @ p) active passive + | Some (n, p), Some (rn, rp) -> + let nn, np = new' in + simplify (nn @ n @ rn, np @ p @ rp) active passive + in + let active, passive, new' = simplify new' active passive in + + let k = size_of_passive passive in + if k < (kept - 1) then + processed_clauses := !processed_clauses + (kept - 1 - k); + + let _ = + debug_print + (lazy + (Printf.sprintf "active:\n%s\n" + (String.concat "\n" + ((List.map + (fun (s, e) -> (string_of_sign s) ^ " " ^ + (string_of_equality ~env e)) + (fst active)))))) + in + let _ = + match new' with + | neg, pos -> + debug_print + (lazy + (Printf.sprintf "new':\n%s\n" + (String.concat "\n" + ((List.map + (fun e -> "Negative " ^ + (string_of_equality ~env e)) neg) @ + (List.map + (fun e -> "Positive " ^ + (string_of_equality ~env e)) pos))))) + in + match contains_empty env new' with + | false, _ -> + let passive = add_to_passive passive new' in + given_clause_fullred dbd env goals theorems passive active + | true, goal -> + let proof = + match goal with + | Some goal -> let _, proof, _, _, _ = goal in Some proof + | None -> None + in + ParamodulationSuccess (proof, env) + ) +;; + + +let rec saturate_equations env goal accept_fun passive active = + elapsed_time := Unix.gettimeofday () -. !start_time; + if !elapsed_time > !time_limit then + (active, passive) + else + let (sign, current), passive = select env [1, [goal]] passive active in + let res = forward_simplify env (sign, current) ~passive active in + match res with + | None -> + saturate_equations env goal accept_fun passive active + | Some (sign, current) -> + assert (sign = Positive); + debug_print + (lazy "\n================================================"); + debug_print (lazy (Printf.sprintf "selected: %s %s" + (string_of_sign sign) + (string_of_equality ~env current))); + let new' = infer env sign current active in + let active = + if is_identity env current then active + else + let al, tbl = active in + al @ [(sign, current)], Indexing.index tbl current + in + let rec simplify new' active passive = + let new' = forward_simplify_new env new' ~passive active in + let active, passive, newa, retained = + backward_simplify env new' ~passive active in + match newa, retained with + | None, None -> active, passive, new' + | Some (n, p), None + | None, Some (n, p) -> + let nn, np = new' in + simplify (nn @ n, np @ p) active passive + | Some (n, p), Some (rn, rp) -> + let nn, np = new' in + simplify (nn @ n @ rn, np @ p @ rp) active passive + in + let active, passive, new' = simplify new' active passive in + let _ = + debug_print + (lazy + (Printf.sprintf "active:\n%s\n" + (String.concat "\n" + ((List.map + (fun (s, e) -> (string_of_sign s) ^ " " ^ + (string_of_equality ~env e)) + (fst active)))))) + in + let _ = + match new' with + | neg, pos -> + debug_print + (lazy + (Printf.sprintf "new':\n%s\n" + (String.concat "\n" + ((List.map + (fun e -> "Negative " ^ + (string_of_equality ~env e)) neg) @ + (List.map + (fun e -> "Positive " ^ + (string_of_equality ~env e)) pos))))) + in + let new' = match new' with _, pos -> [], List.filter accept_fun pos in + let passive = add_to_passive passive new' in + saturate_equations env goal accept_fun passive active +;; + + + + +let main dbd full term metasenv ugraph = + let module C = Cic in + let module T = CicTypeChecker in + let module PET = ProofEngineTypes in + let module PP = CicPp in + let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in + let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in + let proof, goals = status in + let goal' = List.nth goals 0 in + let _, metasenv, meta_proof, _ = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let eq_indexes, equalities, maxm = find_equalities context proof in + let lib_eq_uris, library_equalities, maxm = + + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let library_equalities = List.map snd library_equalities in + maxmeta := maxm+2; (* TODO ugly!! *) + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + let new_meta_goal, metasenv, type_of_goal = + let _, context, ty = CicUtil.lookup_meta goal' metasenv in + debug_print + (lazy + (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n\n" (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let env = (metasenv, context, ugraph) in + let t1 = Unix.gettimeofday () in + let theorems = + if full then + let theorems = find_library_theorems dbd env (proof, goal') lib_eq_uris in + let context_hyp = find_context_hypotheses env eq_indexes in + context_hyp @ theorems, [] + else + let refl_equal = + let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") + in + let t = CicUtil.term_of_uri refl_equal in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + [(t, ty, [])], [] + in + let t2 = Unix.gettimeofday () in + debug_print + (lazy + (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); + let _ = + debug_print + (lazy + (Printf.sprintf + "Theorems:\n-------------------------------------\n%s\n" + (String.concat "\n" + (List.map + (fun (t, ty, _) -> + Printf.sprintf + "Term: %s, type: %s" (CicPp.ppterm t) (CicPp.ppterm ty)) + (fst theorems))))) + in + (*try*) + let goal = Inference.BasicProof new_meta_goal, [], goal in + let equalities = simplify_equalities env (equalities@library_equalities) in + let active = make_active () in + let passive = make_passive [] equalities in + Printf.printf "\ncurrent goal: %s\n" + (let _, _, g = goal in CicPp.ppterm g); + Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); + Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); + Printf.printf "\nequalities:\n%s\n" + (String.concat "\n" + (List.map + (string_of_equality ~env) equalities)); +(* (equalities @ library_equalities))); *) + print_endline "--------------------------------------------------"; + let start = Unix.gettimeofday () in + print_endline "GO!"; + start_time := Unix.gettimeofday (); + let res = + let goals = make_goals goal in + (if !use_fullred then given_clause_fullred else given_clause) + dbd env goals theorems passive active + in + let finish = Unix.gettimeofday () in + let _ = + match res with + | ParamodulationFailure -> + Printf.printf "NO proof found! :-(\n\n" + | ParamodulationSuccess (Some proof, env) -> + let proof = Inference.build_proof_term proof in + Printf.printf "OK, found a proof!\n"; + (* REMEMBER: we have to instantiate meta_proof, we should use + apply the "apply" tactic to proof and status + *) + let names = names_of_context context in + print_endline (PP.pp proof names); + let newmetasenv = + List.fold_left + (fun m (_, _, _, menv, _) -> m @ menv) metasenv equalities + in + let _ = + (*try*) + let ty, ug = + CicTypeChecker.type_of_aux' newmetasenv context proof ugraph + in + print_endline (string_of_float (finish -. start)); + Printf.printf + "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n\n" + (CicPp.pp type_of_goal names) (CicPp.pp ty names) + (string_of_bool + (fst (CicReduction.are_convertible + context type_of_goal ty ug))); + (*with e -> + Printf.printf "\nEXCEPTION!!! %s\n" (Printexc.to_string e); + Printf.printf "MAXMETA USED: %d\n" !maxmeta; + print_endline (string_of_float (finish -. start));*) + in + () + + | ParamodulationSuccess (None, env) -> + Printf.printf "Success, but no proof?!?\n\n" + in + Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^ + "forward_simpl_new_time: %.9f\n" ^^ + "backward_simpl_time: %.9f\n") + !infer_time !forward_simpl_time !forward_simpl_new_time + !backward_simpl_time; + Printf.printf "passive_maintainance_time: %.9f\n" + !passive_maintainance_time; + Printf.printf " successful unification/matching time: %.9f\n" + !Indexing.match_unif_time_ok; + Printf.printf " failed unification/matching time: %.9f\n" + !Indexing.match_unif_time_no; + Printf.printf " indexing retrieval time: %.9f\n" + !Indexing.indexing_retrieval_time; + Printf.printf " demodulate_term.build_newtarget_time: %.9f\n" + !Indexing.build_newtarget_time; + Printf.printf "derived %d clauses, kept %d clauses.\n" + !derived_clauses !kept_clauses; +(* + with exc -> + print_endline ("EXCEPTION: " ^ (Printexc.to_string exc)); + raise exc +*) +;; + + +let default_depth = !maxdepth +and default_width = !maxwidth;; + +let reset_refs () = + maxmeta := 0; + symbols_counter := 0; + weight_age_counter := !weight_age_ratio; + processed_clauses := 0; + start_time := 0.; + elapsed_time := 0.; + maximal_retained_equality := None; + infer_time := 0.; + forward_simpl_time := 0.; + forward_simpl_new_time := 0.; + backward_simpl_time := 0.; + passive_maintainance_time := 0.; + derived_clauses := 0; + kept_clauses := 0; +;; + +let saturate + dbd ?(full=false) ?(depth=default_depth) ?(width=default_width) status = + let module C = Cic in + reset_refs (); + Indexing.init_index (); + maxdepth := depth; + maxwidth := width; + let proof, goal = status in + let goal' = goal in + let uri, metasenv, meta_proof, term_to_prove = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let eq_indexes, equalities, maxm = find_equalities context proof in + let new_meta_goal, metasenv, type_of_goal = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + let _, context, ty = CicUtil.lookup_meta goal' metasenv in + debug_print + (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let ugraph = CicUniv.empty_ugraph in + let env = (metasenv, context, ugraph) in + let goal = Inference.BasicProof new_meta_goal, [], goal in + let res, time = + let t1 = Unix.gettimeofday () in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let library_equalities = List.map snd library_equalities in + let t2 = Unix.gettimeofday () in + maxmeta := maxm+2; + let equalities = simplify_equalities env (equalities@library_equalities) in + debug_print + (lazy + (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))); + let t1 = Unix.gettimeofday () in + let theorems = + if full then + let thms = find_library_theorems dbd env (proof, goal') lib_eq_uris in + let context_hyp = find_context_hypotheses env eq_indexes in + context_hyp @ thms, [] + else + let refl_equal = + let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") + in + let t = CicUtil.term_of_uri refl_equal in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + [(t, ty, [])], [] + in + let t2 = Unix.gettimeofday () in + let _ = + debug_print + (lazy + (Printf.sprintf + "Theorems:\n-------------------------------------\n%s\n" + (String.concat "\n" + (List.map + (fun (t, ty, _) -> + Printf.sprintf + "Term: %s, type: %s" + (CicPp.ppterm t) (CicPp.ppterm ty)) + (fst theorems))))); + debug_print + (lazy + (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); + in + let active = make_active () in + let passive = make_passive [] equalities in + let start = Unix.gettimeofday () in + let res = + let goals = make_goals goal in + given_clause_fullred dbd env goals theorems passive active + in + let finish = Unix.gettimeofday () in + (res, finish -. start) + in + match res with + | ParamodulationSuccess (Some proof, env) -> + debug_print (lazy "OK, found a proof!"); + let proof = Inference.build_proof_term proof in + let names = names_of_context context in + let newmetasenv = + let i1 = + match new_meta_goal with + | C.Meta (i, _) -> i | _ -> assert false + in + List.filter (fun (i, _, _) -> i <> i1 && i <> goal') metasenv + in + let newstatus = + try + let ty, ug = + CicTypeChecker.type_of_aux' newmetasenv context proof ugraph + in + debug_print (lazy (CicPp.pp proof [](* names *))); + debug_print + (lazy + (Printf.sprintf + "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n" + (CicPp.pp type_of_goal names) (CicPp.pp ty names) + (string_of_bool + (fst (CicReduction.are_convertible + context type_of_goal ty ug))))); + let equality_for_replace i t1 = + match t1 with + | C.Meta (n, _) -> n = i + | _ -> false + in + let real_proof = + ProofEngineReduction.replace + ~equality:equality_for_replace + ~what:[goal'] ~with_what:[proof] + ~where:meta_proof + in + debug_print + (lazy + (Printf.sprintf "status:\n%s\n%s\n%s\n%s\n" + (match uri with Some uri -> UriManager.string_of_uri uri + | None -> "") + (print_metasenv newmetasenv) + (CicPp.pp real_proof [](* names *)) + (CicPp.pp term_to_prove names))); + ((uri, newmetasenv, real_proof, term_to_prove), []) + with CicTypeChecker.TypeCheckerFailure _ -> + debug_print (lazy "THE PROOF DOESN'T TYPECHECK!!!"); + debug_print (lazy (CicPp.pp proof names)); + raise (ProofEngineTypes.Fail + (lazy "Found a proof, but it doesn't typecheck")) + in + let tall = fs_time_info.build_all in + let tdemodulate = fs_time_info.demodulate in + let tsubsumption = fs_time_info.subsumption in + debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time)); + debug_print (lazy (Printf.sprintf "\ntall: %.9f" tall)); + debug_print (lazy (Printf.sprintf "\ntdemod: %.9f" tdemodulate)); + debug_print (lazy (Printf.sprintf "\ntsubsumption: %.9f" tsubsumption)); + debug_print (lazy (Printf.sprintf "\ninfer_time: %.9f" !infer_time)); + debug_print (lazy (Printf.sprintf "\nforward_simpl_times: %.9f" !forward_simpl_time)); + debug_print (lazy (Printf.sprintf "\nforward_simpl_new_times: %.9f" !forward_simpl_new_time)); + debug_print (lazy (Printf.sprintf "\nbackward_simpl_times: %.9f" !backward_simpl_time)); + debug_print (lazy (Printf.sprintf "\npassive_maintainance_time: %.9f" !passive_maintainance_time)); + newstatus + | _ -> + raise (ProofEngineTypes.Fail (lazy "NO proof found")) +;; + +(* dummy function called within matita to trigger linkage *) +let init () = ();; + + +let retrieve_and_print dbd term metasenv ugraph = + let module C = Cic in + let module T = CicTypeChecker in + let module PET = ProofEngineTypes in + let module PP = CicPp in + let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in + let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in + let proof, goals = status in + let goal' = List.nth goals 0 in + let uri, metasenv, meta_proof, term_to_prove = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let eq_indexes, equalities, maxm = find_equalities context proof in + let new_meta_goal, metasenv, type_of_goal = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + let _, context, ty = CicUtil.lookup_meta goal' metasenv in + debug_print + (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let ugraph = CicUniv.empty_ugraph in + let env = (metasenv, context, ugraph) in + let t1 = Unix.gettimeofday () in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) in + let t2 = Unix.gettimeofday () in + maxmeta := maxm+2; + let equalities = (* equalities @ *) library_equalities in + debug_print + (lazy + (Printf.sprintf "\n\nequalities:\n%s\n" + (String.concat "\n" + (List.map + (fun (u, e) -> +(* Printf.sprintf "%s: %s" *) + (UriManager.string_of_uri u) +(* (string_of_equality e) *) + ) + equalities)))); + debug_print (lazy "SIMPLYFYING EQUALITIES..."); + let rec simpl e others others_simpl = + let (u, e) = e in + let active = List.map (fun (u, e) -> (Positive, e)) + (others @ others_simpl) in + let tbl = + List.fold_left + (fun t (_, e) -> Indexing.index t e) + Indexing.empty active + in + let res = forward_simplify env (Positive, e) (active, tbl) in + match others with + | hd::tl -> ( + match res with + | None -> simpl hd tl others_simpl + | Some e -> simpl hd tl ((u, (snd e))::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> (u, (snd e))::others_simpl + ) + in + let _equalities = + match equalities with + | [] -> [] + | hd::tl -> + let others = tl in (* List.map (fun e -> (Positive, e)) tl in *) + let res = + List.rev (simpl (*(Positive,*) hd others []) + in + debug_print + (lazy + (Printf.sprintf "\nequalities AFTER:\n%s\n" + (String.concat "\n" + (List.map + (fun (u, e) -> + Printf.sprintf "%s: %s" + (UriManager.string_of_uri u) + (string_of_equality e) + ) + res)))); + res in + debug_print + (lazy + (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))) +;; + + +let main_demod_equalities dbd term metasenv ugraph = + let module C = Cic in + let module T = CicTypeChecker in + let module PET = ProofEngineTypes in + let module PP = CicPp in + let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in + let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in + let proof, goals = status in + let goal' = List.nth goals 0 in + let _, metasenv, meta_proof, _ = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let eq_indexes, equalities, maxm = find_equalities context proof in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let library_equalities = List.map snd library_equalities in + maxmeta := maxm+2; (* TODO ugly!! *) + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + let new_meta_goal, metasenv, type_of_goal = + let _, context, ty = CicUtil.lookup_meta goal' metasenv in + debug_print + (lazy + (Printf.sprintf "\n\nTRYING TO INFER EQUALITIES MATCHING: %s\n\n" + (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let env = (metasenv, context, ugraph) in + (*try*) + let goal = Inference.BasicProof new_meta_goal, [], goal in + let equalities = simplify_equalities env (equalities@library_equalities) in + let active = make_active () in + let passive = make_passive [] equalities in + Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); + Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); + Printf.printf "\nequalities:\n%s\n" + (String.concat "\n" + (List.map + (string_of_equality ~env) equalities)); + print_endline "--------------------------------------------------"; + print_endline "GO!"; + start_time := Unix.gettimeofday (); + if !time_limit < 1. then time_limit := 60.; + let ra, rp = + saturate_equations env goal (fun e -> true) passive active + in + + let initial = + List.fold_left (fun s e -> EqualitySet.add e s) + EqualitySet.empty equalities + in + let addfun s e = + if not (EqualitySet.mem e initial) then EqualitySet.add e s else s + in + + let passive = + match rp with + | (n, _), (p, _), _ -> + EqualitySet.elements (List.fold_left addfun EqualitySet.empty p) + in + let active = + let l = List.map snd (fst ra) in + EqualitySet.elements (List.fold_left addfun EqualitySet.empty l) + in + Printf.printf "\n\nRESULTS:\nActive:\n%s\n\nPassive:\n%s\n" + (String.concat "\n" (List.map (string_of_equality ~env) active)) + (* (String.concat "\n" + (List.map (fun e -> CicPp.ppterm (term_of_equality e)) active)) *) +(* (String.concat "\n" (List.map (string_of_equality ~env) passive)); *) + (String.concat "\n" + (List.map (fun e -> CicPp.ppterm (term_of_equality e)) passive)); + print_newline (); +(* + with e -> + debug_print (lazy ("EXCEPTION: " ^ (Printexc.to_string e))) +*) +;; + +let demodulate_tac ~dbd ~pattern ((proof,goal) as initialstatus) = + let module I = Inference in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let eq_indexes, equalities, maxm = I.find_equalities context proof in + let lib_eq_uris, library_equalities, maxm = + I.find_library_equalities dbd context (proof, goal) (maxm+2) in + if library_equalities = [] then prerr_endline "VUOTA!!!"; + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + let library_equalities = List.map snd library_equalities in + let goalterm = Cic.Meta (metano,irl) in + let initgoal = Inference.BasicProof goalterm, [], ty in + let env = (metasenv, context, CicUniv.empty_ugraph) in + let equalities = simplify_equalities env (equalities@library_equalities) in + let table = + List.fold_left + (fun tbl eq -> Indexing.index tbl eq) + Indexing.empty equalities + in + let newmeta,(newproof,newmetasenv, newty) = Indexing.demodulation_goal + maxm (metasenv,context,CicUniv.empty_ugraph) table initgoal + in + if newmeta != maxm then + begin + let opengoal = Cic.Meta(maxm,irl) in + let proofterm = + Inference.build_proof_term ~noproof:opengoal newproof in + let extended_metasenv = (maxm,context,newty)::metasenv in + let extended_status = + (curi,extended_metasenv,pbo,pty),goal in + let (status,newgoals) = + ProofEngineTypes.apply_tactic + (PrimitiveTactics.apply_tac ~term:proofterm) + extended_status in + (status,maxm::newgoals) + end + else if newty = ty then + raise (ProofEngineTypes.Fail (lazy "no progress")) + else ProofEngineTypes.apply_tactic + (ReductionTactics.simpl_tac ~pattern) + initialstatus +;; + +let demodulate_tac ~dbd ~pattern = + ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~pattern) +;; diff --git a/helm/software/components/tactics/paramodulation/saturation.mli b/helm/software/components/tactics/paramodulation/saturation.mli new file mode 100644 index 000000000..34159810d --- /dev/null +++ b/helm/software/components/tactics/paramodulation/saturation.mli @@ -0,0 +1,52 @@ +(* Copyright (C) 2006, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +val saturate : + HMysql.dbd -> + ?full:bool -> + ?depth:int -> + ?width:int -> + ProofEngineTypes.proof * ProofEngineTypes.goal -> + (UriManager.uri option * Cic.conjecture list * Cic.term * Cic.term) * + 'a list + +val weight_age_ratio : int ref +val weight_age_counter: int ref +val symbols_ratio: int ref +val symbols_counter: int ref +val use_fullred: bool ref +val time_limit: float ref +val maxwidth: int ref +val maxdepth: int ref +val retrieve_and_print: HMysql.dbd -> Cic.term -> Cic.conjecture list -> 'a -> unit +val main_demod_equalities: HMysql.dbd -> + Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit +val main: HMysql.dbd -> + bool -> Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit +val demodulate_tac: + dbd:HMysql.dbd -> + pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/paramodulation/test_indexing.ml b/helm/software/components/tactics/paramodulation/test_indexing.ml new file mode 100644 index 000000000..ba6b2ebe0 --- /dev/null +++ b/helm/software/components/tactics/paramodulation/test_indexing.ml @@ -0,0 +1,253 @@ +(* $Id$ *) + +open Path_indexing + +(* +let build_equality term = + let module C = Cic in + C.Implicit None, (C.Implicit None, term, C.Rel 1, Utils.Gt), [], [] +;; + + +(* + f = Rel 1 + g = Rel 2 + a = Rel 3 + b = Rel 4 + c = Rel 5 +*) +let path_indexing_test () = + let module C = Cic in + let terms = [ + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; + C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])] + ] in + let path_strings = List.map (path_strings_of_term 0) terms in + let table = + List.fold_left index PSTrie.empty (List.map build_equality terms) in + let query = + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in + let matches = retrieve_generalizations table query in + let unifications = retrieve_unifiables table query in + let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) + and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in + let res1 = in_index table eq1 + and res2 = in_index table eq2 in + let print_results res = + String.concat "\n" + (PosEqSet.fold + (fun (p, e) l -> + let s = + "(" ^ (Utils.string_of_pos p) ^ ", " ^ + (Inference.string_of_equality e) ^ ")" + in + s::l) + res []) + in + Printf.printf "path_strings:\n%s\n\n" + (String.concat "\n" + (List.map + (fun l -> + "{" ^ (String.concat "; " (List.map string_of_path_string l)) ^ "}" + ) path_strings)); + Printf.printf "table:\n%s\n\n" (string_of_pstrie table); + Printf.printf "matches:\n%s\n\n" (print_results matches); + Printf.printf "unifications:\n%s\n\n" (print_results unifications); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq1) (string_of_bool res1); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq2) (string_of_bool res2); +;; + + +let differing () = + let module C = Cic in + let t1 = + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5] + and t2 = + C.Appl [C.Rel 1; C.Appl [C.Rel 5; C.Rel 4; C.Meta (1, [])]; C.Rel 5] + in + let res = Inference.extract_differing_subterms t1 t2 in + match res with + | None -> print_endline "NO DIFFERING SUBTERMS???" + | Some (t1, t2) -> + Printf.printf "OK: %s, %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); +;; + + +let next_after () = + let module C = Cic in + let t = + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5] + in + let pos1 = Discrimination_tree.next_t [1] t in + let pos2 = Discrimination_tree.after_t [1] t in + Printf.printf "next_t 1: %s\nafter_t 1: %s\n" + (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos1 t)) + (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos2 t)); +;; + + +let discrimination_tree_test () = + let module C = Cic in + let terms = [ + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; + C.Appl [C.Rel 10; C.Meta (5, []); C.Rel 11] + ] in + let path_strings = + List.map Discrimination_tree.path_string_of_term terms in + let table = + List.fold_left + Discrimination_tree.index + Discrimination_tree.DiscriminationTree.empty + (List.map build_equality terms) + in +(* let query = *) +(* C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in *) + let query = C.Appl [C.Rel 10; C.Meta (14, []); C.Meta (13, [])] in + let matches = Discrimination_tree.retrieve_generalizations table query in + let unifications = Discrimination_tree.retrieve_unifiables table query in + let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) + and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in + let res1 = Discrimination_tree.in_index table eq1 + and res2 = Discrimination_tree.in_index table eq2 in + let print_results res = + String.concat "\n" + (Discrimination_tree.PosEqSet.fold + (fun (p, e) l -> + let s = + "(" ^ (Utils.string_of_pos p) ^ ", " ^ + (Inference.string_of_equality e) ^ ")" + in + s::l) + res []) + in + Printf.printf "path_strings:\n%s\n\n" + (String.concat "\n" + (List.map Discrimination_tree.string_of_path_string path_strings)); + Printf.printf "table:\n%s\n\n" + (Discrimination_tree.string_of_discrimination_tree table); + Printf.printf "matches:\n%s\n\n" (print_results matches); + Printf.printf "unifications:\n%s\n\n" (print_results unifications); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq1) (string_of_bool res1); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq2) (string_of_bool res2); +;; + + +let test_subst () = + let module C = Cic in + let module M = CicMetaSubst in + let term = C.Appl [ + C.Rel 1; + C.Appl [C.Rel 11; + C.Meta (43, []); + C.Appl [C.Rel 15; C.Rel 12; C.Meta (41, [])]]; + C.Appl [C.Rel 11; + C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])]; + C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (12, [])]] + ] in + let subst1 = [ + (43, ([], C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])], C.Rel 16)); + (10, ([], C.Rel 12, C.Rel 16)); + (12, ([], C.Meta (41, []), C.Rel 16)) + ] + and subst2 = [ + (43, ([], C.Appl [C.Rel 15; C.Rel 12; C.Meta (11, [])], C.Rel 16)); + (10, ([], C.Rel 12, C.Rel 16)); + (12, ([], C.Meta (41, []), C.Rel 16)) + ] in + let t1 = M.apply_subst subst1 term + and t2 = M.apply_subst subst2 term in + Printf.printf "t1 = %s\nt2 = %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); +;; +*) + + +let test_refl () = + let module C = Cic in + let context = [ + Some (C.Name "H", C.Decl ( + C.Prod (C.Name "z", C.Rel 3, + C.Appl [ + C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); + C.Rel 4; C.Rel 3; C.Rel 1]))); + Some (C.Name "x", C.Decl (C.Rel 2)); + Some (C.Name "y", C.Decl (C.Rel 1)); + Some (C.Name "A", C.Decl (C.Sort C.Set)) + ] + in + let term = C.Appl [ + C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); C.Rel 4; + C.Rel 2; + C.Lambda (C.Name "z", C.Rel 4, + C.Appl [ + C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); + C.Rel 5; C.Rel 1; C.Rel 3 + ]); + C.Appl [C.MutConstruct + (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); (* reflexivity *) + C.Rel 4; C.Rel 2]; + C.Rel 3; +(* C.Appl [C.Const (HelmLibraryObjects.Logic.sym_eq_URI, []); (\* symmetry *\) *) +(* C.Rel 4; C.Appl [C.Rel 1; C.Rel 2]] *) + C.Appl [ + C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); + C.Rel 4; C.Rel 3; + C.Lambda (C.Name "z", C.Rel 4, + C.Appl [ + C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); + C.Rel 5; C.Rel 1; C.Rel 4 + ]); + C.Appl [C.MutConstruct (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); + C.Rel 4; C.Rel 3]; + C.Rel 2; C.Appl [C.Rel 1; C.Rel 2] + ] + ] in + let ens = [ + (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var", + C.Rel 4); + (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var", + C.Rel 3); + (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var", + C.Rel 2); + ] in + let term2 = C.Appl [ + C.Const (HelmLibraryObjects.Logic.sym_eq_URI, ens); + C.Appl [C.Rel 1; C.Rel 2] + ] in + let ty, ug = + CicTypeChecker.type_of_aux' [] context term CicUniv.empty_ugraph + in + Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term) (CicPp.ppterm ty); + let ty, ug = + CicTypeChecker.type_of_aux' [] context term2 CicUniv.empty_ugraph + in + Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term2) (CicPp.ppterm ty); +;; + + +let test_lib () = + let uri = Sys.argv.(1) in + let t = CicUtil.term_of_uri (UriManager.uri_of_string uri) in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + Printf.printf "Term of %s: %s\n" uri (CicPp.ppterm t); + Printf.printf "type: %s\n" (CicPp.ppterm ty); +;; + + +(* differing ();; *) +(* next_after ();; *) +(* discrimination_tree_test ();; *) +(* path_indexing_test ();; *) +(* test_subst ();; *) +Helm_registry.load_from "../../matita/matita.conf.xml"; +(* test_refl ();; *) +test_lib ();; diff --git a/helm/software/components/tactics/paramodulation/utils.ml b/helm/software/components/tactics/paramodulation/utils.ml new file mode 100644 index 000000000..b212d0fab --- /dev/null +++ b/helm/software/components/tactics/paramodulation/utils.ml @@ -0,0 +1,707 @@ +(* Copyright (C) 2005, 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/. + *) + +(* $Id$ *) + +let debug = true;; + +let debug_print s = if debug then prerr_endline (Lazy.force s);; + +let print_metasenv metasenv = + String.concat "\n--------------------------\n" + (List.map (fun (i, context, term) -> + (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^ + "\n] " ^ (CicPp.ppterm term)) + metasenv) +;; + + + + +let print_subst ?(prefix="\n") subst = + String.concat prefix + (List.map + (fun (i, (c, t, ty)) -> + Printf.sprintf "?%d -> %s : %s" i + (CicPp.ppterm t) (CicPp.ppterm ty)) + subst) +;; + +type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; + +let string_of_comparison = function + | Lt -> "<" + | Le -> "<=" + | Gt -> ">" + | Ge -> ">=" + | Eq -> "=" + | Incomparable -> "I" + +module OrderedTerm = +struct + type t = Cic.term + + let compare = Pervasives.compare +end + +module TermSet = Set.Make(OrderedTerm);; +module TermMap = Map.Make(OrderedTerm);; + +let symbols_of_term term = + let module C = Cic in + let rec aux map = function + | C.Meta _ -> map + | C.Appl l -> + List.fold_left (fun res t -> (aux res t)) map l + | t -> + let map = + try + let c = TermMap.find t map in + TermMap.add t (c+1) map + with Not_found -> + TermMap.add t 1 map + in + map + in + aux TermMap.empty term +;; + + +let metas_of_term term = + let module C = Cic in + let rec aux = function + | C.Meta _ as t -> TermSet.singleton t + | C.Appl l -> + List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l + | t -> TermSet.empty (* TODO: maybe add other cases? *) + in + aux term +;; + + +(************************* rpo ********************************) +let number = [ + UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)",3; + UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)",6; + UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)",9; + HelmLibraryObjects.Peano.pred_URI, 12; + HelmLibraryObjects.Peano.plus_URI, 15; + HelmLibraryObjects.Peano.minus_URI, 18; + HelmLibraryObjects.Peano.mult_URI, 21; + UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1)",103; + UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/1)",106; + UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/2)",109; + UriManager.uri_of_string "cic:/matita/nat/nat/pred.con",112; + UriManager.uri_of_string "cic:/matita/nat/plus/plus.con",115; + UriManager.uri_of_string "cic:/matita/nat/minus/minus.con",118; + UriManager.uri_of_string "cic:/matita/nat/times/times.con",121; + ] +;; + +let atomic t = + match t with + Cic.Const _ + | Cic.MutInd _ + | Cic.MutConstruct _ + | Cic.Rel _ -> true + | _ -> false + +let sig_order_const t1 t2 = + try + let u1 = CicUtil.uri_of_term t1 in + let u2 = CicUtil.uri_of_term t2 in + let n1 = List.assoc u1 number in + let n2 = List.assoc u2 number in + if n1 < n2 then Lt + else if n1 > n2 then Gt + else + begin + prerr_endline ("t1 = "^(CicPp.ppterm t1)); + prerr_endline ("t2 = "^(CicPp.ppterm t2)); + assert false + end + with + Invalid_argument _ + | Not_found -> Incomparable + +let sig_order t1 t2 = + match t1, t2 with + Cic.Rel n, Cic.Rel m when n < m -> Gt (* inverted order *) + | Cic.Rel n, Cic.Rel m when n = m -> Incomparable + | Cic.Rel n, Cic.Rel m when n > m -> Lt + | Cic.Rel _, _ -> Gt + | _, Cic.Rel _ -> Lt + | _,_ -> sig_order_const t1 t2 + +let rec rpo_lt t1 t2 = + let module C = Cic in + let first_trie = + match t1,t2 with + C.Meta (_, _), C.Meta (_,_) -> false + | C.Meta (_,_) , t2 -> TermSet.mem t1 (metas_of_term t2) + | t1, C.Meta (_,_) -> false + | C.Appl [h1;a1],C.Appl [h2;a2] when h1=h2 -> + rpo_lt a1 a2 + | C.Appl (h1::arg1),C.Appl (h2::arg2) when h1=h2 -> + if lex_lt arg1 arg2 then + check_lt arg1 t2 + else false + | C.Appl (h1::arg1),C.Appl (h2::arg2) -> + (match sig_order h1 h2 with + | Lt -> check_lt arg1 t2 + | _ -> false) + | C.Appl (h1::arg1), t2 when atomic t2 -> + (match sig_order h1 t2 with + | Lt -> check_lt arg1 t2 + | _ -> false) + | t1 , C.Appl (h2::arg2) when atomic t1 -> + (match sig_order t1 h2 with + | Lt -> true + | _ -> false ) + | C.Appl [] , _ -> assert false + | _ , C.Appl [] -> assert false + | t1, t2 when (atomic t1 && atomic t2 && t1<>t2) -> + (match sig_order t1 t2 with + | Lt -> true + | _ -> false) + | _,_ -> false + in + if first_trie then true else + match t2 with + C.Appl (_::args) -> + List.exists (fun a -> t1 = a || rpo_lt t1 a) args + | _ -> false + +and lex_lt l1 l2 = + match l1,l2 with + [],[] -> false + | [],_ -> assert false + | _, [] -> assert false + | a1::l1, a2::l2 when a1 = a2 -> lex_lt l1 l2 + | a1::_, a2::_ -> rpo_lt a1 a2 + +and check_lt l t = + List.fold_left + (fun b a -> b && (rpo_lt a t)) + true l +;; + +let rpo t1 t2 = + if rpo_lt t2 t1 then Gt + else if rpo_lt t1 t2 then Lt + else Incomparable + + +(*********************** fine rpo *****************************) + +(* (weight of constants, [(meta, weight_of_meta)]) *) +type weight = int * (int * int) list;; + +let string_of_weight (cw, mw) = + let s = + String.concat ", " + (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw) + in + Printf.sprintf "[%d; %s]" cw s + + +let weight_of_term ?(consider_metas=true) term = + let module C = Cic in + let vars_dict = Hashtbl.create 5 in + let rec aux = function + | C.Meta (metano, _) when consider_metas -> + (try + let oldw = Hashtbl.find vars_dict metano in + Hashtbl.replace vars_dict metano (oldw+1) + with Not_found -> + Hashtbl.add vars_dict metano 1); + 0 + | C.Meta _ -> 0 (* "variables" are lighter than constants and functions...*) + + | C.Var (_, ens) + | C.Const (_, ens) + | C.MutInd (_, _, ens) + | C.MutConstruct (_, _, _, ens) -> + List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens + + | C.Cast (t1, t2) + | C.Lambda (_, t1, t2) + | C.Prod (_, t1, t2) + | C.LetIn (_, t1, t2) -> + let w1 = aux t1 in + let w2 = aux t2 in + w1 + w2 + 1 + + | C.Appl l -> List.fold_left (+) 0 (List.map aux l) + + | C.MutCase (_, _, outt, t, pl) -> + let w1 = aux outt in + let w2 = aux t in + let w3 = List.fold_left (+) 0 (List.map aux pl) in + w1 + w2 + w3 + 1 + + | C.Fix (_, fl) -> + List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl + + | C.CoFix (_, fl) -> + List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl + + | _ -> 1 + in + let w = aux term in + let l = + Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in + let compare w1 w2 = + match w1, w2 with + | (m1, _), (m2, _) -> m2 - m1 + in + (w, List.sort compare l) (* from the biggest meta to the smallest (0) *) +;; + + +module OrderedInt = struct + type t = int + + let compare = Pervasives.compare +end + +module IntSet = Set.Make(OrderedInt) + +let compute_equality_weight ty left right = + let metasw = ref 0 in + let weight_of t = + let w, m = (weight_of_term ~consider_metas:true t) in + metasw := !metasw + (2 * (List.length m)); + w + in + (* Warning: the following let cannot be expanded since it forces the + right evaluation order!!!! *) + let w = (weight_of ty) + (weight_of left) + (weight_of right) in + w + !metasw +;; + + +(* returns a "normalized" version of the polynomial weight wl (with type + * weight list), i.e. a list sorted ascending by meta number, + * from 0 to maxmeta. wl must be sorted descending by meta number. Example: + * normalize_weight 5 (3, [(3, 2); (1, 1)]) -> + * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *) +let normalize_weight maxmeta (cw, wl) = + let rec aux = function + | 0 -> [] + | m -> (m, 0)::(aux (m-1)) + in + let tmpl = aux maxmeta in + let wl = + List.sort + (fun (m, _) (n, _) -> Pervasives.compare m n) + (List.fold_left + (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl) + in + (cw, wl) +;; + + +let normalize_weights (cw1, wl1) (cw2, wl2) = + let rec aux wl1 wl2 = + match wl1, wl2 with + | [], [] -> [], [] + | (m, w)::tl1, (n, w')::tl2 when m = n -> + let res1, res2 = aux tl1 tl2 in + (m, w)::res1, (n, w')::res2 + | (m, w)::tl1, ((n, w')::_ as wl2) when m < n -> + let res1, res2 = aux tl1 wl2 in + (m, w)::res1, (m, 0)::res2 + | ((m, w)::_ as wl1), (n, w')::tl2 when m > n -> + let res1, res2 = aux wl1 tl2 in + (n, 0)::res1, (n, w')::res2 + | [], (n, w)::tl2 -> + let res1, res2 = aux [] tl2 in + (n, 0)::res1, (n, w)::res2 + | (m, w)::tl1, [] -> + let res1, res2 = aux tl1 [] in + (m, w)::res1, (m, 0)::res2 + | _, _ -> assert false + in + let cmp (m, _) (n, _) = compare m n in + let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in + (cw1, wl1), (cw2, wl2) +;; + + +let compare_weights ?(normalize=false) + ((h1, w1) as weight1) ((h2, w2) as weight2)= + let (h1, w1), (h2, w2) = + if normalize then + normalize_weights weight1 weight2 + else + (h1, w1), (h2, w2) + in + let res, diffs = + try + List.fold_left2 + (fun ((lt, eq, gt), diffs) w1 w2 -> + match w1, w2 with + | (meta1, w1), (meta2, w2) when meta1 = meta2 -> + let diffs = (w1 - w2) + diffs in + let r = compare w1 w2 in + if r < 0 then (lt+1, eq, gt), diffs + else if r = 0 then (lt, eq+1, gt), diffs + else (lt, eq, gt+1), diffs + | (meta1, w1), (meta2, w2) -> + debug_print + (lazy + (Printf.sprintf "HMMM!!!! %s, %s\n" + (string_of_weight weight1) (string_of_weight weight2))); + assert false) + ((0, 0, 0), 0) w1 w2 + with Invalid_argument _ -> + debug_print + (lazy + (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n" + (string_of_weight (h1, w1)) (string_of_weight weight1) + (string_of_weight (h2, w2)) (string_of_weight weight2) + (string_of_bool normalize))); + assert false + in + let hdiff = h1 - h2 in + match res with + | (0, _, 0) -> + if hdiff < 0 then Lt + else if hdiff > 0 then Gt + else Eq (* Incomparable *) + | (m, _, 0) -> + if hdiff <= 0 then Lt + else if (- diffs) >= hdiff then Le else Incomparable + | (0, _, m) -> + if hdiff >= 0 then Gt + else if diffs >= (- hdiff) then Ge else Incomparable + | (m, _, n) when m > 0 && n > 0 -> + Incomparable + | _ -> assert false + +;; + + +let rec aux_ordering ?(recursion=true) t1 t2 = + let module C = Cic in + let compare_uris u1 u2 = + let res = + compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in + if res < 0 then Lt + else if res = 0 then Eq + else Gt + in + match t1, t2 with + | C.Meta _, _ + | _, C.Meta _ -> Incomparable + + | t1, t2 when t1 = t2 -> Eq + + | C.Rel n, C.Rel m -> if n > m then Lt else Gt + | C.Rel _, _ -> Lt + | _, C.Rel _ -> Gt + + | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2 + | C.Const _, _ -> Lt + | _, C.Const _ -> Gt + + | C.MutInd (u1, _, _), C.MutInd (u2, _, _) -> compare_uris u1 u2 + | C.MutInd _, _ -> Lt + | _, C.MutInd _ -> Gt + + | C.MutConstruct (u1, _, _, _), C.MutConstruct (u2, _, _, _) -> + compare_uris u1 u2 + | C.MutConstruct _, _ -> Lt + | _, C.MutConstruct _ -> Gt + + | C.Appl l1, C.Appl l2 when recursion -> + let rec cmp t1 t2 = + match t1, t2 with + | [], [] -> Eq + | _, [] -> Gt + | [], _ -> Lt + | hd1::tl1, hd2::tl2 -> + let o = aux_ordering hd1 hd2 in + if o = Eq then cmp tl1 tl2 + else o + in + cmp l1 l2 + | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion -> + aux_ordering h1 h2 + + | t1, t2 -> + debug_print + (lazy + (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n" + (CicPp.ppterm t1) (CicPp.ppterm t2))); + Incomparable +;; + + +(* w1, w2 are the weights, they should already be normalized... *) +let nonrec_kbo_w (t1, w1) (t2, w2) = + match compare_weights w1 w2 with + | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable + | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable + | Eq -> aux_ordering t1 t2 + | res -> res +;; + + +let nonrec_kbo t1 t2 = + let w1 = weight_of_term t1 in + let w2 = weight_of_term t2 in + (* + prerr_endline ("weight1 :"^(string_of_weight w1)); + prerr_endline ("weight2 :"^(string_of_weight w2)); + *) + match compare_weights ~normalize:true w1 w2 with + | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable + | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable + | Eq -> aux_ordering t1 t2 + | res -> res +;; + + +let rec kbo t1 t2 = + let aux = aux_ordering ~recursion:false in + let w1 = weight_of_term t1 + and w2 = weight_of_term t2 in + let rec cmp t1 t2 = + match t1, t2 with + | [], [] -> Eq + | _, [] -> Gt + | [], _ -> Lt + | hd1::tl1, hd2::tl2 -> + let o = + kbo hd1 hd2 + in + if o = Eq then cmp tl1 tl2 + else o + in + let comparison = compare_weights ~normalize:true w1 w2 in + match comparison with + | Le -> + let r = aux t1 t2 in + if r = Lt then Lt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Lt then Lt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Ge -> + let r = aux t1 t2 in + if r = Gt then Gt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Gt then Gt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Eq -> + let r = aux t1 t2 in + if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + cmp tl1 tl2 + | _, _ -> Incomparable + ) else r + | res -> res +;; + +let rec ao t1 t2 = + let get_hd t = + match t with + Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno) + | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) -> + Some(uri,tyno,cno) + | _ -> None in + let aux = aux_ordering ~recursion:false in + let w1 = weight_of_term t1 + and w2 = weight_of_term t2 in + let rec cmp t1 t2 = + match t1, t2 with + | [], [] -> Eq + | _, [] -> Gt + | [], _ -> Lt + | hd1::tl1, hd2::tl2 -> + let o = + ao hd1 hd2 + in + if o = Eq then cmp tl1 tl2 + else o + in + match get_hd t1, get_hd t2 with + Some(_),None -> Lt + | None,Some(_) -> Gt + | _ -> + let comparison = compare_weights ~normalize:true w1 w2 in + match comparison with + | Le -> + let r = aux t1 t2 in + if r = Lt then Lt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Lt then Lt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Ge -> + let r = aux t1 t2 in + if r = Gt then Gt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Gt then Gt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Eq -> + let r = aux t1 t2 in + if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + cmp tl1 tl2 + | _, _ -> Incomparable + ) else r + | res -> res +;; + +let names_of_context context = + List.map + (function + | None -> None + | Some (n, e) -> Some n) + context +;; + + +let rec lpo t1 t2 = + let module C = Cic in + match t1, t2 with + | t1, t2 when t1 = t2 -> Eq + | t1, (C.Meta _ as m) -> + if TermSet.mem m (metas_of_term t1) then Gt else Incomparable + | (C.Meta _ as m), t2 -> + if TermSet.mem m (metas_of_term t2) then Lt else Incomparable + | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> ( + let res = + let f o r t = + if r then true else + match lpo t o with + | Gt | Eq -> true + | _ -> false + in + let res1 = List.fold_left (f t2) false tl1 in + if res1 then Gt + else let res2 = List.fold_left (f t1) false tl2 in + if res2 then Lt + else Incomparable + in + if res <> Incomparable then + res + else + let f o r t = + if not r then false else + match lpo o t with + | Gt -> true + | _ -> false + in + match aux_ordering hd1 hd2 with + | Gt -> + let res = List.fold_left (f t1) false tl2 in + if res then Gt + else Incomparable + | Lt -> + let res = List.fold_left (f t2) false tl1 in + if res then Lt + else Incomparable + | Eq -> ( + let lex_res = + try + List.fold_left2 + (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2) + Eq tl1 tl2 + with Invalid_argument _ -> + Incomparable + in + match lex_res with + | Gt -> + if List.fold_left (f t1) false tl2 then Gt + else Incomparable + | Lt -> + if List.fold_left (f t2) false tl1 then Lt + else Incomparable + | _ -> Incomparable + ) + | _ -> Incomparable + ) + | t1, t2 -> aux_ordering t1 t2 +;; + + +(* settable by the user... *) +let compare_terms = ref nonrec_kbo;; +(* let compare_terms = ref ao;; *) +(* let compare_terms = ref rpo;; *) + +let guarded_simpl ?(debug=false) context t = + if !compare_terms == nonrec_kbo then t + else + let t' = ProofEngineReduction.simpl context t in + if t = t' then t else + begin + let simpl_order = !compare_terms t t' in + if debug then + prerr_endline ("comparing "^(CicPp.ppterm t)^(CicPp.ppterm t')); + if simpl_order = Gt then (if debug then prerr_endline "GT";t') + else (if debug then prerr_endline "NO_GT";t) + end +;; + +type equality_sign = Negative | Positive;; + +let string_of_sign = function + | Negative -> "Negative" + | Positive -> "Positive" +;; + + +type pos = Left | Right + +let string_of_pos = function + | Left -> "Left" + | Right -> "Right" +;; + + +let eq_ind_URI () = LibraryObjects.eq_ind_URI ~eq:(LibraryObjects.eq_URI ()) +let eq_ind_r_URI () = LibraryObjects.eq_ind_r_URI ~eq:(LibraryObjects.eq_URI ()) +let sym_eq_URI () = LibraryObjects.sym_eq_URI ~eq:(LibraryObjects.eq_URI ()) +let eq_XURI () = + let s = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (s ^ "#xpointer(1/1/1)") +let trans_eq_URI () = LibraryObjects.trans_eq_URI ~eq:(LibraryObjects.eq_URI ()) diff --git a/helm/software/components/tactics/paramodulation/utils.mli b/helm/software/components/tactics/paramodulation/utils.mli new file mode 100644 index 000000000..ce14d480f --- /dev/null +++ b/helm/software/components/tactics/paramodulation/utils.mli @@ -0,0 +1,84 @@ +(* Copyright (C) 2005, 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/. + *) + +(* (weight of constants, [(meta, weight_of_meta)]) *) +type weight = int * (int * int) list;; + +type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; + +val print_metasenv: Cic.metasenv -> string + +val print_subst: ?prefix:string -> Cic.substitution -> string + +val string_of_weight: weight -> string + +val weight_of_term: ?consider_metas:bool -> Cic.term -> weight + +val normalize_weight: int -> weight -> weight + +val string_of_comparison: comparison -> string + +val compare_weights: ?normalize:bool -> weight -> weight -> comparison + +val nonrec_kbo: Cic.term -> Cic.term -> comparison + +val rpo: Cic.term -> Cic.term -> comparison + +val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison + +val names_of_context: Cic.context -> (Cic.name option) list + +module TermMap: Map.S with type key = Cic.term + +val symbols_of_term: Cic.term -> int TermMap.t + +val lpo: Cic.term -> Cic.term -> comparison + +val kbo: Cic.term -> Cic.term -> comparison + +val ao: Cic.term -> Cic.term -> comparison + +(** term-ordering function settable by the user *) +val compare_terms: (Cic.term -> Cic.term -> comparison) ref + +val guarded_simpl: ?debug:bool -> Cic.context -> Cic.term -> Cic.term + +type equality_sign = Negative | Positive + +val string_of_sign: equality_sign -> string + +type pos = Left | Right + +val string_of_pos: pos -> string + +val compute_equality_weight: Cic.term -> Cic.term -> Cic.term -> int + +val debug_print: string Lazy.t -> unit + +val eq_ind_URI: unit -> UriManager.uri +val eq_ind_r_URI: unit -> UriManager.uri +val sym_eq_URI: unit -> UriManager.uri +val eq_XURI: unit -> UriManager.uri +val trans_eq_URI: unit -> UriManager.uri diff --git a/helm/software/components/tactics/primitiveTactics.ml b/helm/software/components/tactics/primitiveTactics.ml new file mode 100644 index 000000000..7a732a572 --- /dev/null +++ b/helm/software/components/tactics/primitiveTactics.ml @@ -0,0 +1,567 @@ +(* 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/. + *) + +(* $Id$ *) + +open ProofEngineHelpers +open ProofEngineTypes + +exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple +exception NotAnInductiveTypeToEliminate +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. *) +(* howmany = -1 means Intros, howmany > 0 means Intros n *) +let lambda_abstract ?(howmany=(-1)) metasenv context newmeta ty mk_fresh_name = + let module C = Cic in + let rec collect_context context howmany ty = + match howmany with + | 0 -> + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context + in + context, ty, (C.Meta (newmeta,irl)) + | _ -> + match ty with + C.Cast (te,_) -> collect_context context howmany te + | C.Prod (n,s,t) -> + let n' = mk_fresh_name metasenv context n ~typ:s in + let (context',ty,bo) = + collect_context ((Some (n',(C.Decl s)))::context) (howmany - 1) 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,None))))::context) (howmany - 1) t + in + (context',ty,C.LetIn(n,s,bo)) + | _ as t -> + if howmany <= 0 then + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context + in + context, t, (C.Meta (newmeta,irl)) + else + raise (Fail (lazy "intro(s): not enough products or let-ins")) + in + collect_context context howmany 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 (i,l) -> + let l' = + List.map (function None -> None | Some t -> Some (aux n t)) l + in + C.Meta (i, l') + | 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 CicUniv.empty_ugraph (* TASSI: FIXME *) + in + let fresh_name = + FreshNamesGenerator.mk_fresh_name ~subst:[] + metasenv 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,None)) -> + Some (n,Cic.Def ((subst_in canonical_context' s),None)) + | None -> None + | Some (n,Cic.Def (bo,Some ty)) -> + Some + (n, + Cic.Def + (subst_in canonical_context' bo, + Some (subst_in canonical_context' ty))) + 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 ([],[]) + +(* 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 = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + CicUtil.params_of_obj o + 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 = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.Variable (_,_,ty,_,_) -> + CicSubstitution.subst_vars !exp_named_subst_diff ty + | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri)) + in +(* CSC: patch to generate ?1 : ?2 : Type in place of ?1 : Type to simulate ?1 :< Type + (match ty with + C.Sort (C.Type _) as s -> (* TASSI: ?? *) + let fresh_meta = !next_fresh_meta in + let fresh_meta' = fresh_meta + 1 in + next_fresh_meta := !next_fresh_meta + 2 ; + let subst_item = uri,C.Meta (fresh_meta',[]) in + newmetasenvfragment := + (fresh_meta,[],C.Sort (C.Type (CicUniv.fresh()))) :: + (* TASSI: ?? *) + (fresh_meta',[],C.Meta (fresh_meta,[])) :: !newmetasenvfragment ; + exp_named_subst_diff := !exp_named_subst_diff @ [subst_item] ; + subst_item::(aux (tl,[])) + | _ -> +*) + let irl = + CicMkImplicit.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 + new_fresh_meta,newmetasenvfragment,exp_named_subst',exp_named_subst_diff +;; + +let new_metasenv_and_unify_and_t newmeta' metasenv' context term' ty termty goal_arity = + let (consthead,newmetasenv,arguments,_) = + saturate_term newmeta' metasenv' context termty goal_arity in + let subst,newmetasenv',_ = + CicUnification.fo_unif newmetasenv context consthead ty CicUniv.empty_ugraph + in + let t = + if List.length arguments = 0 then term' else Cic.Appl (term'::arguments) + in + subst,newmetasenv',t + +let rec count_prods context ty = + match CicReduction.whd context ty with + Cic.Prod (n,s,t) -> 1 + count_prods (Some (n,Cic.Decl s)::context) t + | _ -> 0 + +let apply_tac_verbose_with_subst ~term (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 = CicUtil.lookup_meta goal metasenv in + let newmeta = new_meta_of_proof ~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 + let termty,_ = + CicTypeChecker.type_of_aux' metasenv' context term' CicUniv.empty_ugraph + in + let termty = + CicSubstitution.subst_vars exp_named_subst_diff termty in + let goal_arity = count_prods context ty in + let subst,newmetasenv',t = + let rec add_one_argument n = + try + new_metasenv_and_unify_and_t newmeta' metasenv' context term' ty + termty n + with CicUnification.UnificationFailure _ when n > 0 -> + add_one_argument (n - 1) + in + add_one_argument goal_arity + in + let in_subst_domain i = List.exists (function (j,_) -> i=j) subst in + let apply_subst = CicMetaSubst.apply_subst subst in + let old_uninstantiatedmetas,new_uninstantiatedmetas = + (* subst_in doesn't need the context. Hence the underscore. *) + let subst_in _ = CicMetaSubst.apply_subst subst in + classify_metas newmeta in_subst_domain subst_in newmetasenv' + in + let bo' = apply_subst t in + let newmetasenv'' = new_uninstantiatedmetas@old_uninstantiatedmetas in + let subst_in = + (* if we just apply the subtitution, the type is irrelevant: + we may use Implicit, since it will be dropped *) + CicMetaSubst.apply_subst ((metano,(context,bo',Cic.Implicit None))::subst) + in + let (newproof, newmetasenv''') = + subst_meta_and_metasenv_in_proof proof metano subst_in newmetasenv'' + in + (((metano,(context,bo',Cic.Implicit None))::subst)(* subst_in *), (* ALB *) + (newproof, + List.map (function (i,_,_) -> i) new_uninstantiatedmetas)) + + +(* ALB *) +let apply_tac_verbose_with_subst ~term status = + try +(* apply_tac_verbose ~term status *) + apply_tac_verbose_with_subst ~term status + (* TODO cacciare anche altre eccezioni? *) + with + | CicUnification.UnificationFailure msg + | CicTypeChecker.TypeCheckerFailure msg -> + raise (Fail msg) + +(* ALB *) +let apply_tac_verbose ~term status = + let subst, status = apply_tac_verbose_with_subst ~term status in + (CicMetaSubst.apply_subst subst), status + +let apply_tac ~term status = snd (apply_tac_verbose ~term status) + + (* TODO per implementare i tatticali e' necessario che tutte le tattiche + sollevino _solamente_ Fail *) +let apply_tac ~term = + let apply_tac ~term status = + try + apply_tac ~term status + (* TODO cacciare anche altre eccezioni? *) + with + | CicUnification.UnificationFailure msg + | CicTypeChecker.TypeCheckerFailure msg -> + raise (Fail msg) + in + mk_tactic (apply_tac ~term) + +let intros_tac ?howmany ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) ()= + let intros_tac + ?(mk_fresh_name_callback = (FreshNamesGenerator.mk_fresh_name ~subst:[])) () + (proof, goal) + = + let module C = Cic in + let module R = CicReduction in + let (_,metasenv,_,_) = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let newmeta = new_meta_of_proof ~proof in + let (context',ty',bo') = + lambda_abstract ?howmany metasenv context newmeta ty mk_fresh_name_callback + in + let (newproof, _) = + subst_meta_in_proof proof metano bo' [newmeta,context',ty'] + in + (newproof, [newmeta]) + in + mk_tactic (intros_tac ~mk_fresh_name_callback ()) + +let cut_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) term = + let cut_tac + ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + term (proof, goal) + = + let module C = Cic in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let newmeta1 = new_meta_of_proof ~proof in + let newmeta2 = newmeta1 + 1 in + let fresh_name = + mk_fresh_name_callback metasenv context (Cic.Name "Hcut") ~typ:term in + let context_for_newmeta1 = + (Some (fresh_name,C.Decl term))::context in + let irl1 = + CicMkImplicit.identity_relocation_list_for_metavariable + context_for_newmeta1 + in + let irl2 = + CicMkImplicit.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]) + in + mk_tactic (cut_tac ~mk_fresh_name_callback term) + +let letin_tac ?(mk_fresh_name_callback=FreshNamesGenerator.mk_fresh_name ~subst:[]) term = + let letin_tac + ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + term (proof, goal) + = + let module C = Cic in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let _,_ = (* TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in + let newmeta = new_meta_of_proof ~proof in + let fresh_name = + mk_fresh_name_callback metasenv context (Cic.Name "Hletin") ~typ:term in + let context_for_newmeta = + (Some (fresh_name,C.Def (term,None)))::context in + let irl = + CicMkImplicit.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]) + in + mk_tactic (letin_tac ~mk_fresh_name_callback term) + + (** functional part of the "exact" tactic *) +let exact_tac ~term = + let exact_tac ~term (proof, goal) = + (* Assumption: the term bo must be closed in the current context *) + let (_,metasenv,_,_) = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let module T = CicTypeChecker in + let module R = CicReduction in + let ty_term,u = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in + let b,_ = R.are_convertible context ty_term ty u in (* TASSI: FIXME *) + if b then + begin + let (newproof, metasenv') = + subst_meta_in_proof proof metano term [] in + (newproof, []) + end + else + raise (Fail (lazy "The type of the provided term is not the one expected.")) + in + mk_tactic (exact_tac ~term) + +(* not really "primitive" tactics .... *) +let elim_tac ~term = + let elim_tac ~term (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,proofbo,proofty) = proof in + let metano,context,ty = CicUtil.lookup_meta goal metasenv in + let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in + let (termty,metasenv',arguments,fresh_meta) = + ProofEngineHelpers.saturate_term + (ProofEngineHelpers.new_meta_of_proof proof) metasenv context termty 0 in + let term = if arguments = [] then term else Cic.Appl (term::arguments) 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 = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.InductiveDefinition (tys,_,_,_) -> + let (name,_,_,_) = List.nth tys typeno in + name + | _ -> assert false + in + let ty_ty,_ = T.type_of_aux' metasenv' context ty CicUniv.empty_ugraph in + let ext = + match ty_ty with + C.Sort C.Prop -> "_ind" + | C.Sort C.Set -> "_rec" + | C.Sort C.CProp -> "_rec" + | C.Sort (C.Type _)-> "_rect" + | C.Meta (_,_) -> raise TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple + | _ -> 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 CicUniv.empty_ugraph in + let rec find_args_no = + function + C.Prod (_,_,t) -> 1 + find_args_no t + | C.Cast (s,_) -> find_args_no s + | C.LetIn (_,_,t) -> 0 + find_args_no t + | _ -> 0 + in + let args_no = find_args_no ety in + let term_to_refine = + let rec make_tl base_case = + function + 0 -> [base_case] + | n -> (C.Implicit None)::(make_tl base_case (n - 1)) + in + C.Appl (eliminator_ref :: make_tl term (args_no - 1)) + in + let refined_term,_,metasenv'',_ = + CicRefine.type_of_aux' metasenv' context term_to_refine + CicUniv.empty_ugraph + in + let new_goals = + ProofEngineHelpers.compare_metasenvs + ~oldmetasenv:metasenv ~newmetasenv:metasenv'' + in + let proof' = curi,metasenv'',proofbo,proofty in + let proof'', new_goals' = + apply_tactic (apply_tac ~term:refined_term) (proof',goal) + in + (* The apply_tactic can have closed some of the new_goals *) + let patched_new_goals = + let (_,metasenv''',_,_) = proof'' in + List.filter + (function i -> List.exists (function (j,_,_) -> j=i) metasenv''' + ) new_goals @ new_goals' + in + proof'', patched_new_goals + in + mk_tactic (elim_tac ~term) +;; + +let elim_intros_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + ?depth ?using what = + Tacticals.then_ ~start:(elim_tac ~term:what) + ~continuation:(intros_tac ~mk_fresh_name_callback ?howmany:depth ()) +;; + +(* The simplification is performed only on the conclusion *) +let elim_intros_simpl_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + ?depth ?using what = + Tacticals.then_ ~start:(elim_tac ~term:what) + ~continuation: + (Tacticals.thens + ~start:(intros_tac ~mk_fresh_name_callback ?howmany:depth ()) + ~continuations: + [ReductionTactics.simpl_tac + ~pattern:(ProofEngineTypes.conclusion_pattern None)]) +;; diff --git a/helm/software/components/tactics/primitiveTactics.mli b/helm/software/components/tactics/primitiveTactics.mli new file mode 100644 index 000000000..01d200eb7 --- /dev/null +++ b/helm/software/components/tactics/primitiveTactics.mli @@ -0,0 +1,59 @@ +(* 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/. + *) + +(* ALB, needed by the new paramodulation... *) +val apply_tac_verbose_with_subst: + term:Cic.term -> ProofEngineTypes.proof * int -> + Cic.substitution * (ProofEngineTypes.proof * int list) + +(* not a real tactic *) +val apply_tac_verbose : + term:Cic.term -> + ProofEngineTypes.proof * int -> + (Cic.term -> Cic.term) * (ProofEngineTypes.proof * int list) + +val apply_tac: + term: Cic.term -> ProofEngineTypes.tactic +val exact_tac: + term: Cic.term -> ProofEngineTypes.tactic +val intros_tac: + ?howmany:int -> + ?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: + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic +val elim_intros_tac: + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/proofEngineHelpers.ml b/helm/software/components/tactics/proofEngineHelpers.ml new file mode 100644 index 000000000..cf7df2d58 --- /dev/null +++ b/helm/software/components/tactics/proofEngineHelpers.ml @@ -0,0 +1,688 @@ +(* 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/. + *) + +(* $Id$ *) + +exception Bad_pattern of string Lazy.t + +let new_meta_of_proof ~proof:(_, metasenv, _, _) = + CicMkImplicit.new_meta metasenv [] + +let subst_meta_in_proof proof meta term newmetasenv = + let uri,metasenv,bo,ty = proof in + (* empty context is ok for term since it wont be used by apply_subst *) + (* hack: since we do not know the context and the type of term, we + create a substitution with cc =[] and type = Implicit; they will be + in any case dropped by apply_subst, but it would be better to rewrite + the code. Cannot we just use apply_subst_metasenv, etc. ?? *) + let subst_in = CicMetaSubst.apply_subst [meta,([], term,Cic.Implicit None)] 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,None)) -> Some (n,Cic.Def (subst_in s,None)) + | None -> None + | Some (n,Cic.Def (bo,Some ty)) -> + Some (n,Cic.Def (subst_in bo,Some (subst_in ty))) + ) canonical_context + in + i,canonical_context',(subst_in ty) + ) metasenv' + in + let bo' = subst_in bo in + (* Metavariables can appear also in the *statement* of the theorem + * since the parser does not reject as statements terms with + * metavariable therein *) + let ty' = subst_in ty 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 + (* Metavariables can appear also in the *statement* of the theorem + * since the parser does not reject as statements terms with + * metavariable therein *) + let ty' = subst_in ty 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,None)) -> + Some (i,Cic.Def (subst_in t,None)) + | Some (i,Cic.Def (bo,Some ty)) -> + Some (i,Cic.Def (subst_in bo,Some (subst_in ty))) + ) canonical_context + in + (m,canonical_context',subst_in ty)::i + | _ -> i + ) newmetasenv [] + in + let newproof = uri,metasenv',bo',ty' in + (newproof, metasenv') + +let compare_metasenvs ~oldmetasenv ~newmetasenv = + List.map (function (i,_,_) -> i) + (List.filter + (function (i,_,_) -> + not (List.exists (fun (j,_,_) -> i=j) oldmetasenv)) newmetasenv) +;; + +(** finds the _pointers_ to subterms that are alpha-equivalent to wanted in t *) +let find_subterms ~subst ~metasenv ~ugraph ~wanted ~context t = + let rec find subst metasenv ugraph context w t = + try + let subst,metasenv,ugraph = + CicUnification.fo_unif_subst subst context metasenv w t ugraph + in + subst,metasenv,ugraph,[context,t] + with + CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + match t with + | Cic.Sort _ + | Cic.Rel _ -> subst,metasenv,ugraph,[] + | Cic.Meta (_, ctx) -> + List.fold_left ( + fun (subst,metasenv,ugraph,acc) e -> + match e with + | None -> subst,metasenv,ugraph,acc + | Some t -> + let subst,metasenv,ugraph,res = + find subst metasenv ugraph context w t + in + subst,metasenv,ugraph, res @ acc + ) (subst,metasenv,ugraph,[]) ctx + | Cic.Lambda (name, t1, t2) + | Cic.Prod (name, t1, t2) -> + let subst,metasenv,ugraph,rest1 = + find subst metasenv ugraph context w t1 in + let subst,metasenv,ugraph,rest2 = + find subst metasenv ugraph (Some (name, Cic.Decl t1)::context) + (CicSubstitution.lift 1 w) t2 + in + subst,metasenv,ugraph,rest1 @ rest2 + | Cic.LetIn (name, t1, t2) -> + let subst,metasenv,ugraph,rest1 = + find subst metasenv ugraph context w t1 in + let subst,metasenv,ugraph,rest2 = + find subst metasenv ugraph (Some (name, Cic.Def (t1,None))::context) + (CicSubstitution.lift 1 w) t2 + in + subst,metasenv,ugraph,rest1 @ rest2 + | Cic.Appl l -> + List.fold_left + (fun (subst,metasenv,ugraph,acc) t -> + let subst,metasenv,ugraph,res = + find subst metasenv ugraph context w t + in + subst,metasenv,ugraph,res @ acc) + (subst,metasenv,ugraph,[]) l + | Cic.Cast (t, ty) -> + let subst,metasenv,ugraph,rest = + find subst metasenv ugraph context w t in + let subst,metasenv,ugraph,resty = + find subst metasenv ugraph context w ty + in + subst,metasenv,ugraph,rest @ resty + | Cic.Implicit _ -> assert false + | Cic.Const (_, esubst) + | Cic.Var (_, esubst) + | Cic.MutInd (_, _, esubst) + | Cic.MutConstruct (_, _, _, esubst) -> + List.fold_left + (fun (subst,metasenv,ugraph,acc) (_, t) -> + let subst,metasenv,ugraph,res = + find subst metasenv ugraph context w t + in + subst,metasenv,ugraph,res @ acc) + (subst,metasenv,ugraph,[]) esubst + | Cic.MutCase (_, _, outty, indterm, patterns) -> + let subst,metasenv,ugraph,resoutty = + find subst metasenv ugraph context w outty in + let subst,metasenv,ugraph,resindterm = + find subst metasenv ugraph context w indterm in + let subst,metasenv,ugraph,respatterns = + List.fold_left + (fun (subst,metasenv,ugraph,acc) p -> + let subst,metaseng,ugraph,res = + find subst metasenv ugraph context w p + in + subst,metasenv,ugraph,res @ acc + ) (subst,metasenv,ugraph,[]) patterns + in + subst,metasenv,ugraph,resoutty @ resindterm @ respatterns + | Cic.Fix (_, funl) -> + let tys = + List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funl + in + List.fold_left ( + fun (subst,metasenv,ugraph,acc) (_, _, ty, bo) -> + let subst,metasenv,ugraph,resty = + find subst metasenv ugraph context w ty in + let subst,metasenv,ugraph,resbo = + find subst metasenv ugraph (tys @ context) w bo + in + subst,metasenv,ugraph, resty @ resbo @ acc + ) (subst,metasenv,ugraph,[]) funl + | Cic.CoFix (_, funl) -> + let tys = + List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funl + in + List.fold_left ( + fun (subst,metasenv,ugraph,acc) (_, ty, bo) -> + let subst,metasenv,ugraph,resty = + find subst metasenv ugraph context w ty in + let subst,metasenv,ugraph,resbo = + find subst metasenv ugraph (tys @ context) w bo + in + subst,metasenv,ugraph, resty @ resbo @ acc + ) (subst,metasenv,ugraph,[]) funl + in + find subst metasenv ugraph context wanted t + +let select_in_term ~metasenv ~context ~ugraph ~term ~pattern:(wanted,where) = + let add_ctx context name entry = (Some (name, entry)) :: context in + let map2 error_msg f l1 l2 = + try + List.map2 f l1 l2 + with + | Invalid_argument _ -> raise (Bad_pattern (lazy error_msg)) + in + let rec aux context where term = + match (where, term) with + | Cic.Implicit (Some `Hole), t -> [context,t] + | Cic.Implicit (Some `Type), t -> [] + | Cic.Implicit None,_ -> [] + | Cic.Meta (_, ctxt1), Cic.Meta (_, ctxt2) -> + List.concat + (map2 "wrong number of argument in explicit substitution" + (fun t1 t2 -> + (match (t1, t2) with + Some t1, Some t2 -> aux context t1 t2 + | _ -> [])) + ctxt1 ctxt2) + | Cic.Cast (te1, ty1), Cic.Cast (te2, ty2) -> + aux context te1 te2 @ aux context ty1 ty2 + | Cic.Prod (Cic.Anonymous, s1, t1), Cic.Prod (name, s2, t2) + | Cic.Lambda (Cic.Anonymous, s1, t1), Cic.Lambda (name, s2, t2) -> + aux context s1 s2 @ aux (add_ctx context name (Cic.Decl s2)) t1 t2 + | Cic.Prod (Cic.Name n1, s1, t1), + Cic.Prod ((Cic.Name n2) as name , s2, t2) + | Cic.Lambda (Cic.Name n1, s1, t1), + Cic.Lambda ((Cic.Name n2) as name, s2, t2) when n1 = n2-> + aux context s1 s2 @ aux (add_ctx context name (Cic.Decl s2)) t1 t2 + | Cic.Prod (name1, s1, t1), Cic.Prod (name2, s2, t2) + | Cic.Lambda (name1, s1, t1), Cic.Lambda (name2, s2, t2) -> [] + | Cic.LetIn (Cic.Anonymous, s1, t1), Cic.LetIn (name, s2, t2) -> + aux context s1 s2 @ aux (add_ctx context name (Cic.Def (s2,None))) t1 t2 + | Cic.LetIn (Cic.Name n1, s1, t1), + Cic.LetIn ((Cic.Name n2) as name, s2, t2) when n1 = n2-> + aux context s1 s2 @ aux (add_ctx context name (Cic.Def (s2,None))) t1 t2 + | Cic.LetIn (name1, s1, t1), Cic.LetIn (name2, s2, t2) -> [] + | Cic.Appl terms1, Cic.Appl terms2 -> auxs context terms1 terms2 + | Cic.Var (_, subst1), Cic.Var (_, subst2) + | Cic.Const (_, subst1), Cic.Const (_, subst2) + | Cic.MutInd (_, _, subst1), Cic.MutInd (_, _, subst2) + | Cic.MutConstruct (_, _, _, subst1), Cic.MutConstruct (_, _, _, subst2) -> + auxs context (List.map snd subst1) (List.map snd subst2) + | Cic.MutCase (_, _, out1, t1, pat1), Cic.MutCase (_ , _, out2, t2, pat2) -> + aux context out1 out2 @ aux context t1 t2 @ auxs context pat1 pat2 + | Cic.Fix (_, funs1), Cic.Fix (_, funs2) -> + let tys = + List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs2 + in + List.concat + (map2 "wrong number of mutually recursive functions" + (fun (_, _, ty1, bo1) (_, _, ty2, bo2) -> + aux context ty1 ty2 @ aux (tys @ context) bo1 bo2) + funs1 funs2) + | Cic.CoFix (_, funs1), Cic.CoFix (_, funs2) -> + let tys = + List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs2 + in + List.concat + (map2 "wrong number of mutually co-recursive functions" + (fun (_, ty1, bo1) (_, ty2, bo2) -> + aux context ty1 ty2 @ aux (tys @ context) bo1 bo2) + funs1 funs2) + | x,y -> + raise (Bad_pattern + (lazy (Printf.sprintf "Pattern %s versus term %s" + (CicPp.ppterm x) + (CicPp.ppterm y)))) + and auxs context terms1 terms2 = (* as aux for list of terms *) + List.concat (map2 "wrong number of arguments in application" + (fun t1 t2 -> aux context t1 t2) terms1 terms2) + in + let roots = + match where with + | None -> [] + | Some where -> aux context where term + in + match wanted with + None -> [],metasenv,ugraph,roots + | Some wanted -> + let rec find_in_roots = + function + [] -> [],metasenv,ugraph,[] + | (context',where)::tl -> + let subst,metasenv,ugraph,tl' = find_in_roots tl in + let subst,metasenv,ugraph,found = + let wanted, metasenv, ugraph = wanted context' metasenv ugraph in + find_subterms ~subst ~metasenv ~ugraph ~wanted ~context:context' + where + in + subst,metasenv,ugraph,found @ tl' + in + find_in_roots roots + +(** create a pattern from a term and a list of subterms. +* the pattern is granted to have a ? for every subterm that has no selected +* subterms +* @param equality equality function used while walking the term. Defaults to +* physical equality (==) *) +let pattern_of ?(equality=(==)) ~term terms = + let (===) x y = equality x y in + let not_found = false, Cic.Implicit None in + let rec aux t = + match t with + | t when List.exists (fun t' -> t === t') terms -> + true,Cic.Implicit (Some `Hole) + | Cic.Var (uri, subst) -> + let b,subst = aux_subst subst in + if b then + true,Cic.Var (uri, subst) + else + not_found + | Cic.Meta (i, ctxt) -> + let b,ctxt = + List.fold_right + (fun e (b,ctxt) -> + match e with + None -> b,None::ctxt + | Some t -> let bt,t = aux t in b||bt ,Some t::ctxt + ) ctxt (false,[]) + in + if b then + true,Cic.Meta (i, ctxt) + else + not_found + | Cic.Cast (te, ty) -> + let b1,te = aux te in + let b2,ty = aux ty in + if b1||b2 then true,Cic.Cast (te, ty) + else + not_found + | Cic.Prod (name, s, t) -> + let b1,s = aux s in + let b2,t = aux t in + if b1||b2 then + true, Cic.Prod (name, s, t) + else + not_found + | Cic.Lambda (name, s, t) -> + let b1,s = aux s in + let b2,t = aux t in + if b1||b2 then + true, Cic.Lambda (name, s, t) + else + not_found + | Cic.LetIn (name, s, t) -> + let b1,s = aux s in + let b2,t = aux t in + if b1||b2 then + true, Cic.LetIn (name, s, t) + else + not_found + | Cic.Appl terms -> + let b,terms = + List.fold_right + (fun t (b,terms) -> + let bt,t = aux t in + b||bt,t::terms + ) terms (false,[]) + in + if b then + true,Cic.Appl terms + else + not_found + | Cic.Const (uri, subst) -> + let b,subst = aux_subst subst in + if b then + true, Cic.Const (uri, subst) + else + not_found + | Cic.MutInd (uri, tyno, subst) -> + let b,subst = aux_subst subst in + if b then + true, Cic.MutInd (uri, tyno, subst) + else + not_found + | Cic.MutConstruct (uri, tyno, consno, subst) -> + let b,subst = aux_subst subst in + if b then + true, Cic.MutConstruct (uri, tyno, consno, subst) + else + not_found + | Cic.MutCase (uri, tyno, outty, t, pat) -> + let b1,outty = aux outty in + let b2,t = aux t in + let b3,pat = + List.fold_right + (fun t (b,pat) -> + let bt,t = aux t in + bt||b,t::pat + ) pat (false,[]) + in + if b1 || b2 || b3 then + true, Cic.MutCase (uri, tyno, outty, t, pat) + else + not_found + | Cic.Fix (funno, funs) -> + let b,funs = + List.fold_right + (fun (name, i, ty, bo) (b,funs) -> + let b1,ty = aux ty in + let b2,bo = aux bo in + b||b1||b2, (name, i, ty, bo)::funs) funs (false,[]) + in + if b then + true, Cic.Fix (funno, funs) + else + not_found + | Cic.CoFix (funno, funs) -> + let b,funs = + List.fold_right + (fun (name, ty, bo) (b,funs) -> + let b1,ty = aux ty in + let b2,bo = aux bo in + b||b1||b2, (name, ty, bo)::funs) funs (false,[]) + in + if b then + true, Cic.CoFix (funno, funs) + else + not_found + | Cic.Rel _ + | Cic.Sort _ + | Cic.Implicit _ -> not_found + and aux_subst subst = + List.fold_right + (fun (uri, t) (b,subst) -> + let b1,t = aux t in + b||b1,(uri, t)::subst) subst (false,[]) + in + snd (aux term) + +exception Fail of string Lazy.t + + (** select metasenv conjecture pattern + * select all subterms of [conjecture] matching [pattern]. + * It returns the set of matched terms (that can be compared using physical + * equality to the subterms of [conjecture]) together with their contexts. + * The representation of the set mimics the ProofEngineTypes.pattern type: + * a list of hypothesis (names of) together with the list of its matched + * subterms (and their contexts) + the list of matched subterms of the + * with their context conclusion. Note: in the result the list of hypothesis + * has an entry for each entry in the context and in the same order. + * Of course the list of terms (with their context) associated to the + * hypothesis name may be empty. + * + * @raise Bad_pattern + * *) + let select ~metasenv ~ugraph ~conjecture:(_,context,ty) + ~(pattern: (Cic.term, Cic.lazy_term) ProofEngineTypes.pattern) + = + let what, hyp_patterns, goal_pattern = pattern in + let find_pattern_for name = + try Some (snd (List.find (fun (n, pat) -> Cic.Name n = name) hyp_patterns)) + with Not_found -> None in + let subst,metasenv,ugraph,ty_terms = + select_in_term ~metasenv ~context ~ugraph ~term:ty + ~pattern:(what,goal_pattern) in + let subst,metasenv,ugraph,context_terms = + let subst,metasenv,ugraph,res,_ = + (List.fold_right + (fun entry (subst,metasenv,ugraph,res,context) -> + match entry with + None -> subst,metasenv,ugraph,(None::res),(None::context) + | Some (name,Cic.Decl term) -> + (match find_pattern_for name with + | None -> + subst,metasenv,ugraph,((Some (`Decl []))::res),(entry::context) + | Some pat -> + let subst,metasenv,ugraph,terms = + select_in_term ~metasenv ~context ~ugraph ~term + ~pattern:(what, Some pat) + in + subst,metasenv,ugraph,((Some (`Decl terms))::res), + (entry::context)) + | Some (name,Cic.Def (bo, ty)) -> + (match find_pattern_for name with + | None -> + let selected_ty=match ty with None -> None | Some _ -> Some [] in + subst,metasenv,ugraph,((Some (`Def ([],selected_ty)))::res), + (entry::context) + | Some pat -> + let subst,metasenv,ugraph,terms_bo = + select_in_term ~metasenv ~context ~ugraph ~term:bo + ~pattern:(what, Some pat) in + let subst,metasenv,ugraph,terms_ty = + match ty with + None -> subst,metasenv,ugraph,None + | Some ty -> + let subst,metasenv,ugraph,res = + select_in_term ~metasenv ~context ~ugraph ~term:ty + ~pattern:(what, Some pat) + in + subst,metasenv,ugraph,Some res + in + subst,metasenv,ugraph,((Some (`Def (terms_bo,terms_ty)))::res), + (entry::context)) + ) context (subst,metasenv,ugraph,[],[])) + in + subst,metasenv,ugraph,res + in + subst,metasenv,ugraph,context_terms, ty_terms + +(** locate_in_term equality what where context +* [what] must match a subterm of [where] according to [equality] +* It returns the matched terms together with their contexts in [where] +* [equality] defaults to physical equality +* [context] must be the context of [where] +*) +let locate_in_term ?(equality=(fun _ -> (==))) what ~where context = + let add_ctx context name entry = + (Some (name, entry)) :: context in + let rec aux context where = + if equality context what where then [context,where] + else + match where with + | Cic.Implicit _ + | Cic.Meta _ + | Cic.Rel _ + | Cic.Sort _ + | Cic.Var _ + | Cic.Const _ + | Cic.MutInd _ + | Cic.MutConstruct _ -> [] + | Cic.Cast (te, ty) -> aux context te @ aux context ty + | Cic.Prod (name, s, t) + | Cic.Lambda (name, s, t) -> + aux context s @ aux (add_ctx context name (Cic.Decl s)) t + | Cic.LetIn (name, s, t) -> + aux context s @ aux (add_ctx context name (Cic.Def (s,None))) t + | Cic.Appl tl -> auxs context tl + | Cic.MutCase (_, _, out, t, pat) -> + aux context out @ aux context t @ auxs context pat + | Cic.Fix (_, funs) -> + let tys = + List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs + in + List.concat + (List.map + (fun (_, _, ty, bo) -> + aux context ty @ aux (tys @ context) bo) + funs) + | Cic.CoFix (_, funs) -> + let tys = + List.map (fun (n,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) funs + in + List.concat + (List.map + (fun (_, ty, bo) -> + aux context ty @ aux (tys @ context) bo) + funs) + and auxs context tl = (* as aux for list of terms *) + List.concat (List.map (fun t -> aux context t) tl) + in + aux context where + +(** locate_in_conjecture equality what where context +* [what] must match a subterm of [where] according to [equality] +* It returns the matched terms together with their contexts in [where] +* [equality] defaults to physical equality +* [context] must be the context of [where] +*) +let locate_in_conjecture ?(equality=fun _ -> (==)) what (_,context,ty) = + let context,res = + List.fold_right + (fun entry (context,res) -> + match entry with + None -> entry::context, res + | Some (_, Cic.Decl ty) -> + let res = res @ locate_in_term what ~where:ty context in + let context' = entry::context in + context',res + | Some (_, Cic.Def (bo,ty)) -> + let res = res @ locate_in_term what ~where:bo context in + let res = + match ty with + None -> res + | Some ty -> + res @ locate_in_term what ~where:ty context in + let context' = entry::context in + context',res + ) context ([],[]) + in + res @ locate_in_term what ~where:ty context + +(* saturate_term newmeta metasenv context ty goal_arity *) +(* Given a type [ty] (a backbone), it returns its suffix of length *) +(* [goal_arity] head and a new metasenv in which there is new a META for each *) +(* hypothesis, a list of arguments for the new applications and the index of *) +(* the last new META introduced. The nth argument in the list of arguments is *) +(* just the nth new META. *) +let saturate_term newmeta metasenv context ty goal_arity = + let module C = Cic in + let module S = CicSubstitution in + assert (goal_arity >= 0); + let rec aux newmeta ty = + match ty with + C.Cast (he,_) -> aux newmeta he +(* CSC: patch to generate ?1 : ?2 : Type in place of ?1 : Type to simulate ?1 :< Type + (* If the expected type is a Type, then also Set is OK ==> + * we accept any term of type Type *) + (*CSC: BUG HERE: in this way it is possible for the term of + * type Type to be different from a Sort!!! *) + | C.Prod (name,(C.Sort (C.Type _) as s),t) -> + (* TASSI: ask CSC if BUG HERE refers to the C.Cast or C.Propd case *) + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context + in + let newargument = C.Meta (newmeta+1,irl) in + let (res,newmetasenv,arguments,lastmeta) = + aux (newmeta + 2) (S.subst newargument t) + in + res, + (newmeta,[],s)::(newmeta+1,context,C.Meta (newmeta,[]))::newmetasenv, + newargument::arguments,lastmeta +*) + | C.Prod (name,s,t) -> + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context + in + let newargument = C.Meta (newmeta,irl) in + let res,newmetasenv,arguments,lastmeta,prod_no = + aux (newmeta + 1) (S.subst newargument t) + in + if prod_no + 1 = goal_arity then + let head = CicReduction.normalize ~delta:false context ty in + head,[],[],lastmeta,goal_arity + 1 + else + (** NORMALIZE RATIONALE + * we normalize the target only NOW since we may be in this case: + * A1 -> A2 -> T where T = (\lambda x.A3 -> P) k + * and we want a mesasenv with ?1:A1 and ?2:A2 and not + * ?1, ?2, ?3 (that is the one we whould get if we start from the + * beta-normalized A1 -> A2 -> A3 -> P **) + let s' = CicReduction.normalize ~delta:false context s in + res,(newmeta,context,s')::newmetasenv,newargument::arguments, + lastmeta,prod_no + 1 + | t -> + let head = CicReduction.normalize ~delta:false context t in + match CicReduction.whd context head with + C.Prod _ as head' -> aux newmeta head' + | _ -> head,[],[],newmeta,0 + 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,metasenv @ newmetasenv,arguments,lastmeta + +let lookup_type metasenv context hyp = + let rec aux p = function + | Some (Cic.Name name, Cic.Decl t) :: _ when name = hyp -> p, t + | Some (Cic.Name name, Cic.Def (_, Some t)) :: _ when name = hyp -> p, t + | Some (Cic.Name name, Cic.Def (u, _)) :: tail when name = hyp -> + p, fst (CicTypeChecker.type_of_aux' metasenv tail u CicUniv.empty_ugraph) + | _ :: tail -> aux (succ p) tail + | [] -> raise (ProofEngineTypes.Fail (lazy "lookup_type: not premise in the current goal")) + in + aux 1 context diff --git a/helm/software/components/tactics/proofEngineHelpers.mli b/helm/software/components/tactics/proofEngineHelpers.mli new file mode 100644 index 000000000..a7c0e5b54 --- /dev/null +++ b/helm/software/components/tactics/proofEngineHelpers.mli @@ -0,0 +1,118 @@ +(* 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/. + *) + +exception Bad_pattern of string Lazy.t + +(* Returns the first meta whose number is above the *) +(* number of the higher meta. *) +val new_meta_of_proof : 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 + +(* returns the list of goals that are in newmetasenv and were not in + oldmetasenv *) +val compare_metasenvs : + oldmetasenv:Cic.metasenv -> newmetasenv:Cic.metasenv -> int list + + +(** { Patterns } + * A pattern is a Cic term in which Cic.Implicit terms annotated with `Hole + * appears *) + +(** create a pattern from a term and a list of subterms. +* the pattern is granted to have a ? for every subterm that has no selected +* subterms +* @param equality equality function used while walking the term. Defaults to +* physical equality (==) *) +val pattern_of: + ?equality:(Cic.term -> Cic.term -> bool) -> term:Cic.term -> Cic.term list -> + Cic.term + + +(** select metasenv conjecture pattern +* select all subterms of [conjecture] matching [pattern]. +* It returns the set of matched terms (that can be compared using physical +* equality to the subterms of [conjecture]) together with their contexts. +* The representation of the set mimics the conjecture type (but for the id): +* a list of (possibly removed) hypothesis (without their names) together with +* the list of its matched subterms (and their contexts) + the list of matched +* subterms of the conclusion with their context. Note: in the result the list +* of hypotheses * has an entry for each entry in the context and in the same +* order. Of course the list of terms (with their context) associated to one +* hypothesis may be empty. +* +* @raise Bad_pattern +* *) +val select: + metasenv:Cic.metasenv -> + ugraph:CicUniv.universe_graph -> + conjecture:Cic.conjecture -> + pattern:ProofEngineTypes.lazy_pattern -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph * + [ `Decl of (Cic.context * Cic.term) list + | `Def of (Cic.context * Cic.term) list * (Cic.context * Cic.term) list option + ] option list * + (Cic.context * Cic.term) list + +(** locate_in_term equality what where context +* [what] must match a subterm of [where] according to [equality] +* It returns the matched terms together with their contexts in [where] +* [equality] defaults to physical equality +* [context] must be the context of [where] +*) +val locate_in_term: + ?equality:(Cic.context -> Cic.term -> Cic.term -> bool) -> + Cic.term -> where:Cic.term -> Cic.context -> (Cic.context * Cic.term) list + +(** locate_in_conjecture equality what where context +* [what] must match a subterm of [where] according to [equality] +* It returns the matched terms together with their contexts in [where] +* [equality] defaults to physical equality +* [context] must be the context of [where] +*) +val locate_in_conjecture: + ?equality:(Cic.context -> Cic.term -> Cic.term -> bool) -> + Cic.term -> Cic.conjecture -> (Cic.context * Cic.term) list + +(* saturate_term newmeta metasenv context ty goal_arity *) +(* Given a type [ty] (a backbone), it returns its suffix of length *) +(* [goal_arity] head and a new metasenv in which there is new a META for each *) +(* hypothesis, a list of arguments for the new applications and the index of *) +(* the last new META introduced. The nth argument in the list of arguments is *) +(* just the nth new META. *) +val saturate_term: + int -> Cic.metasenv -> Cic.context -> Cic.term -> int -> + Cic.term * Cic.metasenv * Cic.term list * int + +(* returns the index and the type of a premise in a context *) +val lookup_type: Cic.metasenv -> Cic.context -> string -> int * Cic.term + diff --git a/helm/software/components/tactics/proofEngineReduction.ml b/helm/software/components/tactics/proofEngineReduction.ml new file mode 100644 index 000000000..0dc4ce4ee --- /dev/null +++ b/helm/software/components/tactics/proofEngineReduction.ml @@ -0,0 +1,965 @@ +(* 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 *) +(* 12/04/2002 *) +(* *) +(* *) +(******************************************************************************) + +(* $Id$ *) + +(* 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 what t 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 what t 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) -> + 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 what t 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 -> + 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) -> + 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 + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o 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 + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o 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) -> + 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) -> + 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 (_,_,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) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in + match o 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 reductaed, than it*) +(* is reduced, the delta-reduction is succesfull and the whole algorithm *) +(* is applied again to the new redex; Step 3.1) 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 performs step 3.2). *) +(* 3.1) 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. *) +(* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *) +(* reductions. If the reduction cannot be performed, it returns the *) +(* original term (not the head beta-zeta normal form of the definiendum) *) +(*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 -> + (* we never perform delta expansion automatically *) + if l = [] then t else C.Appl (t::l) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst' = + reduceaux_exp_named_subst context l exp_named_subst + in + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o 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 [] 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 + (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + match o with + C.Constant (_,Some body,_,_,_) -> + try_delta_expansion context 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) -> + 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 (_,_,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 (CicReduction.whd context term) with + C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1)) + | C.Appl (C.MutConstruct (_,_,j,_) :: tl) -> + let (arity, r) = + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in + match o 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 context 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) -> + 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) -> + 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.1 ****) + 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 -> + (**** Step 3.2 ****) + let rec aux l = + function + C.Lambda (name,s,t) -> + (match l with + [] -> raise AlreadySimplified + | he::tl -> + (* when name is Anonimous the substitution should *) + (* be superfluous *) + aux tl (S.subst he t)) + | C.LetIn (_,s,t) -> aux l (S.subst s t) + | t -> + let simplified = reduceaux context l t in + if t = simplified then + raise AlreadySimplified + else + simplified + in + (try aux l body + with + AlreadySimplified -> + if l = [] then term else C.Appl (term::l)) + | 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 [] +;; + +let unfold ?what context where = + let contextlen = List.length context in + let first_is_the_expandable_head_of_second context' t1 t2 = + match t1,t2 with + Cic.Const (uri,_), Cic.Const (uri',_) + | Cic.Var (uri,_), Cic.Var (uri',_) + | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_) + | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri' + | Cic.Const _, _ + | Cic.Var _, _ -> false + | Cic.Rel n, Cic.Rel m + | Cic.Rel n, Cic.Appl (Cic.Rel m::_) -> + n + (List.length context' - contextlen) = m + | Cic.Rel _, _ -> false + | _,_ -> + raise + (ProofEngineTypes.Fail + (lazy "The term to unfold is not a constant, a variable or a bound variable ")) + in + let appl he tl = + if tl = [] then he else Cic.Appl (he::tl) in + let cannot_delta_expand t = + raise + (ProofEngineTypes.Fail + (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in + let rec hd_delta_beta context tl = + function + Cic.Rel n as t -> + (try + match List.nth context (n-1) with + Some (_,Cic.Decl _) -> cannot_delta_expand t + | Some (_,Cic.Def (bo,_)) -> + CicReduction.head_beta_reduce + (appl (CicSubstitution.lift n bo) tl) + | None -> raise RelToHiddenHypothesis + with + Failure _ -> assert false) + | Cic.Const (uri,exp_named_subst) as t -> + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match o with + Cic.Constant (_,Some body,_,_,_) -> + CicReduction.head_beta_reduce + (appl (CicSubstitution.subst_vars exp_named_subst body) tl) + | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t + | Cic.Variable _ -> raise ReferenceToVariable + | Cic.CurrentProof _ -> raise ReferenceToCurrentProof + | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + ) + | Cic.Var (uri,exp_named_subst) as t -> + let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + (match o with + Cic.Constant _ -> raise ReferenceToConstant + | Cic.CurrentProof _ -> raise ReferenceToCurrentProof + | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + | Cic.Variable (_,Some body,_,_,_) -> + CicReduction.head_beta_reduce + (appl (CicSubstitution.subst_vars exp_named_subst body) tl) + | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t + ) + | Cic.Appl [] -> assert false + | Cic.Appl (he::tl) -> hd_delta_beta context tl he + | t -> cannot_delta_expand t + in + let context_and_matched_term_list = + match what with + None -> [context, where] + | Some what -> + let res = + ProofEngineHelpers.locate_in_term + ~equality:first_is_the_expandable_head_of_second + what ~where context + in + if res = [] then + raise + (ProofEngineTypes.Fail + (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where))) + else + res + in + let reduced_terms = + List.map + (function (context,where) -> hd_delta_beta context [] where) + context_and_matched_term_list in + let whats = List.map snd context_and_matched_term_list in + replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where +;; diff --git a/helm/software/components/tactics/proofEngineReduction.mli b/helm/software/components/tactics/proofEngineReduction.mli new file mode 100644 index 000000000..67247876a --- /dev/null +++ b/helm/software/components/tactics/proofEngineReduction.mli @@ -0,0 +1,49 @@ +(* 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:('a -> Cic.term -> 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 +val unfold : ?what:Cic.term -> Cic.context -> Cic.term -> Cic.term diff --git a/helm/software/components/tactics/proofEngineStructuralRules.ml b/helm/software/components/tactics/proofEngineStructuralRules.ml new file mode 100644 index 000000000..4677a33ac --- /dev/null +++ b/helm/software/components/tactics/proofEngineStructuralRules.ml @@ -0,0 +1,195 @@ +(* 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/. + *) + +(* $Id$ *) + +open ProofEngineTypes + +let clearbody ~hyp = + let clearbody ~hyp (proof, goal) = + let module C = Cic in + let curi,metasenv,pbo,pty = proof in + let metano,_,_ = CicUtil.lookup_meta 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 + Some (C.Name hyp',C.Def (term,ty)) when hyp = hyp' -> + let cleared_entry = + let ty = + match ty with + Some ty -> ty + | None -> + fst + (CicTypeChecker.type_of_aux' metasenv context term + CicUniv.empty_ugraph) (* TASSI: FIXME *) + in + Some (C.Name hyp, Cic.Decl ty) + in + cleared_entry::context + | None -> None::context + | Some (n,C.Decl t) + | Some (n,C.Def (t,None)) -> + let _,_ = + try + CicTypeChecker.type_of_aux' metasenv context t + CicUniv.empty_ugraph (* TASSI: FIXME *) + with + _ -> + raise + (Fail + (lazy ("The correctness of hypothesis " ^ + string_of_name n ^ + " relies on the body of " ^ hyp) + )) + in + entry::context + | Some (_,Cic.Def (_,Some _)) -> assert false + ) canonical_context [] + in + let _,_ = + try + CicTypeChecker.type_of_aux' metasenv canonical_context' ty + CicUniv.empty_ugraph (* TASSI: FIXME *) + with + _ -> + raise + (Fail + (lazy ("The correctness of the goal relies on the body of " ^ + hyp))) + in + m,canonical_context',ty + | t -> t + ) metasenv + in + (curi,metasenv',pbo,pty), [goal] + in + mk_tactic (clearbody ~hyp) + +let clear ~hyp = + let clear ~hyp (proof, goal) = + let module C = Cic in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = + CicUtil.lookup_meta 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 context_changed, canonical_context' = + List.fold_right + (fun entry (b, context) -> + match entry with + Some (Cic.Name hyp',_) when hyp' = hyp -> + (true, None::context) + | None -> (b, None::context) + | Some (n,C.Decl t) + | Some (n,Cic.Def (t,Some _)) + | Some (n,C.Def (t,None)) -> + if b then + let _,_ = + try + CicTypeChecker.type_of_aux' metasenv context t + CicUniv.empty_ugraph + with _ -> + raise + (Fail + (lazy ("Hypothesis " ^ string_of_name n ^ + " uses hypothesis " ^ hyp))) + in + (b, entry::context) + else + (b, entry::context) + ) canonical_context (false, []) + in + if not context_changed then + raise (Fail (lazy ("Hypothesis " ^ hyp ^ " does not exist"))); + let _,_ = + try + CicTypeChecker.type_of_aux' metasenv canonical_context' ty + CicUniv.empty_ugraph + with _ -> + raise (Fail (lazy ("Hypothesis " ^ hyp ^ " occurs in the goal"))) + in + m,canonical_context',ty + | t -> t + ) metasenv + in + (curi,metasenv',pbo,pty), [goal] + in + mk_tactic (clear ~hyp) + +(* Warning: this tactic has no effect on the proof term. + It just changes the name of an hypothesis in the current sequent *) +let rename ~from ~to_ = + let rename ~from ~to_ (proof, goal) = + let module C = Cic in + let curi,metasenv,pbo,pty = proof in + let metano,context,ty = + CicUtil.lookup_meta goal metasenv + in + let metasenv' = + List.map + (function + (m,canonical_context,ty) when m = metano -> + let canonical_context' = + List.map + (function + Some (Cic.Name hyp,decl_or_def) when hyp = from -> + Some (Cic.Name to_,decl_or_def) + | item -> item + ) canonical_context + in + m,canonical_context',ty + | t -> t + ) metasenv + in + (curi,metasenv',pbo,pty), [goal] + in + mk_tactic (rename ~from ~to_) + +let set_goal n = + ProofEngineTypes.mk_tactic + (fun (proof, goal) -> + let (_, metasenv, _, _) = proof in + if CicUtil.exists_meta n metasenv then + (proof, [n]) + else + raise (ProofEngineTypes.Fail (lazy ("no such meta: " ^ string_of_int n)))) diff --git a/helm/software/components/tactics/proofEngineStructuralRules.mli b/helm/software/components/tactics/proofEngineStructuralRules.mli new file mode 100644 index 000000000..91ebfecfb --- /dev/null +++ b/helm/software/components/tactics/proofEngineStructuralRules.mli @@ -0,0 +1,34 @@ +(* 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:string -> ProofEngineTypes.tactic +val clear: hyp:string -> ProofEngineTypes.tactic + +(* Warning: this tactic has no effect on the proof term. + It just changes the name of an hypothesis in the current sequent *) +val rename: from:string -> to_:string -> ProofEngineTypes.tactic + + (* change the current goal to those referred by the given meta number *) +val set_goal: int -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/proofEngineTypes.ml b/helm/software/components/tactics/proofEngineTypes.ml new file mode 100644 index 000000000..68ea561f9 --- /dev/null +++ b/helm/software/components/tactics/proofEngineTypes.ml @@ -0,0 +1,101 @@ +(* 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/. + *) + +(* $Id$ *) + + (** + current proof (proof uri * metas * (in)complete proof * term to be prooved) + *) +type proof = UriManager.uri option * Cic.metasenv * Cic.term * Cic.term + (** current goal, integer index *) +type goal = int +type status = proof * goal + +let initial_status ty metasenv = + let rec aux max = function + | [] -> max + 1 + | (idx, _, _) :: tl -> + if idx > max then + aux idx tl + else + aux max tl + in + let newmeta_idx = aux 0 metasenv in + let proof = + None, (newmeta_idx, [], ty) :: metasenv, Cic.Meta (newmeta_idx, []), ty + in + (proof, newmeta_idx) + + (** + 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 list + + (** creates an opaque tactic from a status->proof*goal list function *) +let mk_tactic t = t + +type reduction = Cic.context -> Cic.term -> Cic.term + +let const_lazy_term t = + (fun _ metasenv ugraph -> t, metasenv, ugraph) + +type lazy_reduction = + Cic.context -> Cic.metasenv -> CicUniv.universe_graph -> + reduction * Cic.metasenv * CicUniv.universe_graph + +let const_lazy_reduction red = + (fun _ metasenv ugraph -> red, metasenv, ugraph) + +type ('term, 'lazy_term) pattern = + 'lazy_term option * (string * 'term) list * 'term option + +type lazy_pattern = (Cic.term, Cic.lazy_term) pattern + +let conclusion_pattern t = + let t' = + match t with + | None -> None + | Some t -> Some (fun _ m u -> t, m, u) + in + t',[],Some (Cic.Implicit (Some `Hole)) + + (** tactic failure *) +exception Fail of string Lazy.t + + (** + calls the opaque tactic on the status, restoring the original + universe graph if the tactic Fails + *) +let apply_tactic t status = + t status + + (** constraint: the returned value will always be constructed by Cic.Name **) +type mk_fresh_name_type = + Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name + +let goals_of_proof (_,metasenv,_,_) = List.map (fun (g,_,_) -> g) metasenv + diff --git a/helm/software/components/tactics/proofEngineTypes.mli b/helm/software/components/tactics/proofEngineTypes.mli new file mode 100644 index 000000000..4396ea78f --- /dev/null +++ b/helm/software/components/tactics/proofEngineTypes.mli @@ -0,0 +1,76 @@ +(* 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 option * Cic.metasenv * Cic.term * Cic.term + (** current goal, integer index *) +type goal = int +type status = proof * goal + + (** @param goal + * @param goal's metasenv + * @return initial proof status for the given goal *) +val initial_status: Cic.term -> Cic.metasenv -> status + + (** + 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 +val mk_tactic: (status -> proof * goal list) -> tactic + +type reduction = Cic.context -> Cic.term -> Cic.term + +val const_lazy_term: Cic.term -> Cic.lazy_term + +type lazy_reduction = + Cic.context -> Cic.metasenv -> CicUniv.universe_graph -> + reduction * Cic.metasenv * CicUniv.universe_graph + +val const_lazy_reduction: reduction -> lazy_reduction + + (** what, hypothesis patterns, conclusion pattern *) +type ('term, 'lazy_term) pattern = + 'lazy_term option * (string * 'term) list * 'term option + +type lazy_pattern = (Cic.term, Cic.lazy_term) pattern + + (** conclusion_pattern [t] returns the pattern (t,[],%) *) +val conclusion_pattern : Cic.term option -> lazy_pattern + + (** tactic failure *) +exception Fail of string Lazy.t + +val apply_tactic: tactic -> status -> proof * goal list + + (** constraint: the returned value will always be constructed by Cic.Name **) +type mk_fresh_name_type = + Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name + +val goals_of_proof: proof -> goal list + diff --git a/helm/software/components/tactics/reductionTactics.ml b/helm/software/components/tactics/reductionTactics.ml new file mode 100644 index 000000000..115faa80b --- /dev/null +++ b/helm/software/components/tactics/reductionTactics.ml @@ -0,0 +1,220 @@ +(* 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/. + *) + +(* $Id$ *) + +open ProofEngineTypes + +(* Note: this code is almost identical to change_tac and +* it could be unified by making the change function a callback *) +let reduction_tac ~reduction ~pattern (proof,goal) = + let curi,metasenv,pbo,pty = proof in + let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in + let change subst where terms metasenv ugraph = + if terms = [] then where, metasenv, ugraph + else + let pairs, metasenv, ugraph = + List.fold_left + (fun (pairs, metasenv, ugraph) (context, t) -> + let reduction, metasenv, ugraph = reduction context metasenv ugraph in + ((t, reduction context t) :: pairs), metasenv, ugraph) + ([], metasenv, ugraph) + terms + in + let terms, terms' = List.split pairs in + let where' = + ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms' + ~where:where + in + CicMetaSubst.apply_subst subst where', metasenv, ugraph + in + let (subst,metasenv,ugraph,selected_context,selected_ty) = + ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph + ~conjecture ~pattern + in + let ty', metasenv, ugraph = change subst ty selected_ty metasenv ugraph in + let context', metasenv, ugraph = + List.fold_right2 + (fun entry selected_entry (context', metasenv, ugraph) -> + match entry,selected_entry with + None,None -> None::context', metasenv, ugraph + | Some (name,Cic.Decl ty),Some (`Decl selected_ty) -> + let ty', metasenv, ugraph = + change subst ty selected_ty metasenv ugraph + in + Some (name,Cic.Decl ty')::context', metasenv, ugraph + | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) -> + let bo', metasenv, ugraph = + change subst bo selected_bo metasenv ugraph + in + let ty', metasenv, ugraph = + match ty,selected_ty with + None,None -> None, metasenv, ugraph + | Some ty,Some selected_ty -> + let ty', metasenv, ugraph = + change subst ty selected_ty metasenv ugraph + in + Some ty', metasenv, ugraph + | _,_ -> assert false + in + (Some (name,Cic.Def (bo',ty'))::context'), metasenv, ugraph + | _,_ -> assert false + ) context selected_context ([], metasenv, ugraph) 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 ~pattern = + mk_tactic (reduction_tac + ~reduction:(const_lazy_reduction ProofEngineReduction.simpl) ~pattern) + +let reduce_tac ~pattern = + mk_tactic (reduction_tac + ~reduction:(const_lazy_reduction ProofEngineReduction.reduce) ~pattern) + +let unfold_tac what ~pattern = + let reduction = + match what with + | None -> const_lazy_reduction (ProofEngineReduction.unfold ?what:None) + | Some lazy_term -> + (fun context metasenv ugraph -> + let what, metasenv, ugraph = lazy_term context metasenv ugraph in + ProofEngineReduction.unfold ~what, metasenv, ugraph) + in + mk_tactic (reduction_tac ~reduction ~pattern) + +let whd_tac ~pattern = + mk_tactic (reduction_tac + ~reduction:(const_lazy_reduction CicReduction.whd) ~pattern) + +let normalize_tac ~pattern = + mk_tactic (reduction_tac + ~reduction:(const_lazy_reduction CicReduction.normalize) ~pattern) + +exception NotConvertible + +(* Note: this code is almost identical to reduction_tac and +* it could be unified by making the change function a callback *) +(* CSC: with_what is parsed in the context of the goal, but it should replace + something that lives in a completely different context. Thus we + perform a delift + lift phase to move it in the right context. However, + in this way the tactic is less powerful than expected: with_what cannot + reference variables that are local to the term that is going to be + replaced. To fix this we should parse with_what in the context of the + term(s) to be replaced. *) +let change_tac ~pattern with_what = + let change_tac ~pattern ~with_what (proof, goal) = + let curi,metasenv,pbo,pty = proof in + let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in + let change subst where terms metasenv ugraph = + if terms = [] then where, metasenv, ugraph + else + let pairs, metasenv, ugraph = + List.fold_left + (fun (pairs, metasenv, ugraph) (context_of_t, t) -> + let with_what, metasenv, ugraph = + with_what context_of_t metasenv ugraph + in + let _,u = + CicTypeChecker.type_of_aux' metasenv context_of_t with_what ugraph + in + let b,_ = + CicReduction.are_convertible ~metasenv context_of_t t with_what u + in + if b then + ((t, with_what) :: pairs), metasenv, ugraph + else + raise NotConvertible) + ([], metasenv, ugraph) + terms + in + let terms, terms' = List.split pairs in + let where' = + ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms' + ~where:where + in + CicMetaSubst.apply_subst subst where', metasenv, ugraph + in + let (subst,metasenv,ugraph,selected_context,selected_ty) = + ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph ~conjecture + ~pattern in + let ty', metasenv, ugraph = change subst ty selected_ty metasenv ugraph in + let context', metasenv, ugraph = + List.fold_right2 + (fun entry selected_entry (context', metasenv, ugraph) -> + match entry,selected_entry with + None,None -> (None::context'), metasenv, ugraph + | Some (name,Cic.Decl ty),Some (`Decl selected_ty) -> + let ty', metasenv, ugraph = + change subst ty selected_ty metasenv ugraph + in + (Some (name,Cic.Decl ty')::context'), metasenv, ugraph + | Some (name,Cic.Def (bo,ty)),Some (`Def (selected_bo,selected_ty)) -> + let bo', metasenv, ugraph = + change subst bo selected_bo metasenv ugraph + in + let ty', metasenv, ugraph = + match ty,selected_ty with + None,None -> None, metasenv, ugraph + | Some ty,Some selected_ty -> + let ty', metasenv, ugraph = + change subst ty selected_ty metasenv ugraph + in + Some ty', metasenv, ugraph + | _,_ -> assert false + in + (Some (name,Cic.Def (bo',ty'))::context'), metasenv, ugraph + | _,_ -> assert false + ) context selected_context ([], metasenv, ugraph) in + let metasenv' = + List.map + (function + | (n,_,_) when n = metano -> (metano,context',ty') + | _ as t -> t) + metasenv + in + (curi,metasenv',pbo,pty), [metano] + in + mk_tactic (change_tac ~pattern ~with_what) + +let fold_tac ~reduction ~term ~pattern = + let fold_tac ~reduction ~term ~pattern:(wanted,hyps_pat,concl_pat) status = + assert (wanted = None); (* this should be checked syntactically *) + let reduced_term = + (fun context metasenv ugraph -> + let term, metasenv, ugraph = term context metasenv ugraph in + let reduction, metasenv, ugraph = reduction context metasenv ugraph in + reduction context term, metasenv, ugraph) + in + apply_tactic + (change_tac ~pattern:(Some reduced_term,hyps_pat,concl_pat) term) status + in + mk_tactic (fold_tac ~reduction ~term ~pattern) + diff --git a/helm/software/components/tactics/reductionTactics.mli b/helm/software/components/tactics/reductionTactics.mli new file mode 100644 index 000000000..16e2bc23c --- /dev/null +++ b/helm/software/components/tactics/reductionTactics.mli @@ -0,0 +1,47 @@ +(* 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 simpl_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val reduce_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val whd_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val normalize_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic + +(* The default of term is the thesis of the goal to be prooved *) +val unfold_tac: + Cic.lazy_term option -> + pattern:ProofEngineTypes.lazy_pattern -> + ProofEngineTypes.tactic + +val change_tac: + pattern:ProofEngineTypes.lazy_pattern -> + Cic.lazy_term -> + ProofEngineTypes.tactic + +val fold_tac: + reduction:ProofEngineTypes.lazy_reduction -> + term:Cic.lazy_term -> + pattern:ProofEngineTypes.lazy_pattern -> + ProofEngineTypes.tactic + diff --git a/helm/software/components/tactics/ring.ml b/helm/software/components/tactics/ring.ml new file mode 100644 index 000000000..4c58f1004 --- /dev/null +++ b/helm/software/components/tactics/ring.ml @@ -0,0 +1,596 @@ +(* 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/. + *) + +(* $Id$ *) + +open CicReduction +open PrimitiveTactics +open ProofEngineTypes +open UriManager + +(** DEBUGGING *) + + (** perform debugging output? *) +let debug = false +let debug_print = fun _ -> () + + (** debugging print *) +let warn s = debug_print (lazy ("RING WARNING: " ^ (Lazy.force 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 equality_is_a_congruence_A = + uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var" +let equality_is_a_congruence_x = + uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var" +let equality_is_a_congruence_y = + uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var" + +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 status current proof engine status + @raise Failure if proof is None + @return current goal's metasenv + *) +let metasenv_of_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 = + let (proof, goal) = status in + let metasenv = metasenv_of_status status in + let _, context, _ = CicUtil.lookup_meta 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 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 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 HelmLibraryObjects.Logic.eq_URI) -> true + | _ -> false + in + let is_real = function + | Cic.Const (uri, _) when (eq uri HelmLibraryObjects.Reals.r_URI) -> true + | _ -> false + in + function + | Cic.Appl (app::set::_::_::[]) when (is_equality app && is_real set) -> + warn (lazy "Goal Ringable!"); + true + | _ -> + warn (lazy "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 (lazy ("" ^ (CicPp.ppterm t1) ^ "")); + warn (lazy ("" ^ (CicPp.ppterm t2) ^ "")); + (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 = HelmLibraryObjects.Reals.r in + 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 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 HelmLibraryObjects.Reals.rplus_URI) bop) -> (* +. *) + Cic.Appl [mkCtor applus_uri []; aux t1; aux t2] + | Cic.Appl (bop::t1::t2::[]) + when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.rmult_URI) bop) -> (* *. *) + Cic.Appl [mkCtor apmult_uri []; aux t1; aux t2] + | Cic.Appl (uop::t::[]) + when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.ropp_URI) uop) -> (* ~-. *) + Cic.Appl [mkCtor apopp_uri []; aux t] + | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.r0_URI) t) -> (* 0. *) + mkCtor ap0_uri [] + | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.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 theory_args_subst varmap = + [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ; + abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ; + abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ; + abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ; + abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ; + abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.ropp ; + abstract_rings_vm_uri, varmap] in + let theory_args_subst' eq varmap t = + [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ; + abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ; + abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ; + abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ; + abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ; + abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.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 lxy_false = (** Cic funcion "fun (x,y):R -> false" *) + Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, + Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, HelmLibraryObjects.Datatypes.falseb)) + 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 HelmLibraryObjects.Reals.rtheory ; t] + ) aterms + + +let status_of_single_goal_tactic_result = + function + proof,[goal] -> proof,goal + | _ -> + raise (Fail (lazy "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 (lazy "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 + *) +(* FG: METTERE I NOMI ANCHE QUI? *) +let elim_type2_tac ~term ~proof = + let elim_type2_tac ~term ~proof status = + let module E = EliminationTactics in + warn (lazy "in Ring.elim_type2"); + ProofEngineTypes.apply_tactic + (Tacticals.thens ~start:(E.elim_type_tac term) + ~continuations:[Tacticals.id_tac ; exact_tac ~term:proof]) status + in + ProofEngineTypes.mk_tactic (elim_type2_tac ~term ~proof) + +(* 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 (proof, goal) = + warn (lazy "in Ring.reflexivity_tac"); + let refl_eqt = mkCtor ~uri:refl_eqt_uri ~exp_named_subst:[] in + try + apply_tac (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 = + let purge_hyps_tac ~count status = + let module S = ProofEngineStructuralRules in + let (proof, goal) = status in + let rec aux n context status = + assert(n>=0); + match (n, context) with + | (0, _) -> status + | (n, hd::tl) -> + let name_of_hyp = + match hd with + None + | Some (Cic.Anonymous,_) -> assert false + | Some (Cic.Name name,_) -> name + in + aux (n-1) tl + (status_of_single_goal_tactic_result + (ProofEngineTypes.apply_tactic (S.clear ~hyp:name_of_hyp) status)) + | (_, []) -> failwith "Ring.purge_hyps_tac: no hypotheses left" + in + let (_, metasenv, _, _) = proof in + let (_, context, _) = CicUtil.lookup_meta goal metasenv in + let proof',goal' = aux count context status in + assert (goal = goal') ; + proof',[goal'] + in + ProofEngineTypes.mk_tactic (purge_hyps_tac ~count) + +(** THE TACTIC! *) + + (** + Ring tactic, does associative and commutative rewritings in Reals ring + @param status current proof engine status + *) + +let ring_tac status = + let (proof, goal) = status in + warn (lazy "in Ring tactic"); + let eqt = mkMutInd (HelmLibraryObjects.Logic.eq_URI, 0) [] in + let r = HelmLibraryObjects.Reals.r in + let metasenv = metasenv_of_status status in + let (metano, context, ty) = CicUtil.lookup_meta 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 + if debug then + List.iter (* debugging, feel free to remove *) + (fun (descr, term) -> + warn (lazy (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 *) + ProofEngineTypes.apply_tactic + (Tacticals.first + ~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 HelmLibraryObjects.Logic.sym_eq_URI + [equality_is_a_congruence_A, HelmLibraryObjects.Reals.r; + equality_is_a_congruence_x, t1'' ; + equality_is_a_congruence_y, t1 + ] ; + t1'_eq_t1'' + ]) ; + "elim_type eqt su t1 ...", ProofEngineTypes.mk_tactic (fun status -> + let status' = (* status after 1st elim_type use *) + let context = context_of_status status in + let b,_ = (*TASSI : FIXME*) + are_convertible context t1'' t1 CicUniv.empty_ugraph in + if not b then begin + warn (lazy "t1'' and t1 are NOT CONVERTIBLE"); + let newstatus = + ProofEngineTypes.apply_tactic + (elim_type2_tac (* 1st elim_type use *) + ~proof:t1'_eq_t1'' + ~term:(Cic.Appl [eqt; r; t1''; t1])) + status + in + incr new_hyps; (* elim_type add an hyp *) + match newstatus with + (proof,[goal]) -> proof,goal + | _ -> assert false + end else begin + warn (lazy "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'' = + ProofEngineTypes.apply_tactic + (Tacticals.first (* try to solve 1st subgoal *) + ~tactics:[ + "exact t2'_eq_t2''", exact_tac ~term:t2'_eq_t2''; + "exact sym_eqt su t2 ...", + exact_tac + ~term:( + Cic.Appl + [mkConst HelmLibraryObjects.Logic.sym_eq_URI + [equality_is_a_congruence_A, HelmLibraryObjects.Reals.r; + equality_is_a_congruence_x, t2'' ; + equality_is_a_congruence_y, t2 + ] ; + t2'_eq_t2'' + ]) ; + "elim_type eqt su t2 ...", + ProofEngineTypes.mk_tactic (fun status -> + let status' = + let context = context_of_status status in + let b,_ = (* TASSI:FIXME *) + are_convertible context t2'' t2 CicUniv.empty_ugraph + in + if not b then begin + warn (lazy "t2'' and t2 are NOT CONVERTIBLE"); + let newstatus = + ProofEngineTypes.apply_tactic + (elim_type2_tac (* 2nd elim_type use *) + ~proof:t2'_eq_t2'' + ~term:(Cic.Appl [eqt; r; t2''; t2])) + status + in + incr new_hyps; (* elim_type add an hyp *) + match newstatus with + (proof,[goal]) -> proof,goal + | _ -> assert false + end else begin + warn (lazy "t2'' and t2 are CONVERTIBLE"); + status + end + in + try (* try to solve main goal *) + warn (lazy "trying reflexivity ...."); + ProofEngineTypes.apply_tactic + EqualityTactics.reflexivity_tac status' + with (Fail _) -> (* leave conclusion to the user *) + warn (lazy "reflexivity failed, solution's left as an ex :-)"); + ProofEngineTypes.apply_tactic + (purge_hyps_tac ~count:!new_hyps) status')]) + status' + in + status'')]) + status + with (Fail s) -> + raise (Fail (lazy ("Ring failure: " ^ Lazy.force 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 (lazy "goal unringable")) + +let ring_tac = ProofEngineTypes.mk_tactic ring_tac + diff --git a/helm/software/components/tactics/ring.mli b/helm/software/components/tactics/ring.mli new file mode 100644 index 000000000..b6eb34b69 --- /dev/null +++ b/helm/software/components/tactics/ring.mli @@ -0,0 +1,12 @@ + + (* 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 +*) diff --git a/helm/software/components/tactics/statefulProofEngine.ml b/helm/software/components/tactics/statefulProofEngine.ml new file mode 100644 index 000000000..9529c897c --- /dev/null +++ b/helm/software/components/tactics/statefulProofEngine.ml @@ -0,0 +1,214 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let default_history_size = 20 + +exception No_goal_left +exception Uri_redefinition +type event = [ `Proof_changed | `Proof_completed ] +let all_events = [ `Proof_changed; `Proof_completed ] +let default_events: event list = [ `Proof_changed ] + +type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option + +type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit +type observer_id = int + +exception Observer_failures of (observer_id * exn) list +exception Tactic_failure of exn +exception Data_failure of exn + +class ['a] status + ?(history_size = default_history_size) + ?uri ~typ ~body ~metasenv init_data compute_data () + = + let next_observer_id = + let next_id = ref 0 in + fun () -> + incr next_id; + !next_id + in + let initial_proof = ((uri: UriManager.uri option), metasenv, body, typ) in + let next_goal (goals, proof) = + match goals, proof with + | goal :: _, _ -> Some goal + | [], (_, (goal, _, _) :: _, _, _) -> + (* the tactic left no open goal: let's choose the first open goal *) + Some goal + | _, _ -> None + in + let initial_goal = next_goal ([], initial_proof) in + object (self) + + val mutable _proof = initial_proof + val mutable _goal = initial_goal + val mutable _data: 'a = init_data (initial_proof, initial_goal) + + (* event -> (id, observer) list *) + val observers = Hashtbl.create 7 + + (* assumption: all items in history are uncompleted proofs, thus option on + * goal could be ignored and goal are stored as bare integers *) + val history = new History.history history_size + + initializer + history#push self#internal_status + + method proof = _proof + method private status = (_proof, _goal) (* logic status *) + method private set_status (proof, (goal: int option)) = + _proof <- proof; + _goal <- goal + + method goal = + match _goal with + | Some goal -> goal + | None -> raise No_goal_left + + (* what will be kept in history *) + method private internal_status = (self#status, _data) + method private set_internal_status (status, data) = + self#set_status status; + _data <- data + + method set_goal goal = + _goal <- Some goal +(* + let old_internal_status = self#internal_status in + _goal <- Some goal; + try + self#update_data old_internal_status; + history#push self#internal_status; + self#private_notify (Some old_internal_status) + with (Data_failure _) as exn -> + self#set_internal_status old_internal_status; + raise exn +*) + + method uri = let (uri, _, _, _) = _proof in uri + method metasenv = let (_, metasenv, _, _) = _proof in metasenv + method body = let (_, _, body, _) = _proof in body + method typ = let (_, _, _, typ) = _proof in typ + + method set_metasenv metasenv = + let (uri, _, body, typ) = _proof in + _proof <- (uri, metasenv, body, typ) + + method set_uri uri = + let (old_uri, metasenv, body, typ) = _proof in + if old_uri <> None then + raise Uri_redefinition; + _proof <- (Some uri, metasenv, body, typ) + + method conjecture goal = + let (_, metasenv, _, _) = _proof in + CicUtil.lookup_meta goal metasenv + + method apply_tactic tactic = + let old_internal_status = self#internal_status in + let (new_proof, new_goals) = + try + ProofEngineTypes.apply_tactic tactic (_proof, self#goal) + with exn -> raise (Tactic_failure exn) + in + _proof <- new_proof; + _goal <- next_goal (new_goals, new_proof); + try + self#update_data old_internal_status; + history#push self#internal_status; + self#private_notify (Some old_internal_status) + with (Data_failure _) as exn -> + self#set_internal_status old_internal_status; + raise exn + + method proof_completed = _goal = None + + method attach_observer ?(interested_in = default_events) observer + = + let id = next_observer_id () in + List.iter + (fun event -> + let prev_observers = + try Hashtbl.find observers event with Not_found -> [] + in + Hashtbl.replace observers event ((id, observer)::prev_observers)) + interested_in; + id + + method detach_observer id = + List.iter + (fun event -> + let prev_observers = + try Hashtbl.find observers event with Not_found -> [] + in + let new_observers = + List.filter (fun (id', _) -> id' <> id) prev_observers + in + Hashtbl.replace observers event new_observers) + all_events + + method private private_notify old_internal_status = + let cur_internal_status = (self#status, _data) in + let exns = ref [] in + let notify (id, observer) = + try + observer old_internal_status cur_internal_status + with exn -> exns := (id, exn) :: !exns + in + List.iter notify + (try Hashtbl.find observers `Proof_changed with Not_found -> []); + if self#proof_completed then + List.iter notify + (try Hashtbl.find observers `Proof_completed with Not_found -> []); + match !exns with + | [] -> () + | exns -> raise (Observer_failures exns) + + method private update_data old_internal_status = + (* invariant: _goal and/or _proof has been changed + * invariant: proof is not yet completed *) + let status = self#status in + try + _data <- compute_data old_internal_status status + with exn -> raise (Data_failure exn) + + method undo ?(steps = 1) () = + let ((proof, goal), data) = history#undo steps in + _proof <- proof; + _goal <- goal; + _data <- data; + self#private_notify None + + method redo ?(steps = 1) () = self#undo ~steps:~-steps () + + method notify = self#private_notify None + + end + +let trivial_status ?uri ~typ ~body ~metasenv () = + new status ?uri ~typ ~body ~metasenv (fun _ -> ()) (fun _ _ -> ()) () + diff --git a/helm/software/components/tactics/statefulProofEngine.mli b/helm/software/components/tactics/statefulProofEngine.mli new file mode 100644 index 000000000..4198876ca --- /dev/null +++ b/helm/software/components/tactics/statefulProofEngine.mli @@ -0,0 +1,120 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(** Stateful handling of proof status *) + +exception No_goal_left +exception Uri_redefinition + +type event = [ `Proof_changed | `Proof_completed ] + +val all_events: event list + + (** from our point of view a status is the status of an incomplete proof, thus + * we have an optional goal which is None if the proof is not yet completed + * (i.e. some goal is still open) *) +type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option + + (** Proof observer. First callback argument is Some extended_status + * when a 'real 'change of the proof happened and None when Proof_changed event + * was triggered by a time travel by the means of undo/redo actions or by an + * external "#notify" invocation. Embedded status is the status _before_ the + * current change. Second status is the status reached _after_ the current + * change. *) +type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit + + (** needed to detach previously attached observers *) +type observer_id + + (** tactic application failed. @see apply_tactic *) +exception Tactic_failure of exn + + (** one or more observers failed. @see apply_tactic *) +exception Observer_failures of (observer_id * exn) list + + (** failure while updating internal data (: 'a). @see apply_tactic *) +exception Data_failure of exn + +(** {2 OO interface} *) + +class ['a] status: + ?history_size:int -> (** default 20 *) + ?uri:UriManager.uri -> + typ:Cic.term -> body:Cic.term -> metasenv:Cic.metasenv -> + (proof_status -> 'a) -> (* init data *) + (proof_status * 'a -> proof_status -> 'a) -> (* update data *) + unit -> + object + + method proof: ProofEngineTypes.proof + method metasenv: Cic.metasenv + method body: Cic.term + method typ: Cic.term + + (** change metasenv _without_ triggering any notification *) + method set_metasenv: Cic.metasenv -> unit + + (** goal -> conjecture + * @raise CicUtil.Meta_not_found *) + method conjecture: int -> Cic.conjecture + + method proof_completed: bool + method goal: int (** @raise No_goal_left *) + method set_goal: int -> unit (** @raise Data_failure *) + + method uri: UriManager.uri option + method set_uri: UriManager.uri -> unit (** @raise Uri_redefinition *) + + (** @raise Tactic_failure + * @raise Observer_failures + * @raise Data_failure + * + * In case of tactic failure, internal status is left unchanged. + * In case of observer failures internal status will be changed and is + * granted that all observer will be invoked collecting their failures. + * In case of data failure, internal status is left unchanged (rolling back + * last tactic application if needed) + *) + method apply_tactic: ProofEngineTypes.tactic -> unit + + method undo: ?steps:int -> unit -> unit + method redo: ?steps:int -> unit -> unit + + method attach_observer: + ?interested_in:(event list) -> 'a observer -> observer_id + + method detach_observer: observer_id -> unit + + (** force a notification to all observer, old status is passed as None *) + method notify: unit + + end + +val trivial_status: + ?uri:UriManager.uri -> + typ:Cic.term -> body:Cic.term -> metasenv:Cic.metasenv -> + unit -> + unit status + diff --git a/helm/software/components/tactics/tacticChaser.ml b/helm/software/components/tactics/tacticChaser.ml new file mode 100644 index 000000000..cb700f776 --- /dev/null +++ b/helm/software/components/tactics/tacticChaser.ml @@ -0,0 +1,259 @@ +(* 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 *) +(* 18/02/2003 *) +(* *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +module MQI = MQueryInterpreter +module MQIC = MQIConn +module I = MQueryInterpreter +module U = MQGUtil +module G = MQueryGenerator + + (* search arguments on which Apply tactic doesn't fail *) +let matchConclusion mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status = + let ((_, metasenv, _, _), metano) = status in + let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in + let list_of_must, only = CGMatchConclusion.get_constraints metasenv ey ty in +match list_of_must with + [] -> [] +|_ -> + let must = choose_must list_of_must only in + let result = + I.execute mqi_handle + (G.query_of_constraints + (Some CGMatchConclusion.universe) + (must,[],[]) (Some only,None,None)) in + let uris = + List.map + (function uri,_ -> + MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri + ) result + in + let uris = + (* TODO ristretto per ragioni di efficienza *) + prerr_endline "STO FILTRANDO"; + List.filter (fun uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris + in + prerr_endline "HO FILTRATO"; + let uris',exc = + let rec filter_out = + function + [] -> [],"" + | uri::tl -> + let tl',exc = filter_out tl in + try + if + let time = Unix.gettimeofday() in + (try + ignore(ProofEngineTypes.apply_tactic + (PrimitiveTactics.apply_tac + ~term:(MQueryMisc.term_of_cic_textual_parser_uri + (MQueryMisc.cic_textual_parser_uri_of_string uri))) + status); + let time1 = Unix.gettimeofday() in + prerr_endline (Printf.sprintf "%1.3f" (time1 -. time) ); + true + with ProofEngineTypes.Fail _ -> + let time1 = Unix.gettimeofday() in + prerr_endline (Printf.sprintf "%1.3f" (time1 -. time)); false) + then + uri::tl',exc + else + tl',exc + with + (ProofEngineTypes.Fail _) as e -> + let exc' = + "

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

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

    Objects that can actually be applied:

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

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

    " ^ + "

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

    " + in + output_html html' ; + uris' +;; + + +(*matchConclusion modificata per evitare una doppia apply*) +let matchConclusion2 mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status = + let ((_, metasenv, _, _), metano) = status in + let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in + let conn = + match mqi_handle.MQIConn.pgc with + MQIConn.MySQL_C conn -> conn + | _ -> assert false in + let uris = Match_concl.cmatch conn ty in + (* List.iter + (fun (n,u) -> prerr_endline ((string_of_int n) ^ " " ^u)) uris; *) + (* delete all .var uris *) + let uris = List.filter UriManager.is_var uris in + (* delete all not "cic:/Coq" uris *) + (* + let uris = + (* TODO ristretto per ragioni di efficienza *) + List.filter (fun _,uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris in + *) + (* concl_cost are the costants in the conclusion of the proof + while hyp_const are the constants in the hypothesis *) + let (main_concl,concl_const) = NewConstraints.mainandcons ty in + prerr_endline ("Ne sono rimasti" ^ string_of_int (List.length uris)); + let hyp t set = + match t with + Some (_,Cic.Decl t) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t)) + | Some (_,Cic.Def (t,_)) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t)) + | _ -> set in + let hyp_const = + List.fold_right hyp ey NewConstraints.StringSet.empty in + prerr_endline (NewConstraints.pp_StringSet (NewConstraints.StringSet.union hyp_const concl_const)); + (* uris with new constants in the proof are filtered *) + let all_const = NewConstraints.StringSet.union hyp_const concl_const in + let uris = + if (List.length uris < (Filter_auto.power 2 (List.length (NewConstraints.StringSet.elements all_const)))) + then + (prerr_endline("metodo vecchio");List.filter (Filter_auto.filter_new_constants conn all_const) uris) + else Filter_auto.filter_uris conn all_const uris main_concl in +(* + let uris = + (* ristretto all cache *) + prerr_endline "SOLO CACHE"; + List.filter + (fun uri -> CicEnvironment.in_cache (UriManager.uri_of_string uri)) uris + in + prerr_endline "HO FILTRATO2"; +*) + let uris = + List.map + (fun (n,u) -> + (n,MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' u)) + uris in + let uris' = + let rec filter_out = + function + [] -> [] + | (m,uri)::tl -> + let tl' = filter_out tl in + try + prerr_endline ("STO APPLICANDO " ^ uri); + let res = (m, + (ProofEngineTypes.apply_tactic( PrimitiveTactics.apply_tac + ~term:(MQueryMisc.term_of_cic_textual_parser_uri + (MQueryMisc.cic_textual_parser_uri_of_string uri))) + status))::tl' in + prerr_endline ("OK");res + (* with ProofEngineTypes.Fail _ -> tl' *) + (* patch to cover CSC's exportation bug *) + with _ -> prerr_endline ("FAIL");tl' + in + prerr_endline ("Ne sono rimasti 2 " ^ string_of_int (List.length uris)); + filter_out uris + in + prerr_endline ("Ne sono rimasti 3 " ^ string_of_int (List.length uris')); + + uris' +;; + +(*funzione che sceglie il penultimo livello di profondita' dei must*) + +(* +let choose_must list_of_must only= +let n = (List.length list_of_must) - 1 in + List.nth list_of_must n +;;*) + +(* questa prende solo il main *) +let choose_must list_of_must only = + List.nth list_of_must 0 + +(* livello 1 +let choose_must list_of_must only = + try + List.nth list_of_must 1 + with _ -> + List.nth list_of_must 0 *) + +let searchTheorems mqi_handle (proof,goal) = + let subproofs = + matchConclusion2 mqi_handle ~choose_must() (proof, goal) in + let res = + List.sort + (fun (n1,(_,gl1)) (n2,(_,gl2)) -> + let l1 = List.length gl1 in + let l2 = List.length gl2 in + (* if the list of subgoals have the same lenght we use the + prefix tag, where higher tags have precedence *) + if l1 = l2 then n2 - n1 + else l1 - l2) + subproofs + in + (* now we may drop the prefix tag *) + (*let res' = + List.map snd res in*) + let order_goal_list proof goal1 goal2 = + let _,metasenv,_,_ = proof in + let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in + let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in +(* + prerr_endline "PRIMA DELLA PRIMA TYPE OF " ; +*) + let ty_sort1,u = (*TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.empty_ugraph in +(* + prerr_endline (Printf.sprintf "PRIMA DELLA SECONDA TYPE OF %s \n### %s @@@%s " (CicMetaSubst.ppmetasenv metasenv []) (CicMetaSubst.ppcontext [] ey2) (CicMetaSubst.ppterm [] ty2)); +*) + let ty_sort2,u1 = CicTypeChecker.type_of_aux' metasenv ey2 ty2 u in +(* + prerr_endline "DOPO LA SECONDA TYPE OF " ; +*) + let b,u2 = + CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1 u1 in + let prop1 = if b then 0 else 1 in + let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2 u2 in + let prop2 = if b then 0 else 1 in + prop1 - prop2 in + List.map ( + fun (level,(proof,goallist)) -> + (proof, (List.stable_sort (order_goal_list proof) goallist)) + ) res +;; + diff --git a/helm/software/components/tactics/tacticals.ml b/helm/software/components/tactics/tacticals.ml new file mode 100644 index 000000000..a674fe313 --- /dev/null +++ b/helm/software/components/tactics/tacticals.ml @@ -0,0 +1,351 @@ +(* 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/. + *) + +(* $Id$ *) + +(* open CicReduction +open ProofEngineTypes +open UriManager *) + +(** DEBUGGING *) + + (** perform debugging output? *) +let debug = false +let debug_print = fun _ -> () + + (** debugging print *) +let info s = debug_print (lazy ("TACTICALS INFO: " ^ (Lazy.force s))) + +let id_tac = + let id_tac (proof,goal) = + let _, metasenv, _, _ = proof in + let _, _, _ = CicUtil.lookup_meta goal metasenv in + (proof,[goal]) + in + ProofEngineTypes.mk_tactic id_tac + +let fail_tac = + let fail_tac (proof,goal) = + let _, metasenv, _, _ = proof in + let _, _, _ = CicUtil.lookup_meta goal metasenv in + raise (ProofEngineTypes.Fail (lazy "fail tactical")) + in + ProofEngineTypes.mk_tactic fail_tac + +type goal = ProofEngineTypes.goal + + (** TODO needed until tactics start returning both opened and closed goals + * First part of the function performs a diff among goals ~before tactic + * application and ~after it. Second part will add as both opened and closed + * the goals which are returned as opened by the tactic *) +let goals_diff ~before ~after ~opened = + let sort_opened opened add = + opened @ (List.filter (fun g -> not (List.mem g opened)) add) + in + let remove = + List.fold_left + (fun remove e -> if List.mem e after then remove else e :: remove) + [] before + in + let add = + List.fold_left + (fun add e -> if List.mem e before then add else e :: add) + [] + after + in + let add, remove = (* adds goals which have been both opened _and_ closed *) + List.fold_left + (fun (add, remove) opened_goal -> + if List.mem opened_goal before + then opened_goal :: add, opened_goal :: remove + else add, remove) + (add, remove) + opened + in + sort_opened opened add, remove + +module type T = +sig + type tactic + val first: tactics: (string * tactic) list -> tactic + val thens: start: tactic -> continuations: tactic list -> tactic + val then_: start: tactic -> continuation: tactic -> tactic + val seq: tactics: tactic list -> tactic + val repeat_tactic: tactic: tactic -> tactic + val do_tactic: n: int -> tactic: tactic -> tactic + val try_tactic: tactic: tactic -> tactic + val solve_tactics: tactics: (string * tactic) list -> tactic + + val tactic: tactic -> tactic + val skip: tactic + val dot: tactic + val semicolon: tactic + val branch: tactic + val shift: tactic + val pos: int -> tactic + val merge: tactic + val focus: int list -> tactic + val unfocus: tactic +end + +module Make (S: Continuationals.Status) : T with type tactic = S.tactic = +struct + module C = Continuationals.Make (S) + + type tactic = S.tactic + + let fold_eval status ts = + let istatus = + List.fold_left (fun istatus t -> S.focus ~-1 (C.eval t istatus)) status ts + in + S.inject istatus + + (** + 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") + *) + let first ~tactics = + let rec first ~(tactics: (string * tactic) list) istatus = + info (lazy "in Tacticals.first"); + match tactics with + | (descr, tac)::tactics -> + info (lazy ("Tacticals.first IS TRYING " ^ descr)); + (try + let res = S.apply_tactic tac istatus in + info (lazy ("Tacticals.first: " ^ descr ^ " succedeed!!!")); + res + with + e -> + match e with + | (ProofEngineTypes.Fail _) + | (CicTypeChecker.TypeCheckerFailure _) + | (CicUnification.UnificationFailure _) -> + info (lazy ( + "Tacticals.first failed with exn: " ^ + Printexc.to_string e)); + first ~tactics istatus + | _ -> raise e) (* [e] must not be caught ; let's re-raise it *) + | [] -> raise (ProofEngineTypes.Fail (lazy "first: no tactics left")) + in + S.mk_tactic (first ~tactics) + + let thens ~start ~continuations = + S.mk_tactic + (fun istatus -> + fold_eval istatus + ([ C.Tactical (C.Tactic start); C.Branch ] + @ (HExtlib.list_concat ~sep:[ C.Shift ] + (List.map (fun t -> [ C.Tactical (C.Tactic t) ]) continuations)) + @ [ C.Merge ])) + + let then_ ~start ~continuation = + S.mk_tactic + (fun istatus -> + let ostatus = C.eval (C.Tactical (C.Tactic start)) istatus in + let opened,closed = S.goals ostatus in + match opened with + [] -> ostatus + | _ -> + fold_eval (S.focus ~-1 ostatus) + [ C.Semicolon; + C.Tactical (C.Tactic continuation) ]) + + let seq ~tactics = + S.mk_tactic + (fun istatus -> + fold_eval istatus + (HExtlib.list_concat ~sep:[ C.Semicolon ] + (List.map (fun t -> [ C.Tactical (C.Tactic t) ]) tactics))) + + (* TODO: x debug: i due tatticali seguenti non contano quante volte hanno + * applicato la tattica *) + + let rec step f output_status opened closed = + match opened with + | [] -> output_status, [], closed + | head :: tail -> + let status = S.focus head output_status in + let output_status' = f status in + let opened', closed' = S.goals output_status' in + let output_status'', opened'', closed'' = + step f output_status' tail [] + in + output_status'', opened' @ opened'', closed' @ closed'' + + (* This keep on appling tactic until it fails. When generates more + * than one goal, you have a tree of application on the tactic, repeat_tactic + * works in depth on this tree *) + let repeat_tactic ~tactic = + let rec repeat_tactic ~tactic status = + info (lazy "in repeat_tactic"); + try + let output_status = S.apply_tactic tactic status in + let opened, closed = S.goals output_status in + let output_status, opened', closed' = + step (repeat_tactic ~tactic) output_status opened closed + in + S.set_goals (opened', closed') output_status + with + (ProofEngineTypes.Fail _) as e -> + info (lazy + ("Tacticals.repeat_tactic failed after nth time with exception: " + ^ Printexc.to_string e)); + S.apply_tactic S.id_tactic status + in + S.mk_tactic (repeat_tactic ~tactic) + + (* This tries to apply tactic n times *) + let do_tactic ~n ~tactic = + let rec do_tactic ~n ~tactic status = + if n = 0 then + S.apply_tactic S.id_tactic status + else + try + let output_status = S.apply_tactic tactic status in + let opened, closed = S.goals output_status in + let output_status, opened', closed' = + step (do_tactic ~n:(n-1) ~tactic) output_status opened closed + in + S.set_goals (opened', closed') output_status + with + (ProofEngineTypes.Fail _) as e -> + info (lazy + ("Tacticals.do_tactic failed after nth time with exception: " + ^ Printexc.to_string e)) ; + S.apply_tactic S.id_tactic status + in + S.mk_tactic (do_tactic ~n ~tactic) + + (* This applies tactic and catches its possible failure *) + let try_tactic ~tactic = + let rec try_tactic ~tactic status = + info (lazy "in Tacticals.try_tactic"); + try + S.apply_tactic tactic status + with + (ProofEngineTypes.Fail _) as e -> + info (lazy ( + "Tacticals.try_tactic failed with exn: " ^ Printexc.to_string e)); + S.apply_tactic S.id_tactic status + in + S.mk_tactic (try_tactic ~tactic) + + (* This tries tactics until one of them doesn't _solve_ the goal *) + (* TODO: si puo' unificare le 2(due) chiamate ricorsive? *) + let solve_tactics ~tactics = + let rec solve_tactics ~(tactics: (string * tactic) list) status = + info (lazy "in Tacticals.solve_tactics"); + match tactics with + | (descr, currenttactic)::moretactics -> + info (lazy ("Tacticals.solve_tactics is trying " ^ descr)); + (try + let output_status = S.apply_tactic currenttactic status in + let opened, closed = S.goals output_status in + match opened with + | [] -> info (lazy ("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!) *) + output_status + | _ -> info (lazy ("Tacticals.solve_tactics: try the next tactic")); + solve_tactics ~tactics:(moretactics) status + with + (ProofEngineTypes.Fail _) as e -> + info (lazy ( + "Tacticals.solve_tactics: current tactic failed with exn: " + ^ Printexc.to_string e)); + solve_tactics ~tactics status + ) + | [] -> + raise (ProofEngineTypes.Fail + (lazy "solve_tactics cannot solve the goal")) + in + S.mk_tactic (solve_tactics ~tactics) + + let cont_proxy cont = S.mk_tactic (C.eval cont) + + let tactic t = cont_proxy (C.Tactical (C.Tactic t)) + let skip = cont_proxy (C.Tactical C.Skip) + let dot = cont_proxy C.Dot + let semicolon = cont_proxy C.Semicolon + let branch = cont_proxy C.Branch + let shift = cont_proxy C.Shift + let pos i = cont_proxy (C.Pos i) + let merge = cont_proxy C.Merge + let focus goals = cont_proxy (C.Focus goals) + let unfocus = cont_proxy C.Unfocus +end + +module ProofEngineStatus = +struct + module Stack = Continuationals.Stack + + type input_status = + ProofEngineTypes.status (* (proof, goal) *) * Stack.t + + type output_status = + (ProofEngineTypes.proof * goal list * goal list) * Stack.t + + type tactic = ProofEngineTypes.tactic + + let id_tactic = id_tac + + let mk_tactic f = + ProofEngineTypes.mk_tactic + (fun (proof, goal) as pstatus -> + let stack = [ [ 1, Stack.Open goal ], [], [], `NoTag ] in + let istatus = pstatus, stack in +(* let ostatus = f istatus in + let ((proof, opened, _), _) = ostatus in *) + let (proof, _, _), stack = f istatus in + let opened = Continuationals.Stack.open_goals stack in + proof, opened) + + let apply_tactic tac ((proof, _) as pstatus, stack) = + let proof', opened = ProofEngineTypes.apply_tactic tac pstatus in +(* let _ = prerr_endline ("goal aperti dalla tattica " ^ String.concat "," (List.map string_of_int opened)) in *) + let before = ProofEngineTypes.goals_of_proof proof in + let after = ProofEngineTypes.goals_of_proof proof' in + let opened_goals, closed_goals = goals_diff ~before ~after ~opened in +(* let _ = prerr_endline ("goal ritornati dalla tattica " ^ String.concat "," (List.map string_of_int opened_goals)) in *) + (proof', opened_goals, closed_goals), stack + + let goals ((_, opened, closed), _) = opened, closed + let set_goals (opened, closed) ((proof, _, _), stack) = + (proof, opened, closed), stack + + let get_stack = snd + let set_stack stack (opstatus, _) = opstatus, stack + + let inject ((proof, _), stack) = ((proof, [], []), stack) + let focus goal ((proof, _, _), stack) = (proof, goal), stack +end + +module ProofEngineTacticals = Make (ProofEngineStatus) + +include ProofEngineTacticals + diff --git a/helm/software/components/tactics/tacticals.mli b/helm/software/components/tactics/tacticals.mli new file mode 100644 index 000000000..88fafc1f8 --- /dev/null +++ b/helm/software/components/tactics/tacticals.mli @@ -0,0 +1,92 @@ +(* 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 +val fail_tac: ProofEngineTypes.tactic + +(* module type Status = + sig +|+ type external_input_status +| + type input_status + type output_status +|+ type external_output_status +| + +|+ val internalize: external_input_status -> input_status + val externalize: output_status -> external_output_status +| + + type tactic + + val mk_tactic : (input_status -> output_status) -> tactic + val apply_tactic : tactic -> input_status -> output_status + + val id_tac : tactic + + val goals : output_status -> ProofEngineTypes.goal list + val get_stack : input_status -> stack + val set_stack : stack -> output_status -> output_status + + val inject : input_status -> output_status + val focus : goal -> output_status -> input_status + end *) + +module type T = +sig + type tactic + + val first: tactics: (string * tactic) list -> tactic + val thens: start: tactic -> continuations: tactic list -> tactic + val then_: start: tactic -> continuation: tactic -> tactic + val seq: tactics: tactic list -> tactic (** "folding" of then_ *) + val repeat_tactic: tactic: tactic -> tactic + val do_tactic: n: int -> tactic: tactic -> tactic + val try_tactic: tactic: tactic -> tactic + val solve_tactics: tactics: (string * tactic) list -> tactic + +(* module C: + sig *) + val tactic: tactic -> tactic (** apply tactic to all goal in env *) + val skip: tactic + val dot: tactic + val semicolon: tactic + val branch: tactic + val shift: tactic + val pos: int -> tactic + val merge: tactic + val focus: int list -> tactic + val unfocus: tactic +(* end *) +end + +module Make (S: Continuationals.Status) : T with type tactic = S.tactic + +include T with type tactic = ProofEngineTypes.tactic + +(* TODO temporary *) +val goals_diff: + before:ProofEngineTypes.goal list -> + after:ProofEngineTypes.goal list -> + opened:ProofEngineTypes.goal list -> + ProofEngineTypes.goal list * ProofEngineTypes.goal list + diff --git a/helm/software/components/tactics/tactics.ml b/helm/software/components/tactics/tactics.ml new file mode 100644 index 000000000..fe8adc549 --- /dev/null +++ b/helm/software/components/tactics/tactics.ml @@ -0,0 +1,74 @@ +(* Copyright (C) 2004, 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/. + *) + +(* $Id$ *) + +let absurd = NegationTactics.absurd_tac +let apply = PrimitiveTactics.apply_tac +let assumption = VariousTactics.assumption_tac +let auto = AutoTactic.auto_tac +let change = ReductionTactics.change_tac +let clear = ProofEngineStructuralRules.clear +let clearbody = ProofEngineStructuralRules.clearbody +let compare = DiscriminationTactics.compare_tac +let constructor = IntroductionTactics.constructor_tac +let contradiction = NegationTactics.contradiction_tac +let cut = PrimitiveTactics.cut_tac +let decide_equality = DiscriminationTactics.decide_equality_tac +let decompose = EliminationTactics.decompose_tac +let demodulate = Saturation.demodulate_tac +let discriminate = DiscriminationTactics.discriminate_tac +let elim_intros = PrimitiveTactics.elim_intros_tac +let elim_intros_simpl = PrimitiveTactics.elim_intros_simpl_tac +let elim_type = EliminationTactics.elim_type_tac +let exact = PrimitiveTactics.exact_tac +let exists = IntroductionTactics.exists_tac +let fail = Tacticals.fail_tac +let fold = ReductionTactics.fold_tac +let fourier = FourierR.fourier_tac +let fwd_simpl = FwdSimplTactic.fwd_simpl_tac +let generalize = VariousTactics.generalize_tac +let id = Tacticals.id_tac +let injection = DiscriminationTactics.injection_tac +let intros = PrimitiveTactics.intros_tac +let inversion = Inversion.inversion_tac +let lapply = FwdSimplTactic.lapply_tac +let left = IntroductionTactics.left_tac +let letin = PrimitiveTactics.letin_tac +let normalize = ReductionTactics.normalize_tac +let reduce = ReductionTactics.reduce_tac +let reflexivity = EqualityTactics.reflexivity_tac +let replace = EqualityTactics.replace_tac +let rewrite = EqualityTactics.rewrite_tac +let rewrite_simpl = EqualityTactics.rewrite_simpl_tac +let right = IntroductionTactics.right_tac +let ring = Ring.ring_tac +let set_goal = ProofEngineStructuralRules.set_goal +let simpl = ReductionTactics.simpl_tac +let split = IntroductionTactics.split_tac +let symmetry = EqualityTactics.symmetry_tac +let transitivity = EqualityTactics.transitivity_tac +let unfold = ReductionTactics.unfold_tac +let whd = ReductionTactics.whd_tac diff --git a/helm/software/components/tactics/tactics.mli b/helm/software/components/tactics/tactics.mli new file mode 100644 index 000000000..c8c225cdd --- /dev/null +++ b/helm/software/components/tactics/tactics.mli @@ -0,0 +1,93 @@ +(* GENERATED FILE, DO NOT EDIT *) +val absurd : term:Cic.term -> ProofEngineTypes.tactic +val apply : term:Cic.term -> ProofEngineTypes.tactic +val assumption : ProofEngineTypes.tactic +val auto : + ?depth:int -> + ?width:int -> + ?paramodulation:string -> + ?full:string -> dbd:HMysql.dbd -> unit -> ProofEngineTypes.tactic +val change : + pattern:ProofEngineTypes.lazy_pattern -> + Cic.lazy_term -> ProofEngineTypes.tactic +val clear : hyp:string -> ProofEngineTypes.tactic +val clearbody : hyp:string -> ProofEngineTypes.tactic +val compare : term:Cic.term -> ProofEngineTypes.tactic +val constructor : n:int -> ProofEngineTypes.tactic +val contradiction : ProofEngineTypes.tactic +val cut : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + Cic.term -> ProofEngineTypes.tactic +val decide_equality : ProofEngineTypes.tactic +val decompose : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?user_types:(UriManager.uri * int) list -> + dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic +val demodulate : + dbd:HMysql.dbd -> + pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val discriminate : term:Cic.term -> ProofEngineTypes.tactic +val elim_intros : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic +val elim_intros_simpl : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic +val elim_type : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic +val exact : term:Cic.term -> ProofEngineTypes.tactic +val exists : ProofEngineTypes.tactic +val fail : ProofEngineTypes.tactic +val fold : + reduction:ProofEngineTypes.lazy_reduction -> + term:Cic.lazy_term -> + pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val fourier : ProofEngineTypes.tactic +val fwd_simpl : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic +val generalize : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val id : ProofEngineTypes.tactic +val injection : term:Cic.term -> ProofEngineTypes.tactic +val intros : + ?howmany:int -> + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + unit -> ProofEngineTypes.tactic +val inversion : term:Cic.term -> ProofEngineTypes.tactic +val lapply : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + ?how_many:int -> + ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic +val left : ProofEngineTypes.tactic +val letin : + ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> + Cic.term -> ProofEngineTypes.tactic +val normalize : + pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val reduce : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val reflexivity : ProofEngineTypes.tactic +val replace : + pattern:ProofEngineTypes.lazy_pattern -> + with_what:Cic.lazy_term -> ProofEngineTypes.tactic +val rewrite : + direction:[ `LeftToRight | `RightToLeft ] -> + pattern:ProofEngineTypes.lazy_pattern -> + Cic.term -> ProofEngineTypes.tactic +val rewrite_simpl : + direction:[ `LeftToRight | `RightToLeft ] -> + pattern:ProofEngineTypes.lazy_pattern -> + Cic.term -> ProofEngineTypes.tactic +val right : ProofEngineTypes.tactic +val ring : ProofEngineTypes.tactic +val set_goal : int -> ProofEngineTypes.tactic +val simpl : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val split : ProofEngineTypes.tactic +val symmetry : ProofEngineTypes.tactic +val transitivity : term:Cic.term -> ProofEngineTypes.tactic +val unfold : + Cic.lazy_term option -> + pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic +val whd : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic diff --git a/helm/software/components/tactics/variousTactics.ml b/helm/software/components/tactics/variousTactics.ml new file mode 100644 index 000000000..bc7b52200 --- /dev/null +++ b/helm/software/components/tactics/variousTactics.ml @@ -0,0 +1,191 @@ +(* 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/. + *) + +(* $Id$ *) + + +(* 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 = + let module PET = ProofEngineTypes in + let assumption_tac status = + let (proof, goal) = status in + let module C = Cic in + let module R = CicReduction in + let module S = CicSubstitution in + let module PT = PrimitiveTactics in + let _,metasenv,_,_ = proof in + let _,context,ty = CicUtil.lookup_meta goal metasenv in + let rec find n = function + hd::tl -> + (match hd with + (Some (_, C.Decl t)) when + fst (R.are_convertible context (S.lift n t) ty + CicUniv.empty_ugraph) -> n + | (Some (_, C.Def (_,Some ty'))) when + fst (R.are_convertible context (S.lift n ty') ty + CicUniv.empty_ugraph) -> n + | (Some (_, C.Def (t,None))) -> + let ty_t, u = (* TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv context (S.lift n t) + CicUniv.empty_ugraph in + let b,_ = R.are_convertible context ty_t ty u in + if b then n else find (n+1) tl + | _ -> find (n+1) tl + ) + | [] -> raise (PET.Fail (lazy "Assumption: No such assumption")) + in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status + in + PET.mk_tactic assumption_tac +;; + +(* ANCORA DA DEBUGGARE *) + +exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;; +exception TheSelectedTermsMustLiveInTheGoalContext +exception AllSelectedTermsMustBeConvertible;; +exception GeneralizationInHypothesesNotImplementedYet;; + +let generalize_tac + ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + pattern + = + let module PET = ProofEngineTypes in + let generalize_tac mk_fresh_name_callback + ~pattern:(term,hyps_pat,concl_pat) status + = + if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet; + let (proof, goal) = status in + let module C = Cic in + let module P = PrimitiveTactics in + let module T = Tacticals in + let uri,metasenv,pbo,pty = proof in + let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in + let subst,metasenv,u,selected_hyps,terms_with_context = + ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph + ~conjecture ~pattern in + let context = CicMetaSubst.apply_subst_context subst context in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + let pbo = CicMetaSubst.apply_subst subst pbo in + let pty = CicMetaSubst.apply_subst subst pty in + let term = + match term with + None -> None + | Some term -> + Some (fun context metasenv ugraph -> + let term, metasenv, ugraph = term context metasenv ugraph in + CicMetaSubst.apply_subst subst term, + CicMetaSubst.apply_subst_metasenv subst metasenv, + ugraph) + in + let u,typ,term, metasenv' = + let context_of_t, (t, metasenv, u) = + match terms_with_context, term with + [], None -> + raise + UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly + | [], Some t -> context, t context metasenv u + | (context_of_t, _)::_, Some t -> + context_of_t, t context_of_t metasenv u + | (context_of_t, t)::_, None -> context_of_t, (t, metasenv, u) + in + let t,subst,metasenv' = + try + CicMetaSubst.delift_rels [] metasenv + (List.length context_of_t - List.length context) t + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + raise TheSelectedTermsMustLiveInTheGoalContext + in + (*CSC: I am not sure about the following two assertions; + maybe I need to propagate the new subst and metasenv *) + assert (subst = []); + assert (metasenv' = metasenv); + let typ,u = CicTypeChecker.type_of_aux' ~subst metasenv context t u in + u,typ,t,metasenv + in + (* We need to check: + 1. whether they live in the context of the goal; + if they do they are also well-typed since they are closed subterms + of a well-typed term in the well-typed context of the well-typed + term + 2. whether they are convertible + *) + ignore ( + List.fold_left + (fun u (context_of_t,t) -> + (* 1 *) + let t,subst,metasenv'' = + try + CicMetaSubst.delift_rels [] metasenv' + (List.length context_of_t - List.length context) t + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + raise TheSelectedTermsMustLiveInTheGoalContext in + (*CSC: I am not sure about the following two assertions; + maybe I need to propagate the new subst and metasenv *) + assert (subst = []); + assert (metasenv'' = metasenv'); + (* 2 *) + let b,u1 = CicReduction.are_convertible ~subst context term t u in + if not b then + raise AllSelectedTermsMustBeConvertible + else + u1 + ) u terms_with_context) ; + let status = (uri,metasenv',pbo,pty),goal in + let proof,goals = + PET.apply_tactic + (T.thens + ~start: + (P.cut_tac + (C.Prod( + (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ), + typ, + (ProofEngineReduction.replace_lifting_csc 1 + ~equality:(==) + ~what:(List.map snd terms_with_context) + ~with_what:(List.map (function _ -> C.Rel 1) terms_with_context) + ~where:ty) + ))) + ~continuations: + [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ; + T.id_tac]) + status + in + let _,metasenv'',_,_ = proof in + (* CSC: the following is just a bad approximation since a meta + can be closed and then re-opened! *) + (proof, + goals @ + (List.filter + (fun j -> List.exists (fun (i,_,_) -> i = j) metasenv'') + (ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv + ~newmetasenv:metasenv'))) + in + PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern) +;; diff --git a/helm/software/components/tactics/variousTactics.mli b/helm/software/components/tactics/variousTactics.mli new file mode 100644 index 000000000..35576326e --- /dev/null +++ b/helm/software/components/tactics/variousTactics.mli @@ -0,0 +1,35 @@ + +(* 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 -> + ProofEngineTypes.lazy_pattern -> + ProofEngineTypes.tactic + diff --git a/helm/software/components/thread/.depend b/helm/software/components/thread/.depend new file mode 100644 index 000000000..7759190c6 --- /dev/null +++ b/helm/software/components/thread/.depend @@ -0,0 +1,4 @@ +threadSafe.cmo: threadSafe.cmi +threadSafe.cmx: threadSafe.cmi +extThread.cmo: extThread.cmi +extThread.cmx: extThread.cmi diff --git a/helm/software/components/thread/Makefile b/helm/software/components/thread/Makefile new file mode 100644 index 000000000..46f009e07 --- /dev/null +++ b/helm/software/components/thread/Makefile @@ -0,0 +1,31 @@ + +PACKAGE = thread +INTERFACE_FILES = threadSafe.mli extThread.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +all: thread_fake.cma +opt: thread_fake.cmxa + +include ../../Makefile.defs +include ../Makefile.common + +fake/threadSafe.cmi: fake/threadSafe.mli + @echo " OCAMLC $<" + @cd fake/ \ + && ocamlfind ocamlc -c threadSafe.mli +thread_fake.cma: fake/threadSafe.cmi + @echo " OCAMLC -a $@" + @cd fake/ \ + && ocamlfind ocamlc -a -o $@ threadSafe.ml \ + && cp $@ ../ +thread_fake.cmxa: fake/threadSafe.cmi + @echo " OCAMLOPT -a $@" + @cd fake/ \ + && ocamlfind opt -a -o $@ threadSafe.ml \ + && cp $@ ../ + +clean: clean_fake +clean_fake: + rm -f fake/*.cm[aiox] fake/*.cmxa fake/*.[ao] + rm -f thread_fake.cma thread_fake.cmxa + diff --git a/helm/software/components/thread/extThread.ml b/helm/software/components/thread/extThread.ml new file mode 100644 index 000000000..d59cccd26 --- /dev/null +++ b/helm/software/components/thread/extThread.ml @@ -0,0 +1,110 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +let debug = true +let debug_print s = if debug then prerr_endline (Lazy.force s) + +exception Can_t_kill of Thread.t * string (* thread, reason *) +exception Thread_not_found of Thread.t + +module OrderedPid = + struct + type t = int + let compare = Pervasives.compare + end +module PidSet = Set.Make (OrderedPid) + + (* perform an action inside a critical section controlled by given mutex *) +let do_critical mutex = + fun action -> + try + Mutex.lock mutex; + let res = Lazy.force action in + Mutex.unlock mutex; + res + with e -> Mutex.unlock mutex; raise e + +let kill_signal = Sys.sigusr2 (* signal used to kill children *) +let chan = Event.new_channel () (* communication channel between threads *) +let creation_mutex = Mutex.create () +let dead_threads_walking = ref PidSet.empty +let pids: (Thread.t, int) Hashtbl.t = Hashtbl.create 17 + + (* given a thread body (i.e. first argument of a Thread.create invocation) + return a new thread body which unblock the kill signal and send its pid to + parent over "chan" *) +let wrap_thread body = + fun arg -> + ignore (Unix.sigprocmask Unix.SIG_UNBLOCK [ kill_signal ]); + Event.sync (Event.send chan (Unix.getpid ())); + body arg + +(* +(* FAKE IMPLEMENTATION *) +let create = Thread.create +let kill _ = () +*) + +let create body arg = + do_critical creation_mutex (lazy ( + let thread_t = Thread.create (wrap_thread body) arg in + let pid = Event.sync (Event.receive chan) in + Hashtbl.add pids thread_t pid; + thread_t + )) + +let kill thread_t = + try + let pid = + try + Hashtbl.find pids thread_t + with Not_found -> raise (Thread_not_found thread_t) + in + dead_threads_walking := PidSet.add pid !dead_threads_walking; + Unix.kill pid kill_signal + with e -> raise (Can_t_kill (thread_t, Printexc.to_string e)) + + (* "kill_signal" handler, check if current process must die, if this is the + case exits with Thread.exit *) +let _ = + ignore (Sys.signal kill_signal (Sys.Signal_handle + (fun signal -> + let myself = Unix.getpid () in + match signal with + | sg when (sg = kill_signal) && + (PidSet.mem myself !dead_threads_walking) -> + dead_threads_walking := PidSet.remove myself !dead_threads_walking; + debug_print (lazy "AYEEEEH!"); + Thread.exit () + | _ -> ()))) + + (* block kill signal in main process *) +let _ = ignore (Unix.sigprocmask Unix.SIG_BLOCK [ kill_signal ]) + diff --git a/helm/software/components/thread/extThread.mli b/helm/software/components/thread/extThread.mli new file mode 100644 index 000000000..5fb3bd487 --- /dev/null +++ b/helm/software/components/thread/extThread.mli @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2003: + * Stefano Zacchiroli + * 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/ + *) + +(** {2 Extended Thread module with killing capabilities} *) + +exception Can_t_kill of Thread.t * string + +val create: ('a -> 'b) -> 'a -> Thread.t +val kill: Thread.t -> unit + diff --git a/helm/software/components/thread/fake/threadSafe.ml b/helm/software/components/thread/fake/threadSafe.ml new file mode 100644 index 000000000..b2c427710 --- /dev/null +++ b/helm/software/components/thread/fake/threadSafe.ml @@ -0,0 +1,35 @@ +(* + * Copyright (C) 2003-2005: + * Stefano Zacchiroli + * 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/ + *) + +class threadSafe = + object + method private doCritical: 'a. 'a lazy_t -> 'a = fun a -> Lazy.force a + method private doReader: 'a. 'a lazy_t -> 'a = fun a -> Lazy.force a + method private doWriter: 'a. 'a lazy_t -> 'a = fun a -> Lazy.force a + end + diff --git a/helm/software/components/thread/fake/threadSafe.mli b/helm/software/components/thread/fake/threadSafe.mli new file mode 100644 index 000000000..78166abcc --- /dev/null +++ b/helm/software/components/thread/fake/threadSafe.mli @@ -0,0 +1,44 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +class threadSafe: + object + + (** execute 'action' in mutual exclusion between all other threads *) + method private doCritical: 'a. 'a lazy_t -> 'a + + (** execute 'action' acting as a 'reader' i.e.: multiple readers can act + at the same time but no writer can act until no readers are acting *) + method private doReader: 'a. 'a lazy_t -> 'a + + (** execute 'action' acting as a 'writer' i.e.: when a writer is acting, + no readers or writer can act, beware that writers can starve *) + method private doWriter: 'a. 'a lazy_t -> 'a + + end + diff --git a/helm/software/components/thread/threadSafe.ml b/helm/software/components/thread/threadSafe.ml new file mode 100644 index 000000000..afe953370 --- /dev/null +++ b/helm/software/components/thread/threadSafe.ml @@ -0,0 +1,100 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +(* $Id$ *) + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) + +class threadSafe = + object (self) + + val mutex = Mutex.create () + + (** condition variable: 'no readers is currently reading' *) + val noReaders = Condition.create () + + (** readers count *) + val mutable readersCount = 0 + + method private incrReadersCount = (* internal, not exported *) + self#doCritical (lazy ( + readersCount <- readersCount + 1 + )) + + method private decrReadersCount = (* internal, not exported *) + self#doCritical (lazy ( + if readersCount > 0 then readersCount <- readersCount - 1; + )) + + method private signalNoReaders = (* internal, not exported *) + self#doCritical (lazy ( + if readersCount = 0 then Condition.signal noReaders + )) + + method private doCritical: 'a. 'a lazy_t -> 'a = + fun action -> + debug_print (lazy ""); + (try + Mutex.lock mutex; + let res = Lazy.force action in + Mutex.unlock mutex; + debug_print (lazy ""); + res + with e -> + Mutex.unlock mutex; + raise e); + + method private doReader: 'a. 'a lazy_t -> 'a = + fun action -> + debug_print (lazy ""); + let cleanup () = + self#decrReadersCount; + self#signalNoReaders + in + self#incrReadersCount; + let res = (try Lazy.force action with e -> (cleanup (); raise e)) in + cleanup (); + debug_print (lazy ""); + res + + (* TODO may starve!!!! is what we want or not? *) + method private doWriter: 'a. 'a lazy_t -> 'a = + fun action -> + debug_print (lazy ""); + self#doCritical (lazy ( + while readersCount > 0 do + Condition.wait noReaders mutex + done; + let res = Lazy.force action in + debug_print (lazy ""); + res + )) + + end + diff --git a/helm/software/components/thread/threadSafe.mli b/helm/software/components/thread/threadSafe.mli new file mode 100644 index 000000000..78166abcc --- /dev/null +++ b/helm/software/components/thread/threadSafe.mli @@ -0,0 +1,44 @@ +(* + * Copyright (C) 2003-2004: + * Stefano Zacchiroli + * 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/ + *) + +class threadSafe: + object + + (** execute 'action' in mutual exclusion between all other threads *) + method private doCritical: 'a. 'a lazy_t -> 'a + + (** execute 'action' acting as a 'reader' i.e.: multiple readers can act + at the same time but no writer can act until no readers are acting *) + method private doReader: 'a. 'a lazy_t -> 'a + + (** execute 'action' acting as a 'writer' i.e.: when a writer is acting, + no readers or writer can act, beware that writers can starve *) + method private doWriter: 'a. 'a lazy_t -> 'a + + end + diff --git a/helm/software/components/urimanager/.depend b/helm/software/components/urimanager/.depend new file mode 100644 index 000000000..482148423 --- /dev/null +++ b/helm/software/components/urimanager/.depend @@ -0,0 +1,2 @@ +uriManager.cmo: uriManager.cmi +uriManager.cmx: uriManager.cmi diff --git a/helm/software/components/urimanager/Makefile b/helm/software/components/urimanager/Makefile new file mode 100644 index 000000000..592c0854e --- /dev/null +++ b/helm/software/components/urimanager/Makefile @@ -0,0 +1,10 @@ +PACKAGE = urimanager +PREDICATES = + +INTERFACE_FILES = uriManager.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/urimanager/uriManager.ml b/helm/software/components/urimanager/uriManager.ml new file mode 100644 index 000000000..9ff6a7966 --- /dev/null +++ b/helm/software/components/urimanager/uriManager.ml @@ -0,0 +1,225 @@ +(* 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/. + *) + +(* $Id$ *) + +(* + * "cic:/a/b/c.con" => ("cic:/a/b/c.con", id ) + * "cic:/a/b/c.ind#xpointer(1/1)" => ("cic:/a/b/c.con#xpointer(1/1)", id) + * "cic:/a/b/c.ind#xpointer(1/1/1)" => ("cic:/a/b/c.con#xpointer(1/1/1)", id) + *) + +let fresh_id = + let id = ref 0 in + function () -> + incr id; + !id + +(* (uriwithxpointer, uniqueid) + * where uniqueid is used to build a set of uri *) +type uri = string * int;; + +let eq uri1 uri2 = + uri1 == uri2 +;; + +let string_of_uri (uri,_) = + uri + +let name_of_uri (uri, _) = + let xpointer_offset = + try String.rindex uri '#' with Not_found -> String.length uri - 1 + in + let index1 = String.rindex_from uri xpointer_offset '/' + 1 in + let index2 = String.rindex uri '.' in + String.sub uri index1 (index2 - index1) + +let buri_of_uri (uri,_) = + let xpointer_offset = + try String.rindex uri '#' with Not_found -> String.length uri - 1 + in + let index = String.rindex_from uri xpointer_offset '/' in + String.sub uri 0 index + +module OrderedStrings = + struct + type t = string + let compare (s1 : t) (s2 : t) = compare s1 s2 + end +;; + +module MapStringsToUri = Map.Make(OrderedStrings);; + +(* Invariant: the map is the identity function, + * i.e. + * let str' = (MapStringsToUri.find str !set_of_uri) in + * str' == (MapStringsToUri.find str' !set_of_uri) + *) +let set_of_uri = ref MapStringsToUri.empty;; + +exception IllFormedUri of string;; + +let _dottypes = ".types" +let _types = "types",5 +let _dotuniv = ".univ" +let _univ = "univ",4 +let _dotann = ".ann" +let _ann = "ann",3 +let _var = "var",3 +let _dotbody = ".body" +let _con = "con",3 +let _ind = "ind",3 +let _xpointer = "#xpointer(1/" +let _con3 = "con" +let _var3 = "var" +let _ind3 = "ind" +let _ann3 = "ann" +let _univ4 = "univ" +let _types5 = "types" +let _xpointer8 = "xpointer" +let _cic5 = "cic:/" + +let is_malformed suri = + try + if String.sub suri 0 5 <> _cic5 then true + else + let len = String.length suri - 5 in + let last5 = String.sub suri len 5 in + let last4 = String.sub last5 1 4 in + let last3 = String.sub last5 2 3 in + if last3 = _con3 || last3 = _var3 || last3 = _ind3 || + last3 = _ann3 || last5 = _types5 || last5 = _dotbody || + last4 = _univ4 then + false + else + try + let index = String.rindex suri '#' + 1 in + let xptr = String.sub suri index 8 in + if xptr = _xpointer8 then + false + else + true + with Not_found -> true + with Invalid_argument _ -> true + +(* hash conses an uri *) +let uri_of_string suri = + try + MapStringsToUri.find suri !set_of_uri + with Not_found -> + if is_malformed suri then + raise (IllFormedUri suri) + else + let new_uri = suri, fresh_id () in + set_of_uri := MapStringsToUri.add suri new_uri !set_of_uri; + new_uri + + +let strip_xpointer ((uri,_) as olduri) = + try + let index = String.rindex uri '#' in + let no_xpointer = String.sub uri 0 index in + uri_of_string no_xpointer + with + Not_found -> olduri + +let clear_suffix uri ?(pat2="",0) pat1 = + try + let index = String.rindex uri '.' in + let index' = index + 1 in + let suffix = String.sub uri index' (String.length uri - index') in + if fst pat1 = suffix || fst pat2 = suffix then + String.sub uri 0 index + else + uri + with + Not_found -> assert false + +let has_suffix uri (pat,n) = + try + let suffix = String.sub uri (String.length uri - n) n in + pat = suffix + with + Not_found -> assert false + + +let cicuri_of_uri (uri, _) = uri_of_string (clear_suffix uri ~pat2:_types _ann) + +let annuri_of_uri (uri , _) = uri_of_string ((clear_suffix uri _ann) ^ _dotann) + +let uri_is_annuri (uri, _) = has_suffix uri _ann + +let uri_is_var (uri, _) = has_suffix uri _var + +let uri_is_con (uri, _) = has_suffix uri _con + +let uri_is_ind (uri, _) = has_suffix uri _ind + +let bodyuri_of_uri (uri, _) = + if has_suffix uri _con then + Some (uri_of_string (uri ^ _dotbody)) + else + None +;; + +(* these are bugged! + * we should remove _types, _univ, _ann all toghether *) +let innertypesuri_of_uri (uri, _) = + uri_of_string ((clear_suffix uri _types) ^ _dottypes) +;; +let univgraphuri_of_uri (uri,_) = + uri_of_string ((clear_suffix uri _univ) ^ _dotuniv) +;; + + +let uri_of_uriref (uri, _) typeno consno = + let typeno = typeno + 1 in + let suri = + match consno with + | None -> Printf.sprintf "%s%s%d)" uri _xpointer typeno + | Some n -> Printf.sprintf "%s%s%d/%d)" uri _xpointer typeno n + in + uri_of_string suri + +let compare (_,id1) (_,id2) = id1 - id2 + +module OrderedUri = +struct + type t = uri + let compare = compare (* the one above, not Pervasives.compare *) +end + +module UriSet = Set.Make (OrderedUri) + +module HashedUri = +struct + type t = uri + let equal = eq + let hash = snd +end + +module UriHashtbl = Hashtbl.Make (HashedUri) + + diff --git a/helm/software/components/urimanager/uriManager.mli b/helm/software/components/urimanager/uriManager.mli new file mode 100644 index 000000000..8250cc839 --- /dev/null +++ b/helm/software/components/urimanager/uriManager.mli @@ -0,0 +1,71 @@ +(* 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 IllFormedUri of string;; + +type uri + +val eq : uri -> uri -> bool +val compare : uri -> uri -> int + +val uri_of_string : string -> uri + +val string_of_uri : uri -> string (* complete uri *) +val name_of_uri : uri -> string (* name only (without extension)*) +val buri_of_uri : uri -> string (* base uri only, without trailing '/' *) + +(* given an uri, returns the uri of the corresponding cic file, *) +(* i.e. removes the [.types][.ann] suffix *) +val cicuri_of_uri : uri -> uri + +val strip_xpointer: uri -> uri (* remove trailing #xpointer..., if any *) + +(* given an uri, returns the uri of the corresponding annotation file, *) +(* i.e. adds the .ann suffix if not already present *) +val annuri_of_uri : uri -> uri + +val uri_is_annuri : uri -> bool +val uri_is_var : uri -> bool +val uri_is_con : uri -> bool +val uri_is_ind : 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 +(* given an uri, it gives back the uri of its univgraph *) +val univgraphuri_of_uri : uri -> uri + +(* builder for MutInd and MutConstruct URIs + * [uri] -> [typeno] -> [consno option] + *) +val uri_of_uriref : uri -> int -> int option -> uri + +module UriSet: Set.S with type elt = uri + +module UriHashtbl : Hashtbl.S with type key = uri + diff --git a/helm/software/components/utf8_macros/.depend b/helm/software/components/utf8_macros/.depend new file mode 100644 index 000000000..f3c6a8bd1 --- /dev/null +++ b/helm/software/components/utf8_macros/.depend @@ -0,0 +1,2 @@ +utf8Macro.cmo: utf8MacroTable.cmo utf8Macro.cmi +utf8Macro.cmx: utf8MacroTable.cmx utf8Macro.cmi diff --git a/helm/software/components/utf8_macros/Makefile b/helm/software/components/utf8_macros/Makefile new file mode 100644 index 000000000..2b737627f --- /dev/null +++ b/helm/software/components/utf8_macros/Makefile @@ -0,0 +1,43 @@ +PACKAGE = utf8_macros +PREDICATES = +MAKE_TABLE_PACKAGES = helm-xml + +# modules which have both a .ml and a .mli +INTERFACE_FILES = utf8Macro.mli +IMPLEMENTATION_FILES = utf8MacroTable.ml $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +all: utf8_macros.cma pa_unicode_macro.cma + +make_table: make_table.ml + @echo " OCAMLC $<" + @$(OCAMLFIND) ocamlc -package $(MAKE_TABLE_PACKAGES) -linkpkg -o $@ $^ + +utf8MacroTable.ml: + ./make_table $@ +utf8MacroTable.cmo: utf8MacroTable.ml + @echo " OCAMLC $<" + @$(OCAMLFIND) ocamlc -c $< + +pa_unicode_macro.cmo: pa_unicode_macro.ml utf8Macro.cmo + @echo " OCAMLC $<" + @$(OCAMLFIND) ocamlc -package camlp4 -pp "camlp4o q_MLast.cmo pa_extend.cmo -loc loc" -c $< +pa_unicode_macro.cma: utf8MacroTable.cmo utf8Macro.cmo pa_unicode_macro.cmo + @echo " OCAMLC -a $@" + @$(OCAMLFIND) ocamlc -a -o $@ $^ + +.PHONY: test +test: test.ml + $(OCAMLFIND) ocamlc -package helm-utf8_macros -syntax camlp4o $< -o $@ + +clean: +distclean: extra_clean +extra_clean: + rm -f make_table test + +STATS_EXCLUDE = utf8MacroTable.ml + +include ../../Makefile.defs +include ../Makefile.common + diff --git a/helm/software/components/utf8_macros/README.syntax b/helm/software/components/utf8_macros/README.syntax new file mode 100644 index 000000000..210ecc095 --- /dev/null +++ b/helm/software/components/utf8_macros/README.syntax @@ -0,0 +1,15 @@ + +Helm Utf8 macro syntax extension for Camlp4 + +Sample file: + + --- test.ml --- + + prerr_endline <:unicode> + + --------------- + +Compile it with: + + ocamlfind ocamlc -package helm-utf8_macros -syntax camlp4o test.ml + diff --git a/helm/software/components/utf8_macros/data/dictionary-tex.xml b/helm/software/components/utf8_macros/data/dictionary-tex.xml new file mode 100644 index 000000000..47995454f --- /dev/null +++ b/helm/software/components/utf8_macros/data/dictionary-tex.xml @@ -0,0 +1,378 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/software/components/utf8_macros/data/entities-table.xml b/helm/software/components/utf8_macros/data/entities-table.xml new file mode 100644 index 000000000..c283631b4 --- /dev/null +++ b/helm/software/components/utf8_macros/data/entities-table.xml @@ -0,0 +1,2079 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/software/components/utf8_macros/data/extra-entities.xml b/helm/software/components/utf8_macros/data/extra-entities.xml new file mode 100644 index 000000000..73b12ad5e --- /dev/null +++ b/helm/software/components/utf8_macros/data/extra-entities.xml @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + + diff --git a/helm/software/components/utf8_macros/make_table.ml b/helm/software/components/utf8_macros/make_table.ml new file mode 100644 index 000000000..4722af1e1 --- /dev/null +++ b/helm/software/components/utf8_macros/make_table.ml @@ -0,0 +1,102 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) + + (* source files for tables xml parsing (if unmarshall=false) *) +let xml_tables = [ +(* + `Entities, "/usr/share/gtkmathview/entities-table.xml"; + `Dictionary, "/usr/share/editex/dictionary-tex.xml" +*) + `Entities, "data/entities-table.xml"; + `Dictionary, "data/dictionary-tex.xml"; + `Entities, "data/extra-entities.xml"; + (** extra-entities.xml should be the last one since it is used to override + * previous mappings. Add there overrides as needed. *) +] + +let iter_gen record_tag name_field value_field f fname = + let start_element tag attrs = + if tag = record_tag then + try + let name = List.assoc name_field attrs in + let value = List.assoc value_field attrs in + f name value + with Not_found -> () + in + let callbacks = { + XmlPushParser.default_callbacks with + XmlPushParser.start_element = Some start_element + } in + let xml_parser = XmlPushParser.create_parser callbacks in + XmlPushParser.parse xml_parser (`File fname) + +let iter_entities_file = iter_gen "entity" "name" "value" +let iter_dictionary_file = iter_gen "entry" "name" "val" + +let parse_from_xml () = + let (macro2utf8, utf82macro) = (Hashtbl.create 2000, Hashtbl.create 2000) in + let add_macro macro utf8 = + debug_print (lazy (sprintf "Adding macro %s = '%s'" macro utf8)); + Hashtbl.replace macro2utf8 macro utf8; + Hashtbl.replace utf82macro utf8 macro + in + let fill_table () = + List.iter + (fun (typ, fname) -> + match typ with + | `Entities -> iter_entities_file add_macro fname + | `Dictionary -> iter_dictionary_file add_macro fname) + xml_tables + in + fill_table (); + macro2utf8, utf82macro + +let main () = + let oc = open_out Sys.argv.(1) in + output_string oc "(* GENERATED by make_table: DO NOT EDIT! *)\n"; + output_string oc "let macro2utf8 = Hashtbl.create 2000\n"; + output_string oc "let utf82macro = Hashtbl.create 2000\n"; + let macro2utf8, utf82macro = parse_from_xml () in + Hashtbl.iter + (fun macro utf8 -> + fprintf oc "let _ = Hashtbl.replace macro2utf8 \"%s\" \"%s\"\n" + macro (String.escaped utf8)) + macro2utf8; + Hashtbl.iter + (fun utf8 macro -> + fprintf oc "let _ = Hashtbl.replace utf82macro \"%s\" \"%s\"\n" + (String.escaped utf8) macro) + utf82macro; + close_out oc + +let _ = main () + diff --git a/helm/software/components/utf8_macros/pa_unicode_macro.ml b/helm/software/components/utf8_macros/pa_unicode_macro.ml new file mode 100644 index 000000000..dda7d4cab --- /dev/null +++ b/helm/software/components/utf8_macros/pa_unicode_macro.ml @@ -0,0 +1,67 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let debug = false +let debug_print s = if debug then prerr_endline (Lazy.force s) + +let loc = + let dummy_pos = + { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1; + Lexing.pos_cnum = -1 } + in + (dummy_pos, dummy_pos) + +let expand_unicode_macro macro = + debug_print (lazy (Printf.sprintf "Expanding macro '%s' ..." macro)); + let expansion = Utf8Macro.expand macro in + <:expr< $str:expansion$ >> + +let _ = + Quotation.add "unicode" + (Quotation.ExAst (expand_unicode_macro, (fun _ -> assert false))) + +open Pa_extend + +EXTEND + symbol: FIRST + [ + [ x = UIDENT; q = QUOTATION -> + let (quotation, arg) = + let pos = String.index q ':' in + (String.sub q 0 pos, + String.sub q (pos + 1) (String.length q - pos - 1)) + in + debug_print (lazy (Printf.sprintf "QUOTATION = %s; ARG = %s" quotation arg)); + if quotation = "unicode" then + let text = TXtok (loc, x, expand_unicode_macro arg) in + {used = []; text = text; styp = STlid (loc, "string")} + else + assert false + ] + ]; +END + diff --git a/helm/software/components/utf8_macros/test.ml b/helm/software/components/utf8_macros/test.ml new file mode 100644 index 000000000..8f98bfd44 --- /dev/null +++ b/helm/software/components/utf8_macros/test.ml @@ -0,0 +1,3 @@ +(* $Id$ *) + +prerr_endline <:unicode> diff --git a/helm/software/components/utf8_macros/utf8Macro.ml b/helm/software/components/utf8_macros/utf8Macro.ml new file mode 100644 index 000000000..e5fca10c4 --- /dev/null +++ b/helm/software/components/utf8_macros/utf8Macro.ml @@ -0,0 +1,47 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception Macro_not_found of string +exception Utf8_not_found of string + +let expand macro = + try + Hashtbl.find Utf8MacroTable.macro2utf8 macro + with Not_found -> raise (Macro_not_found macro) + +let unicode_of_tex s = + try + if s.[0] = '\\' then + expand (String.sub s 1 (String.length s - 1)) + else s + with Macro_not_found _ -> s + +let tex_of_unicode s = + try + "\\" ^ Hashtbl.find Utf8MacroTable.utf82macro s + with Not_found -> s + diff --git a/helm/software/components/utf8_macros/utf8Macro.mli b/helm/software/components/utf8_macros/utf8Macro.mli new file mode 100644 index 000000000..d92f60b37 --- /dev/null +++ b/helm/software/components/utf8_macros/utf8Macro.mli @@ -0,0 +1,40 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +exception Macro_not_found of string +exception Utf8_not_found of string + + (** @param macro name + @return utf8 string *) +val expand: string -> string + + (** @param tex TeX like command (e.g. \forall, \lnot, ...) + * @return unicode character corresponding to the command if it exists, or the + * unchanged command if not *) +val unicode_of_tex: string -> string + + (** ... the other way round *) +val tex_of_unicode: string -> string + diff --git a/helm/software/components/utf8_macros/utf8MacroTable.ml b/helm/software/components/utf8_macros/utf8MacroTable.ml new file mode 100644 index 000000000..8b4a02e47 --- /dev/null +++ b/helm/software/components/utf8_macros/utf8MacroTable.ml @@ -0,0 +1,3625 @@ +(* GENERATED by make_table: DO NOT EDIT! *) +let macro2utf8 = Hashtbl.create 2000 +let utf82macro = Hashtbl.create 2000 +let _ = Hashtbl.replace macro2utf8 "nscr" "\240\157\147\131" +let _ = Hashtbl.replace macro2utf8 "LJcy" "\208\137" +let _ = Hashtbl.replace macro2utf8 "dd" "\226\133\134" +let _ = Hashtbl.replace macro2utf8 "Omacr" "\197\140" +let _ = Hashtbl.replace macro2utf8 "npreceq" "\226\170\175\204\184" +let _ = Hashtbl.replace macro2utf8 "Gcirc" "\196\156" +let _ = Hashtbl.replace macro2utf8 "utilde" "\197\169" +let _ = Hashtbl.replace macro2utf8 "rdca" "\226\164\183" +let _ = Hashtbl.replace macro2utf8 "racute" "\197\149" +let _ = Hashtbl.replace macro2utf8 "mstpos" "\226\136\190" +let _ = Hashtbl.replace macro2utf8 "supnE" "\226\138\139" +let _ = Hashtbl.replace macro2utf8 "NotLessLess" "\226\137\170\204\184\239\184\128" +let _ = Hashtbl.replace macro2utf8 "iiint" "\226\136\173" +let _ = Hashtbl.replace macro2utf8 "uscr" "\240\157\147\138" +let _ = Hashtbl.replace macro2utf8 "Sfr" "\240\157\148\150" +let _ = Hashtbl.replace macro2utf8 "nsupseteqq" "\226\138\137" +let _ = Hashtbl.replace macro2utf8 "nwarrow" "\226\134\150" +let _ = Hashtbl.replace macro2utf8 "twoheadrightarrow" "\226\134\160" +let _ = Hashtbl.replace macro2utf8 "sccue" "\226\137\189" +let _ = Hashtbl.replace macro2utf8 "NotSquareSuperset" "\226\138\144\204\184" +let _ = Hashtbl.replace macro2utf8 "ee" "\226\133\135" +let _ = Hashtbl.replace macro2utf8 "boxbox" "\226\167\137" +let _ = Hashtbl.replace macro2utf8 "andand" "\226\169\149" +let _ = Hashtbl.replace macro2utf8 "LeftVectorBar" "\226\165\146" +let _ = Hashtbl.replace macro2utf8 "eg" "\226\170\154" +let _ = Hashtbl.replace macro2utf8 "csc" "csc" +let _ = Hashtbl.replace macro2utf8 "NotRightTriangleEqual" "\226\139\173" +let _ = Hashtbl.replace macro2utf8 "filig" "\239\172\129" +let _ = Hashtbl.replace macro2utf8 "atilde" "\195\163" +let _ = Hashtbl.replace macro2utf8 "ring" "\203\154" +let _ = Hashtbl.replace macro2utf8 "congdot" "\226\169\173" +let _ = Hashtbl.replace macro2utf8 "gE" "\226\137\167" +let _ = Hashtbl.replace macro2utf8 "rcedil" "\197\151" +let _ = Hashtbl.replace macro2utf8 "el" "\226\170\153" +let _ = Hashtbl.replace macro2utf8 "HorizontalLine" "\226\148\128" +let _ = Hashtbl.replace macro2utf8 "incare" "\226\132\133" +let _ = Hashtbl.replace macro2utf8 "hoarr" "\226\135\191" +let _ = Hashtbl.replace macro2utf8 "SOFTcy" "\208\172" +let _ = Hashtbl.replace macro2utf8 "conint" "\226\136\174" +let _ = Hashtbl.replace macro2utf8 "OverParenthesis" "\239\184\181" +let _ = Hashtbl.replace macro2utf8 "Uogon" "\197\178" +let _ = Hashtbl.replace macro2utf8 "supne" "\226\138\139" +let _ = Hashtbl.replace macro2utf8 "num" "#" +let _ = Hashtbl.replace macro2utf8 "zcy" "\208\183" +let _ = Hashtbl.replace macro2utf8 "Hfr" "\226\132\140" +let _ = Hashtbl.replace macro2utf8 "dtri" "\226\150\191" +let _ = Hashtbl.replace macro2utf8 "FilledSmallSquare" "\226\151\190" +let _ = Hashtbl.replace macro2utf8 "SucceedsEqual" "\226\137\189" +let _ = Hashtbl.replace macro2utf8 "leftthreetimes" "\226\139\139" +let _ = Hashtbl.replace macro2utf8 "ycirc" "\197\183" +let _ = Hashtbl.replace macro2utf8 "sqcup" "\226\138\148" +let _ = Hashtbl.replace macro2utf8 "DoubleLeftArrow" "\226\135\144" +let _ = Hashtbl.replace macro2utf8 "gtrless" "\226\137\183" +let _ = Hashtbl.replace macro2utf8 "ge" "\226\137\165" +let _ = Hashtbl.replace macro2utf8 "Product" "\226\136\143" +let _ = Hashtbl.replace macro2utf8 "NotExists" "\226\136\132" +let _ = Hashtbl.replace macro2utf8 "gg" "\226\137\171" +let _ = Hashtbl.replace macro2utf8 "curlyvee" "\226\139\142" +let _ = Hashtbl.replace macro2utf8 "ntrianglerighteq" "\226\139\173" +let _ = Hashtbl.replace macro2utf8 "Colon" "\226\136\183" +let _ = Hashtbl.replace macro2utf8 "rbrke" "\226\166\140" +let _ = Hashtbl.replace macro2utf8 "LeftDownVector" "\226\135\131" +let _ = Hashtbl.replace macro2utf8 "gl" "\226\137\183" +let _ = Hashtbl.replace macro2utf8 "lrcorner" "\226\140\159" +let _ = Hashtbl.replace macro2utf8 "mapstodown" "\226\134\167" +let _ = Hashtbl.replace macro2utf8 "excl" "!" +let _ = Hashtbl.replace macro2utf8 "cdots" "\226\139\175" +let _ = Hashtbl.replace macro2utf8 "larr" "\226\134\144" +let _ = Hashtbl.replace macro2utf8 "dtdot" "\226\139\177" +let _ = Hashtbl.replace macro2utf8 "kgreen" "\196\184" +let _ = Hashtbl.replace macro2utf8 "rtri" "\226\150\185" +let _ = Hashtbl.replace macro2utf8 "rbarr" "\226\164\141" +let _ = Hashtbl.replace macro2utf8 "ocy" "\208\190" +let _ = Hashtbl.replace macro2utf8 "gt" ">" +let _ = Hashtbl.replace macro2utf8 "DownLeftRightVector" "\226\165\144" +let _ = Hashtbl.replace macro2utf8 "cup" "\226\136\170" +let _ = Hashtbl.replace macro2utf8 "updownarrow" "\226\134\149" +let _ = Hashtbl.replace macro2utf8 "Imacr" "\196\170" +let _ = Hashtbl.replace macro2utf8 "cross" "\226\156\151" +let _ = Hashtbl.replace macro2utf8 "Acirc" "\195\130" +let _ = Hashtbl.replace macro2utf8 "lvertneqq" "\226\137\168\239\184\128" +let _ = Hashtbl.replace macro2utf8 "ccaps" "\226\169\141" +let _ = Hashtbl.replace macro2utf8 "NotLeftTriangleEqual" "\226\139\172" +let _ = Hashtbl.replace macro2utf8 "IJlig" "\196\178" +let _ = Hashtbl.replace macro2utf8 "boxplus" "\226\138\158" +let _ = Hashtbl.replace macro2utf8 "epsilon" "\207\181" +let _ = Hashtbl.replace macro2utf8 "zfr" "\240\157\148\183" +let _ = Hashtbl.replace macro2utf8 "late" "\226\170\173" +let _ = Hashtbl.replace macro2utf8 "ic" "\226\128\139" +let _ = Hashtbl.replace macro2utf8 "lrhar" "\226\135\139" +let _ = Hashtbl.replace macro2utf8 "gsim" "\226\137\179" +let _ = Hashtbl.replace macro2utf8 "inf" "inf" +let _ = Hashtbl.replace macro2utf8 "top" "\226\138\164" +let _ = Hashtbl.replace macro2utf8 "odsold" "\226\166\188" +let _ = Hashtbl.replace macro2utf8 "circlearrowright" "\226\134\187" +let _ = Hashtbl.replace macro2utf8 "rtimes" "\226\139\138" +let _ = Hashtbl.replace macro2utf8 "ii" "\226\133\136" +let _ = Hashtbl.replace macro2utf8 "DoubleRightTee" "\226\138\168" +let _ = Hashtbl.replace macro2utf8 "dcy" "\208\180" +let _ = Hashtbl.replace macro2utf8 "boxdL" "\226\149\149" +let _ = Hashtbl.replace macro2utf8 "duhar" "\226\165\175" +let _ = Hashtbl.replace macro2utf8 "vert" "|" +let _ = Hashtbl.replace macro2utf8 "sacute" "\197\155" +let _ = Hashtbl.replace macro2utf8 "in" "\226\136\136" +let _ = Hashtbl.replace macro2utf8 "Assign" "\226\137\148" +let _ = Hashtbl.replace macro2utf8 "nsim" "\226\137\129" +let _ = Hashtbl.replace macro2utf8 "boxdR" "\226\149\146" +let _ = Hashtbl.replace macro2utf8 "o" "\206\191" +let _ = Hashtbl.replace macro2utf8 "radic" "\226\136\154" +let _ = Hashtbl.replace macro2utf8 "it" "\226\129\162" +let _ = Hashtbl.replace macro2utf8 "int" "\226\136\171" +let _ = Hashtbl.replace macro2utf8 "cwint" "\226\136\177" +let _ = Hashtbl.replace macro2utf8 "ForAll" "\226\136\128" +let _ = Hashtbl.replace macro2utf8 "simplus" "\226\168\164" +let _ = Hashtbl.replace macro2utf8 "isindot" "\226\139\181" +let _ = Hashtbl.replace macro2utf8 "rightthreetimes" "\226\139\140" +let _ = Hashtbl.replace macro2utf8 "supseteqq" "\226\138\135" +let _ = Hashtbl.replace macro2utf8 "bnot" "\226\140\144" +let _ = Hashtbl.replace macro2utf8 "rppolint" "\226\168\146" +let _ = Hashtbl.replace macro2utf8 "def" "\226\137\157" +let _ = Hashtbl.replace macro2utf8 "TScy" "\208\166" +let _ = Hashtbl.replace macro2utf8 "lE" "\226\137\166" +let _ = Hashtbl.replace macro2utf8 "ffilig" "\239\172\131" +let _ = Hashtbl.replace macro2utf8 "deg" "deg" +let _ = Hashtbl.replace macro2utf8 "{" "{" +let _ = Hashtbl.replace macro2utf8 "RightVector" "\226\135\128" +let _ = Hashtbl.replace macro2utf8 "ofr" "\240\157\148\172" +let _ = Hashtbl.replace macro2utf8 "|" "|" +let _ = Hashtbl.replace macro2utf8 "liminf" "liminf" +let _ = Hashtbl.replace macro2utf8 "}" "}" +let _ = Hashtbl.replace macro2utf8 "LeftUpTeeVector" "\226\165\160" +let _ = Hashtbl.replace macro2utf8 "scirc" "\197\157" +let _ = Hashtbl.replace macro2utf8 "scedil" "\197\159" +let _ = Hashtbl.replace macro2utf8 "ufisht" "\226\165\190" +let _ = Hashtbl.replace macro2utf8 "LeftUpDownVector" "\226\165\145" +let _ = Hashtbl.replace macro2utf8 "questeq" "\226\137\159" +let _ = Hashtbl.replace macro2utf8 "leftarrow" "\226\134\144" +let _ = Hashtbl.replace macro2utf8 "Ycy" "\208\171" +let _ = Hashtbl.replace macro2utf8 "Coproduct" "\226\136\144" +let _ = Hashtbl.replace macro2utf8 "det" "det" +let _ = Hashtbl.replace macro2utf8 "boxdl" "\226\148\144" +let _ = Hashtbl.replace macro2utf8 "Aopf" "\240\157\148\184" +let _ = Hashtbl.replace macro2utf8 "srarr" "\226\134\146\239\184\128" +let _ = Hashtbl.replace macro2utf8 "lbrke" "\226\166\139" +let _ = Hashtbl.replace macro2utf8 "boxdr" "\226\148\140" +let _ = Hashtbl.replace macro2utf8 "Ntilde" "\195\145" +let _ = Hashtbl.replace macro2utf8 "gnap" "\226\170\138" +let _ = Hashtbl.replace macro2utf8 "Cap" "\226\139\146" +let _ = Hashtbl.replace macro2utf8 "swarhk" "\226\164\166" +let _ = Hashtbl.replace macro2utf8 "ogt" "\226\167\129" +let _ = Hashtbl.replace macro2utf8 "emptyset" "\226\136\133\239\184\128" +let _ = Hashtbl.replace macro2utf8 "harrw" "\226\134\173" +let _ = Hashtbl.replace macro2utf8 "lbarr" "\226\164\140" +let _ = Hashtbl.replace macro2utf8 "Tilde" "\226\136\188" +let _ = Hashtbl.replace macro2utf8 "delta" "\206\180" +let _ = Hashtbl.replace macro2utf8 "Hopf" "\226\132\141" +let _ = Hashtbl.replace macro2utf8 "dfr" "\240\157\148\161" +let _ = Hashtbl.replace macro2utf8 "le" "\226\137\164" +let _ = Hashtbl.replace macro2utf8 "lg" "lg" +let _ = Hashtbl.replace macro2utf8 "ohm" "\226\132\166" +let _ = Hashtbl.replace macro2utf8 "Jsercy" "\208\136" +let _ = Hashtbl.replace macro2utf8 "quaternions" "\226\132\141" +let _ = Hashtbl.replace macro2utf8 "DoubleLongLeftArrow" "\239\149\185" +let _ = Hashtbl.replace macro2utf8 "Ncy" "\208\157" +let _ = Hashtbl.replace macro2utf8 "nabla" "\226\136\135" +let _ = Hashtbl.replace macro2utf8 "ltcir" "\226\169\185" +let _ = Hashtbl.replace macro2utf8 "ll" "\226\137\170" +let _ = Hashtbl.replace macro2utf8 "ln" "ln" +let _ = Hashtbl.replace macro2utf8 "rmoust" "\226\142\177" +let _ = Hashtbl.replace macro2utf8 "Oopf" "\240\157\149\134" +let _ = Hashtbl.replace macro2utf8 "nbsp" "\194\160" +let _ = Hashtbl.replace macro2utf8 "Kcedil" "\196\182" +let _ = Hashtbl.replace macro2utf8 "vdots" "\226\139\174" +let _ = Hashtbl.replace macro2utf8 "NotLessTilde" "\226\137\180" +let _ = Hashtbl.replace macro2utf8 "lt" "<" +let _ = Hashtbl.replace macro2utf8 "djcy" "\209\146" +let _ = Hashtbl.replace macro2utf8 "DownRightTeeVector" "\226\165\159" +let _ = Hashtbl.replace macro2utf8 "Ograve" "\195\146" +let _ = Hashtbl.replace macro2utf8 "boxhD" "\226\149\165" +let _ = Hashtbl.replace macro2utf8 "nsime" "\226\137\132" +let _ = Hashtbl.replace macro2utf8 "egsdot" "\226\170\152" +let _ = Hashtbl.replace macro2utf8 "mDDot" "\226\136\186" +let _ = Hashtbl.replace macro2utf8 "bigodot" "\226\138\153" +let _ = Hashtbl.replace macro2utf8 "Vopf" "\240\157\149\141" +let _ = Hashtbl.replace macro2utf8 "looparrowright" "\226\134\172" +let _ = Hashtbl.replace macro2utf8 "yucy" "\209\142" +let _ = Hashtbl.replace macro2utf8 "trade" "\226\132\162" +let _ = Hashtbl.replace macro2utf8 "Yfr" "\240\157\148\156" +let _ = Hashtbl.replace macro2utf8 "kjcy" "\209\156" +let _ = Hashtbl.replace macro2utf8 "mp" "\226\136\147" +let _ = Hashtbl.replace macro2utf8 "leftrightarrows" "\226\135\134" +let _ = Hashtbl.replace macro2utf8 "uharl" "\226\134\191" +let _ = Hashtbl.replace macro2utf8 "ncap" "\226\169\131" +let _ = Hashtbl.replace macro2utf8 "Iogon" "\196\174" +let _ = Hashtbl.replace macro2utf8 "NotSubset" "\226\138\132" +let _ = Hashtbl.replace macro2utf8 "Bumpeq" "\226\137\142" +let _ = Hashtbl.replace macro2utf8 "mu" "\206\188" +let _ = Hashtbl.replace macro2utf8 "FilledVerySmallSquare" "\239\150\155" +let _ = Hashtbl.replace macro2utf8 "breve" "\203\152" +let _ = Hashtbl.replace macro2utf8 "boxhU" "\226\149\168" +let _ = Hashtbl.replace macro2utf8 "Sigma" "\206\163" +let _ = Hashtbl.replace macro2utf8 "uharr" "\226\134\190" +let _ = Hashtbl.replace macro2utf8 "xrArr" "\239\149\186" +let _ = Hashtbl.replace macro2utf8 "ne" "\226\137\160" +let _ = Hashtbl.replace macro2utf8 "oS" "\226\147\136" +let _ = Hashtbl.replace macro2utf8 "xodot" "\226\138\153" +let _ = Hashtbl.replace macro2utf8 "ni" "\226\136\139" +let _ = Hashtbl.replace macro2utf8 "mdash" "\226\128\148" +let _ = Hashtbl.replace macro2utf8 "Verbar" "\226\128\150" +let _ = Hashtbl.replace macro2utf8 "die" "\194\168" +let _ = Hashtbl.replace macro2utf8 "veebar" "\226\138\187" +let _ = Hashtbl.replace macro2utf8 "UpArrowBar" "\226\164\146" +let _ = Hashtbl.replace macro2utf8 "Ncaron" "\197\135" +let _ = Hashtbl.replace macro2utf8 "RightArrowBar" "\226\135\165" +let _ = Hashtbl.replace macro2utf8 "LongLeftArrow" "\239\149\182" +let _ = Hashtbl.replace macro2utf8 "rceil" "\226\140\137" +let _ = Hashtbl.replace macro2utf8 "LeftDownVectorBar" "\226\165\153" +let _ = Hashtbl.replace macro2utf8 "umacr" "\197\171" +let _ = Hashtbl.replace macro2utf8 "Hacek" "\203\135" +let _ = Hashtbl.replace macro2utf8 "odblac" "\197\145" +let _ = Hashtbl.replace macro2utf8 "lmidot" "\197\128" +let _ = Hashtbl.replace macro2utf8 "dopf" "\240\157\149\149" +let _ = Hashtbl.replace macro2utf8 "boxhd" "\226\148\172" +let _ = Hashtbl.replace macro2utf8 "dim" "dim" +let _ = Hashtbl.replace macro2utf8 "vnsub" "\226\138\132" +let _ = Hashtbl.replace macro2utf8 "Bscr" "\226\132\172" +let _ = Hashtbl.replace macro2utf8 "plussim" "\226\168\166" +let _ = Hashtbl.replace macro2utf8 "doublebarwedge" "\226\140\134" +let _ = Hashtbl.replace macro2utf8 "nu" "\206\189" +let _ = Hashtbl.replace macro2utf8 "eqcolon" "\226\137\149" +let _ = Hashtbl.replace macro2utf8 "luruhar" "\226\165\166" +let _ = Hashtbl.replace macro2utf8 "Nfr" "\240\157\148\145" +let _ = Hashtbl.replace macro2utf8 "preceq" "\226\170\175" +let _ = Hashtbl.replace macro2utf8 "LeftTee" "\226\138\163" +let _ = Hashtbl.replace macro2utf8 "div" "\195\183" +let _ = Hashtbl.replace macro2utf8 "nVDash" "\226\138\175" +let _ = Hashtbl.replace macro2utf8 "kopf" "\240\157\149\156" +let _ = Hashtbl.replace macro2utf8 "Iscr" "\226\132\144" +let _ = Hashtbl.replace macro2utf8 "vnsup" "\226\138\133" +let _ = Hashtbl.replace macro2utf8 "gneq" "\226\137\169" +let _ = Hashtbl.replace macro2utf8 "backepsilon" "\207\182" +let _ = Hashtbl.replace macro2utf8 "boxhu" "\226\148\180" +let _ = Hashtbl.replace macro2utf8 "ominus" "\226\138\150" +let _ = Hashtbl.replace macro2utf8 "or" "\226\136\168" +let _ = Hashtbl.replace macro2utf8 "lesdot" "\226\169\191" +let _ = Hashtbl.replace macro2utf8 "RightVectorBar" "\226\165\147" +let _ = Hashtbl.replace macro2utf8 "tcedil" "\197\163" +let _ = Hashtbl.replace macro2utf8 "hstrok" "\196\167" +let _ = Hashtbl.replace macro2utf8 "nrarrc" "\226\164\179\204\184" +let _ = Hashtbl.replace macro2utf8 "ropf" "\240\157\149\163" +let _ = Hashtbl.replace macro2utf8 "diamond" "\226\139\132" +let _ = Hashtbl.replace macro2utf8 "smid" "\226\136\163\239\184\128" +let _ = Hashtbl.replace macro2utf8 "nltri" "\226\139\170" +let _ = Hashtbl.replace macro2utf8 "Pscr" "\240\157\146\171" +let _ = Hashtbl.replace macro2utf8 "vartheta" "\207\145" +let _ = Hashtbl.replace macro2utf8 "therefore" "\226\136\180" +let _ = Hashtbl.replace macro2utf8 "pi" "\207\128" +let _ = Hashtbl.replace macro2utf8 "ntrianglelefteq" "\226\139\172" +let _ = Hashtbl.replace macro2utf8 "nearrow" "\226\134\151" +let _ = Hashtbl.replace macro2utf8 "pm" "\194\177" +let _ = Hashtbl.replace macro2utf8 "natural" "\226\153\174" +let _ = Hashtbl.replace macro2utf8 "ucy" "\209\131" +let _ = Hashtbl.replace macro2utf8 "olt" "\226\167\128" +let _ = Hashtbl.replace macro2utf8 "Cfr" "\226\132\173" +let _ = Hashtbl.replace macro2utf8 "yopf" "\240\157\149\170" +let _ = Hashtbl.replace macro2utf8 "Otilde" "\195\149" +let _ = Hashtbl.replace macro2utf8 "ntriangleleft" "\226\139\170" +let _ = Hashtbl.replace macro2utf8 "pr" "\226\137\186" +let _ = Hashtbl.replace macro2utf8 "Wscr" "\240\157\146\178" +let _ = Hashtbl.replace macro2utf8 "midcir" "\226\171\176" +let _ = Hashtbl.replace macro2utf8 "Lacute" "\196\185" +let _ = Hashtbl.replace macro2utf8 "DoubleDot" "\194\168" +let _ = Hashtbl.replace macro2utf8 "Tstrok" "\197\166" +let _ = Hashtbl.replace macro2utf8 "nrarrw" "\226\134\157\204\184" +let _ = Hashtbl.replace macro2utf8 "uArr" "\226\135\145" +let _ = Hashtbl.replace macro2utf8 "nLtv" "\226\137\170\204\184\239\184\128" +let _ = Hashtbl.replace macro2utf8 "rangle" "\226\140\170" +let _ = Hashtbl.replace macro2utf8 "olcir" "\226\166\190" +let _ = Hashtbl.replace macro2utf8 "Auml" "\195\132" +let _ = Hashtbl.replace macro2utf8 "Succeeds" "\226\137\187" +let _ = Hashtbl.replace macro2utf8 "DoubleLongLeftRightArrow" "\239\149\187" +let _ = Hashtbl.replace macro2utf8 "TSHcy" "\208\139" +let _ = Hashtbl.replace macro2utf8 "gammad" "\207\156" +let _ = Hashtbl.replace macro2utf8 "epsiv" "\201\155" +let _ = Hashtbl.replace macro2utf8 "notinva" "\226\136\137\204\184" +let _ = Hashtbl.replace macro2utf8 "notinvb" "\226\139\183" +let _ = Hashtbl.replace macro2utf8 "eqvparsl" "\226\167\165" +let _ = Hashtbl.replace macro2utf8 "notinvc" "\226\139\182" +let _ = Hashtbl.replace macro2utf8 "nsubE" "\226\138\136" +let _ = Hashtbl.replace macro2utf8 "supplus" "\226\171\128" +let _ = Hashtbl.replace macro2utf8 "RightUpDownVector" "\226\165\143" +let _ = Hashtbl.replace macro2utf8 "Tab" "\t" +let _ = Hashtbl.replace macro2utf8 "Lcedil" "\196\187" +let _ = Hashtbl.replace macro2utf8 "backslash" "\\" +let _ = Hashtbl.replace macro2utf8 "pointint" "\226\168\149" +let _ = Hashtbl.replace macro2utf8 "jcy" "\208\185" +let _ = Hashtbl.replace macro2utf8 "iocy" "\209\145" +let _ = Hashtbl.replace macro2utf8 "escr" "\226\132\175" +let _ = Hashtbl.replace macro2utf8 "submult" "\226\171\129" +let _ = Hashtbl.replace macro2utf8 "iiota" "\226\132\169" +let _ = Hashtbl.replace macro2utf8 "lceil" "\226\140\136" +let _ = Hashtbl.replace macro2utf8 "omacr" "\197\141" +let _ = Hashtbl.replace macro2utf8 "gneqq" "\226\137\169" +let _ = Hashtbl.replace macro2utf8 "gcirc" "\196\157" +let _ = Hashtbl.replace macro2utf8 "dotsquare" "\226\138\161" +let _ = Hashtbl.replace macro2utf8 "ccaron" "\196\141" +let _ = Hashtbl.replace macro2utf8 "Square" "\226\150\161" +let _ = Hashtbl.replace macro2utf8 "RightDownTeeVector" "\226\165\157" +let _ = Hashtbl.replace macro2utf8 "Ouml" "\195\150" +let _ = Hashtbl.replace macro2utf8 "lurdshar" "\226\165\138" +let _ = Hashtbl.replace macro2utf8 "SuchThat" "\226\136\139" +let _ = Hashtbl.replace macro2utf8 "setminus" "\226\136\150" +let _ = Hashtbl.replace macro2utf8 "lscr" "\226\132\147" +let _ = Hashtbl.replace macro2utf8 "LessLess" "\226\170\161" +let _ = Hashtbl.replace macro2utf8 "Sub" "\226\139\144" +let _ = Hashtbl.replace macro2utf8 "sc" "\226\137\187" +let _ = Hashtbl.replace macro2utf8 "rx" "\226\132\158" +let _ = Hashtbl.replace macro2utf8 "RightFloor" "\226\140\139" +let _ = Hashtbl.replace macro2utf8 "blacksquare" "\226\150\170" +let _ = Hashtbl.replace macro2utf8 "ufr" "\240\157\148\178" +let _ = Hashtbl.replace macro2utf8 "block" "\226\150\136" +let _ = Hashtbl.replace macro2utf8 "dots" "\226\128\166" +let _ = Hashtbl.replace macro2utf8 "nvsim" "\226\137\129\204\184" +let _ = Hashtbl.replace macro2utf8 "caret" "\226\129\129" +let _ = Hashtbl.replace macro2utf8 "demptyv" "\226\166\177" +let _ = Hashtbl.replace macro2utf8 "Sum" "\226\136\145" +let _ = Hashtbl.replace macro2utf8 "sscr" "\240\157\147\136" +let _ = Hashtbl.replace macro2utf8 "nsube" "\226\138\136" +let _ = Hashtbl.replace macro2utf8 "Sup" "\226\139\145" +let _ = Hashtbl.replace macro2utf8 "ccupssm" "\226\169\144" +let _ = Hashtbl.replace macro2utf8 "Because" "\226\136\181" +let _ = Hashtbl.replace macro2utf8 "harrcir" "\226\165\136" +let _ = Hashtbl.replace macro2utf8 "capbrcup" "\226\169\137" +let _ = Hashtbl.replace macro2utf8 "RightUpVectorBar" "\226\165\148" +let _ = Hashtbl.replace macro2utf8 "caps" "\226\136\169\239\184\128" +let _ = Hashtbl.replace macro2utf8 "ohbar" "\226\166\181" +let _ = Hashtbl.replace macro2utf8 "laemptyv" "\226\166\180" +let _ = Hashtbl.replace macro2utf8 "uacute" "\195\186" +let _ = Hashtbl.replace macro2utf8 "straightphi" "\207\134" +let _ = Hashtbl.replace macro2utf8 "RightDoubleBracket" "\227\128\155" +let _ = Hashtbl.replace macro2utf8 "zscr" "\240\157\147\143" +let _ = Hashtbl.replace macro2utf8 "uogon" "\197\179" +let _ = Hashtbl.replace macro2utf8 "Uarr" "\226\134\159" +let _ = Hashtbl.replace macro2utf8 "nsucc" "\226\138\129" +let _ = Hashtbl.replace macro2utf8 "RBarr" "\226\164\144" +let _ = Hashtbl.replace macro2utf8 "NotRightTriangleBar" "\226\167\144\204\184" +let _ = Hashtbl.replace macro2utf8 "to" "\226\134\146" +let _ = Hashtbl.replace macro2utf8 "rpar" ")" +let _ = Hashtbl.replace macro2utf8 "rdsh" "\226\134\179" +let _ = Hashtbl.replace macro2utf8 "jfr" "\240\157\148\167" +let _ = Hashtbl.replace macro2utf8 "ldquor" "\226\128\158" +let _ = Hashtbl.replace macro2utf8 "bsime" "\226\139\141" +let _ = Hashtbl.replace macro2utf8 "lAtail" "\226\164\155" +let _ = Hashtbl.replace macro2utf8 "Hcirc" "\196\164" +let _ = Hashtbl.replace macro2utf8 "aacute" "\195\161" +let _ = Hashtbl.replace macro2utf8 "dot" "\203\153" +let _ = Hashtbl.replace macro2utf8 "Tcy" "\208\162" +let _ = Hashtbl.replace macro2utf8 "nsub" "\226\138\132" +let _ = Hashtbl.replace macro2utf8 "kappa" "\206\186" +let _ = Hashtbl.replace macro2utf8 "ovbar" "\226\140\189" +let _ = Hashtbl.replace macro2utf8 "shcy" "\209\136" +let _ = Hashtbl.replace macro2utf8 "kappav" "\207\176" +let _ = Hashtbl.replace macro2utf8 "ropar" "\227\128\153" +let _ = Hashtbl.replace macro2utf8 "gtcc" "\226\170\167" +let _ = Hashtbl.replace macro2utf8 "ecolon" "\226\137\149" +let _ = Hashtbl.replace macro2utf8 "circledast" "\226\138\155" +let _ = Hashtbl.replace macro2utf8 "colon" ":" +let _ = Hashtbl.replace macro2utf8 "timesbar" "\226\168\177" +let _ = Hashtbl.replace macro2utf8 "precnsim" "\226\139\168" +let _ = Hashtbl.replace macro2utf8 "ord" "\226\169\157" +let _ = Hashtbl.replace macro2utf8 "real" "\226\132\156" +let _ = Hashtbl.replace macro2utf8 "nexists" "\226\136\132" +let _ = Hashtbl.replace macro2utf8 "nsup" "\226\138\133" +let _ = Hashtbl.replace macro2utf8 "zhcy" "\208\182" +let _ = Hashtbl.replace macro2utf8 "imacr" "\196\171" +let _ = Hashtbl.replace macro2utf8 "egrave" "\195\168" +let _ = Hashtbl.replace macro2utf8 "acirc" "\195\162" +let _ = Hashtbl.replace macro2utf8 "grave" "`" +let _ = Hashtbl.replace macro2utf8 "biguplus" "\226\138\142" +let _ = Hashtbl.replace macro2utf8 "HumpEqual" "\226\137\143" +let _ = Hashtbl.replace macro2utf8 "GreaterSlantEqual" "\226\169\190" +let _ = Hashtbl.replace macro2utf8 "capand" "\226\169\132" +let _ = Hashtbl.replace macro2utf8 "yuml" "\195\191" +let _ = Hashtbl.replace macro2utf8 "orv" "\226\169\155" +let _ = Hashtbl.replace macro2utf8 "Icy" "\208\152" +let _ = Hashtbl.replace macro2utf8 "rightharpoondown" "\226\135\129" +let _ = Hashtbl.replace macro2utf8 "upsilon" "\207\133" +let _ = Hashtbl.replace macro2utf8 "preccurlyeq" "\226\137\188" +let _ = Hashtbl.replace macro2utf8 "ShortUpArrow" "\226\140\131\239\184\128" +let _ = Hashtbl.replace macro2utf8 "searhk" "\226\164\165" +let _ = Hashtbl.replace macro2utf8 "commat" "@" +let _ = Hashtbl.replace macro2utf8 "Sqrt" "\226\136\154" +let _ = Hashtbl.replace macro2utf8 "wp" "\226\132\152" +let _ = Hashtbl.replace macro2utf8 "succnapprox" "\226\139\169" +let _ = Hashtbl.replace macro2utf8 "wr" "\226\137\128" +let _ = Hashtbl.replace macro2utf8 "NotTildeTilde" "\226\137\137" +let _ = Hashtbl.replace macro2utf8 "dcaron" "\196\143" +let _ = Hashtbl.replace macro2utf8 "Tfr" "\240\157\148\151" +let _ = Hashtbl.replace macro2utf8 "bigwedge" "\226\139\128" +let _ = Hashtbl.replace macro2utf8 "DScy" "\208\133" +let _ = Hashtbl.replace macro2utf8 "nrtrie" "\226\139\173" +let _ = Hashtbl.replace macro2utf8 "esim" "\226\137\130" +let _ = Hashtbl.replace macro2utf8 "Not" "\226\171\172" +let _ = Hashtbl.replace macro2utf8 "xmap" "\239\149\189" +let _ = Hashtbl.replace macro2utf8 "rect" "\226\150\173" +let _ = Hashtbl.replace macro2utf8 "Fouriertrf" "\226\132\177" +let _ = Hashtbl.replace macro2utf8 "xi" "\206\190" +let _ = Hashtbl.replace macro2utf8 "NotTilde" "\226\137\129" +let _ = Hashtbl.replace macro2utf8 "gbreve" "\196\159" +let _ = Hashtbl.replace macro2utf8 "par" "\226\136\165" +let _ = Hashtbl.replace macro2utf8 "ddots" "\226\139\177" +let _ = Hashtbl.replace macro2utf8 "nhArr" "\226\135\142" +let _ = Hashtbl.replace macro2utf8 "lsim" "\226\137\178" +let _ = Hashtbl.replace macro2utf8 "RightCeiling" "\226\140\137" +let _ = Hashtbl.replace macro2utf8 "nedot" "\226\137\160\239\184\128" +let _ = Hashtbl.replace macro2utf8 "thksim" "\226\136\188\239\184\128" +let _ = Hashtbl.replace macro2utf8 "lEg" "\226\139\154" +let _ = Hashtbl.replace macro2utf8 "Ifr" "\226\132\145" +let _ = Hashtbl.replace macro2utf8 "emsp" "\226\128\131" +let _ = Hashtbl.replace macro2utf8 "lopar" "\227\128\152" +let _ = Hashtbl.replace macro2utf8 "iiiint" "\226\168\140" +let _ = Hashtbl.replace macro2utf8 "straightepsilon" "\206\181" +let _ = Hashtbl.replace macro2utf8 "intlarhk" "\226\168\151" +let _ = Hashtbl.replace macro2utf8 "image" "\226\132\145" +let _ = Hashtbl.replace macro2utf8 "sqsubseteq" "\226\138\145" +let _ = Hashtbl.replace macro2utf8 "lnapprox" "\226\170\137" +let _ = Hashtbl.replace macro2utf8 "Leftrightarrow" "\226\135\148" +let _ = Hashtbl.replace macro2utf8 "cemptyv" "\226\166\178" +let _ = Hashtbl.replace macro2utf8 "alpha" "\206\177" +let _ = Hashtbl.replace macro2utf8 "uml" "\194\168" +let _ = Hashtbl.replace macro2utf8 "barwedge" "\226\138\188" +let _ = Hashtbl.replace macro2utf8 "KHcy" "\208\165" +let _ = Hashtbl.replace macro2utf8 "tilde" "\203\156" +let _ = Hashtbl.replace macro2utf8 "Superset" "\226\138\131" +let _ = Hashtbl.replace macro2utf8 "gesles" "\226\170\148" +let _ = Hashtbl.replace macro2utf8 "bigoplus" "\226\138\149" +let _ = Hashtbl.replace macro2utf8 "boxuL" "\226\149\155" +let _ = Hashtbl.replace macro2utf8 "rbbrk" "\227\128\149" +let _ = Hashtbl.replace macro2utf8 "nrightarrow" "\226\134\155" +let _ = Hashtbl.replace macro2utf8 "hkswarow" "\226\164\166" +let _ = Hashtbl.replace macro2utf8 "DiacriticalDoubleAcute" "\203\157" +let _ = Hashtbl.replace macro2utf8 "nbumpe" "\226\137\143\204\184" +let _ = Hashtbl.replace macro2utf8 "uhblk" "\226\150\128" +let _ = Hashtbl.replace macro2utf8 "NotSupersetEqual" "\226\138\137" +let _ = Hashtbl.replace macro2utf8 "ntgl" "\226\137\185" +let _ = Hashtbl.replace macro2utf8 "Fopf" "\240\157\148\189" +let _ = Hashtbl.replace macro2utf8 "boxuR" "\226\149\152" +let _ = Hashtbl.replace macro2utf8 "swarr" "\226\134\153" +let _ = Hashtbl.replace macro2utf8 "nsqsube" "\226\139\162" +let _ = Hashtbl.replace macro2utf8 "pluscir" "\226\168\162" +let _ = Hashtbl.replace macro2utf8 "pcy" "\208\191" +let _ = Hashtbl.replace macro2utf8 "leqslant" "\226\169\189" +let _ = Hashtbl.replace macro2utf8 "lnap" "\226\170\137" +let _ = Hashtbl.replace macro2utf8 "lthree" "\226\139\139" +let _ = Hashtbl.replace macro2utf8 "smte" "\226\170\172" +let _ = Hashtbl.replace macro2utf8 "olcross" "\226\166\187" +let _ = Hashtbl.replace macro2utf8 "nvrArr" "\226\135\143" +let _ = Hashtbl.replace macro2utf8 "andslope" "\226\169\152" +let _ = Hashtbl.replace macro2utf8 "MediumSpace" "\226\129\159" +let _ = Hashtbl.replace macro2utf8 "boxvH" "\226\149\170" +let _ = Hashtbl.replace macro2utf8 "Nacute" "\197\131" +let _ = Hashtbl.replace macro2utf8 "nGtv" "\226\137\171\204\184\239\184\128" +let _ = Hashtbl.replace macro2utf8 "Mopf" "\240\157\149\132" +let _ = Hashtbl.replace macro2utf8 "dfisht" "\226\165\191" +let _ = Hashtbl.replace macro2utf8 "boxvL" "\226\149\161" +let _ = Hashtbl.replace macro2utf8 "pertenk" "\226\128\177" +let _ = Hashtbl.replace macro2utf8 "NotPrecedes" "\226\138\128" +let _ = Hashtbl.replace macro2utf8 "profalar" "\226\140\174" +let _ = Hashtbl.replace macro2utf8 "roplus" "\226\168\174" +let _ = Hashtbl.replace macro2utf8 "boxvR" "\226\149\158" +let _ = Hashtbl.replace macro2utf8 "utrif" "\226\150\180" +let _ = Hashtbl.replace macro2utf8 "uHar" "\226\165\163" +let _ = Hashtbl.replace macro2utf8 "nltrie" "\226\139\172" +let _ = Hashtbl.replace macro2utf8 "NotNestedGreaterGreater" "\226\146\162\204\184" +let _ = Hashtbl.replace macro2utf8 "smtes" "\226\170\172\239\184\128" +let _ = Hashtbl.replace macro2utf8 "LeftAngleBracket" "\226\140\169" +let _ = Hashtbl.replace macro2utf8 "iogon" "\196\175" +let _ = Hashtbl.replace macro2utf8 "ExponentialE" "\226\133\135" +let _ = Hashtbl.replace macro2utf8 "Topf" "\240\157\149\139" +let _ = Hashtbl.replace macro2utf8 "GreaterEqual" "\226\137\165" +let _ = Hashtbl.replace macro2utf8 "DownTee" "\226\138\164" +let _ = Hashtbl.replace macro2utf8 "boxul" "\226\148\152" +let _ = Hashtbl.replace macro2utf8 "wreath" "\226\137\128" +let _ = Hashtbl.replace macro2utf8 "sigma" "\207\131" +let _ = Hashtbl.replace macro2utf8 "ENG" "\197\138" +let _ = Hashtbl.replace macro2utf8 "Ncedil" "\197\133" +let _ = Hashtbl.replace macro2utf8 "ecy" "\209\141" +let _ = Hashtbl.replace macro2utf8 "nsubset" "\226\138\132" +let _ = Hashtbl.replace macro2utf8 "LessFullEqual" "\226\137\166" +let _ = Hashtbl.replace macro2utf8 "bsolb" "\226\167\133" +let _ = Hashtbl.replace macro2utf8 "boxur" "\226\148\148" +let _ = Hashtbl.replace macro2utf8 "ThinSpace" "\226\128\137" +let _ = Hashtbl.replace macro2utf8 "supdsub" "\226\171\152" +let _ = Hashtbl.replace macro2utf8 "colone" "\226\137\148" +let _ = Hashtbl.replace macro2utf8 "curren" "\194\164" +let _ = Hashtbl.replace macro2utf8 "boxvh" "\226\148\188" +let _ = Hashtbl.replace macro2utf8 "ecaron" "\196\155" +let _ = Hashtbl.replace macro2utf8 "UnderBrace" "\239\184\184" +let _ = Hashtbl.replace macro2utf8 "caron" "\203\135" +let _ = Hashtbl.replace macro2utf8 "ultri" "\226\151\184" +let _ = Hashtbl.replace macro2utf8 "boxvl" "\226\148\164" +let _ = Hashtbl.replace macro2utf8 "scap" "\226\137\191" +let _ = Hashtbl.replace macro2utf8 "boxvr" "\226\148\156" +let _ = Hashtbl.replace macro2utf8 "bopf" "\240\157\149\147" +let _ = Hashtbl.replace macro2utf8 "pfr" "\240\157\148\173" +let _ = Hashtbl.replace macro2utf8 "nspar" "\226\136\166\239\184\128" +let _ = Hashtbl.replace macro2utf8 "NegativeMediumSpace" "\226\129\159\239\184\128" +let _ = Hashtbl.replace macro2utf8 "simgE" "\226\170\160" +let _ = Hashtbl.replace macro2utf8 "nvDash" "\226\138\173" +let _ = Hashtbl.replace macro2utf8 "NotGreaterFullEqual" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "uparrow" "\226\134\145" +let _ = Hashtbl.replace macro2utf8 "nsupset" "\226\138\133" +let _ = Hashtbl.replace macro2utf8 "simeq" "\226\137\131" +let _ = Hashtbl.replace macro2utf8 "Zcy" "\208\151" +let _ = Hashtbl.replace macro2utf8 "RightTriangle" "\226\138\179" +let _ = Hashtbl.replace macro2utf8 "Lang" "\227\128\138" +let _ = Hashtbl.replace macro2utf8 "Ucirc" "\195\155" +let _ = Hashtbl.replace macro2utf8 "iopf" "\240\157\149\154" +let _ = Hashtbl.replace macro2utf8 "leftrightsquigarrow" "\226\134\173" +let _ = Hashtbl.replace macro2utf8 "Gscr" "\240\157\146\162" +let _ = Hashtbl.replace macro2utf8 "lfloor" "\226\140\138" +let _ = Hashtbl.replace macro2utf8 "lbbrk" "\227\128\148" +let _ = Hashtbl.replace macro2utf8 "bigvee" "\226\139\129" +let _ = Hashtbl.replace macro2utf8 "ordf" "\194\170" +let _ = Hashtbl.replace macro2utf8 "rsquo" "\226\128\153" +let _ = Hashtbl.replace macro2utf8 "parallel" "\226\136\165" +let _ = Hashtbl.replace macro2utf8 "half" "\194\189" +let _ = Hashtbl.replace macro2utf8 "supseteq" "\226\138\135" +let _ = Hashtbl.replace macro2utf8 "ngeqq" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "popf" "\240\157\149\161" +let _ = Hashtbl.replace macro2utf8 "NonBreakingSpace" "\194\160" +let _ = Hashtbl.replace macro2utf8 "softcy" "\209\140" +let _ = Hashtbl.replace macro2utf8 "ordm" "\194\186" +let _ = Hashtbl.replace macro2utf8 "Nscr" "\240\157\146\169" +let _ = Hashtbl.replace macro2utf8 "owns" "\226\136\139" +let _ = Hashtbl.replace macro2utf8 "phi" "\207\149" +let _ = Hashtbl.replace macro2utf8 "efr" "\240\157\148\162" +let _ = Hashtbl.replace macro2utf8 "nesear" "\226\164\168" +let _ = Hashtbl.replace macro2utf8 "marker" "\226\150\174" +let _ = Hashtbl.replace macro2utf8 "lneq" "\226\137\168" +let _ = Hashtbl.replace macro2utf8 "parallet" "????" +let _ = Hashtbl.replace macro2utf8 "ndash" "\226\128\147" +let _ = Hashtbl.replace macro2utf8 "DoubleLeftTee" "\226\171\164" +let _ = Hashtbl.replace macro2utf8 "lArr" "\226\135\144" +let _ = Hashtbl.replace macro2utf8 "becaus" "\226\136\181" +let _ = Hashtbl.replace macro2utf8 "RightTee" "\226\138\162" +let _ = Hashtbl.replace macro2utf8 "Ocy" "\208\158" +let _ = Hashtbl.replace macro2utf8 "ntlg" "\226\137\184" +let _ = Hashtbl.replace macro2utf8 "cacute" "\196\135" +let _ = Hashtbl.replace macro2utf8 "wopf" "\240\157\149\168" +let _ = Hashtbl.replace macro2utf8 "Cup" "\226\139\147" +let _ = Hashtbl.replace macro2utf8 "Uscr" "\240\157\146\176" +let _ = Hashtbl.replace macro2utf8 "NotHumpEqual" "\226\137\143\204\184" +let _ = Hashtbl.replace macro2utf8 "rnmid" "\226\171\174" +let _ = Hashtbl.replace macro2utf8 "nsupE" "\226\138\137" +let _ = Hashtbl.replace macro2utf8 "bemptyv" "\226\166\176" +let _ = Hashtbl.replace macro2utf8 "lsqb" "[" +let _ = Hashtbl.replace macro2utf8 "nrarr" "\226\134\155" +let _ = Hashtbl.replace macro2utf8 "egs" "\226\139\157" +let _ = Hashtbl.replace macro2utf8 "reals" "\226\132\157" +let _ = Hashtbl.replace macro2utf8 "CupCap" "\226\137\141" +let _ = Hashtbl.replace macro2utf8 "Oacute" "\195\147" +let _ = Hashtbl.replace macro2utf8 "Zfr" "\226\132\168" +let _ = Hashtbl.replace macro2utf8 "ReverseEquilibrium" "\226\135\139" +let _ = Hashtbl.replace macro2utf8 "ccedil" "\195\167" +let _ = Hashtbl.replace macro2utf8 "bigtriangleup" "\226\150\179" +let _ = Hashtbl.replace macro2utf8 "piv" "\207\150" +let _ = Hashtbl.replace macro2utf8 "cirscir" "\226\167\130" +let _ = Hashtbl.replace macro2utf8 "exists" "\226\136\131" +let _ = Hashtbl.replace macro2utf8 "Uarrocir" "\226\165\137" +let _ = Hashtbl.replace macro2utf8 "Dcy" "\208\148" +let _ = Hashtbl.replace macro2utf8 "cscr" "\240\157\146\184" +let _ = Hashtbl.replace macro2utf8 "zcaron" "\197\190" +let _ = Hashtbl.replace macro2utf8 "isinE" "\226\139\185" +let _ = Hashtbl.replace macro2utf8 "gtcir" "\226\169\186" +let _ = Hashtbl.replace macro2utf8 "hookrightarrow" "\226\134\170" +let _ = Hashtbl.replace macro2utf8 "Int" "\226\136\172" +let _ = Hashtbl.replace macro2utf8 "nsupe" "\226\138\137" +let _ = Hashtbl.replace macro2utf8 "dotplus" "\226\136\148" +let _ = Hashtbl.replace macro2utf8 "ncup" "\226\169\130" +let _ = Hashtbl.replace macro2utf8 "jscr" "\240\157\146\191" +let _ = Hashtbl.replace macro2utf8 "angmsdaa" "\226\166\168" +let _ = Hashtbl.replace macro2utf8 "Iukcy" "\208\134" +let _ = Hashtbl.replace macro2utf8 "flat" "\226\153\173" +let _ = Hashtbl.replace macro2utf8 "bNot" "\226\171\173" +let _ = Hashtbl.replace macro2utf8 "angmsdab" "\226\166\169" +let _ = Hashtbl.replace macro2utf8 "angmsdac" "\226\166\170" +let _ = Hashtbl.replace macro2utf8 "xdtri" "\226\150\189" +let _ = Hashtbl.replace macro2utf8 "iota" "\206\185" +let _ = Hashtbl.replace macro2utf8 "angmsdad" "\226\166\171" +let _ = Hashtbl.replace macro2utf8 "angmsdae" "\226\166\172" +let _ = Hashtbl.replace macro2utf8 "rightarrowtail" "\226\134\163" +let _ = Hashtbl.replace macro2utf8 "angmsdaf" "\226\166\173" +let _ = Hashtbl.replace macro2utf8 "Ocirc" "\195\148" +let _ = Hashtbl.replace macro2utf8 "angmsdag" "\226\166\174" +let _ = Hashtbl.replace macro2utf8 "Ofr" "\240\157\148\146" +let _ = Hashtbl.replace macro2utf8 "maltese" "\226\156\160" +let _ = Hashtbl.replace macro2utf8 "angmsdah" "\226\166\175" +let _ = Hashtbl.replace macro2utf8 "Del" "\226\136\135" +let _ = Hashtbl.replace macro2utf8 "Barwed" "\226\140\134" +let _ = Hashtbl.replace macro2utf8 "drbkarow" "\226\164\144" +let _ = Hashtbl.replace macro2utf8 "qscr" "\240\157\147\134" +let _ = Hashtbl.replace macro2utf8 "ETH" "\195\144" +let _ = Hashtbl.replace macro2utf8 "operp" "\226\166\185" +let _ = Hashtbl.replace macro2utf8 "daleth" "\226\132\184" +let _ = Hashtbl.replace macro2utf8 "bull" "\226\128\162" +let _ = Hashtbl.replace macro2utf8 "simlE" "\226\170\159" +let _ = Hashtbl.replace macro2utf8 "lsquo" "\226\128\152" +let _ = Hashtbl.replace macro2utf8 "Larr" "\226\134\158" +let _ = Hashtbl.replace macro2utf8 "curarr" "\226\134\183" +let _ = Hashtbl.replace macro2utf8 "blacktriangleleft" "\226\151\130" +let _ = Hashtbl.replace macro2utf8 "hellip" "\226\128\166" +let _ = Hashtbl.replace macro2utf8 "DoubleVerticalBar" "\226\136\165" +let _ = Hashtbl.replace macro2utf8 "rBarr" "\226\164\143" +let _ = Hashtbl.replace macro2utf8 "chcy" "\209\135" +let _ = Hashtbl.replace macro2utf8 "varpi" "\207\150" +let _ = Hashtbl.replace macro2utf8 "Cconint" "\226\136\176" +let _ = Hashtbl.replace macro2utf8 "xlarr" "\239\149\182" +let _ = Hashtbl.replace macro2utf8 "xscr" "\240\157\147\141" +let _ = Hashtbl.replace macro2utf8 "DoubleLongRightArrow" "\239\149\186" +let _ = Hashtbl.replace macro2utf8 "CounterClockwiseContourIntegral" "\226\136\179" +let _ = Hashtbl.replace macro2utf8 "urcrop" "\226\140\142" +let _ = Hashtbl.replace macro2utf8 "RightAngleBracket" "\226\140\170" +let _ = Hashtbl.replace macro2utf8 "Rcaron" "\197\152" +let _ = Hashtbl.replace macro2utf8 "latail" "\226\164\153" +let _ = Hashtbl.replace macro2utf8 "pitchfork" "\226\139\148" +let _ = Hashtbl.replace macro2utf8 "nvinfin" "\226\167\158" +let _ = Hashtbl.replace macro2utf8 "hcirc" "\196\165" +let _ = Hashtbl.replace macro2utf8 "nexist" "\226\136\132" +let _ = Hashtbl.replace macro2utf8 "checkmark" "\226\156\147" +let _ = Hashtbl.replace macro2utf8 "tridot" "\226\151\172" +let _ = Hashtbl.replace macro2utf8 "vcy" "\208\178" +let _ = Hashtbl.replace macro2utf8 "isins" "\226\139\180" +let _ = Hashtbl.replace macro2utf8 "fllig" "\239\172\130" +let _ = Hashtbl.replace macro2utf8 "Dfr" "\240\157\148\135" +let _ = Hashtbl.replace macro2utf8 "hercon" "\226\138\185" +let _ = Hashtbl.replace macro2utf8 "gEl" "\226\139\155" +let _ = Hashtbl.replace macro2utf8 "bump" "\226\137\142" +let _ = Hashtbl.replace macro2utf8 "aleph" "\226\132\181" +let _ = Hashtbl.replace macro2utf8 "Ubreve" "\197\172" +let _ = Hashtbl.replace macro2utf8 "isinv" "\226\136\136" +let _ = Hashtbl.replace macro2utf8 "smile" "\226\140\163" +let _ = Hashtbl.replace macro2utf8 "llcorner" "\226\140\158" +let _ = Hashtbl.replace macro2utf8 "boxH" "\226\149\144" +let _ = Hashtbl.replace macro2utf8 "ecir" "\226\137\150" +let _ = Hashtbl.replace macro2utf8 "varnothing" "\226\136\133" +let _ = Hashtbl.replace macro2utf8 "iuml" "\195\175" +let _ = Hashtbl.replace macro2utf8 "mlcp" "\226\171\155" +let _ = Hashtbl.replace macro2utf8 "leftrightharpoons" "\226\135\139" +let _ = Hashtbl.replace macro2utf8 "ncong" "\226\137\135" +let _ = Hashtbl.replace macro2utf8 "Vert" "\226\128\150" +let _ = Hashtbl.replace macro2utf8 "vee" "\226\136\168" +let _ = Hashtbl.replace macro2utf8 "star" "\226\139\134" +let _ = Hashtbl.replace macro2utf8 "boxV" "\226\149\145" +let _ = Hashtbl.replace macro2utf8 "LeftRightArrow" "\226\134\148" +let _ = Hashtbl.replace macro2utf8 "leftrightarrow" "\226\134\148" +let _ = Hashtbl.replace macro2utf8 "lstrok" "\197\130" +let _ = Hashtbl.replace macro2utf8 "ell" "\226\132\147" +let _ = Hashtbl.replace macro2utf8 "VerticalSeparator" "\226\157\152" +let _ = Hashtbl.replace macro2utf8 "Ubrcy" "\208\142" +let _ = Hashtbl.replace macro2utf8 "NotGreater" "\226\137\175" +let _ = Hashtbl.replace macro2utf8 "Abreve" "\196\130" +let _ = Hashtbl.replace macro2utf8 "TildeTilde" "\226\137\136" +let _ = Hashtbl.replace macro2utf8 "CircleTimes" "\226\138\151" +let _ = Hashtbl.replace macro2utf8 "subsetneq" "\226\138\138" +let _ = Hashtbl.replace macro2utf8 "ltcc" "\226\170\166" +let _ = Hashtbl.replace macro2utf8 "els" "\226\139\156" +let _ = Hashtbl.replace macro2utf8 "succneqq" "\226\170\182" +let _ = Hashtbl.replace macro2utf8 "kcy" "\208\186" +let _ = Hashtbl.replace macro2utf8 "nshortmid" "\226\136\164\239\184\128" +let _ = Hashtbl.replace macro2utf8 "mldr" "\226\128\166" +let _ = Hashtbl.replace macro2utf8 "harr" "\226\134\148" +let _ = Hashtbl.replace macro2utf8 "gimel" "\226\132\183" +let _ = Hashtbl.replace macro2utf8 "Otimes" "\226\168\183" +let _ = Hashtbl.replace macro2utf8 "vsubnE" "\226\138\138\239\184\128" +let _ = Hashtbl.replace macro2utf8 "ltdot" "\226\139\150" +let _ = Hashtbl.replace macro2utf8 "boxh" "\226\148\128" +let _ = Hashtbl.replace macro2utf8 "notin" "\226\136\137" +let _ = Hashtbl.replace macro2utf8 "RuleDelayed" "\226\167\180" +let _ = Hashtbl.replace macro2utf8 "sqsube" "\226\138\145" +let _ = Hashtbl.replace macro2utf8 "macr" "\194\175" +let _ = Hashtbl.replace macro2utf8 "Icirc" "\195\142" +let _ = Hashtbl.replace macro2utf8 "comma" "," +let _ = Hashtbl.replace macro2utf8 "Cayleys" "\226\132\173" +let _ = Hashtbl.replace macro2utf8 "rightleftharpoons" "\226\135\140" +let _ = Hashtbl.replace macro2utf8 "Rarrtl" "\226\164\150" +let _ = Hashtbl.replace macro2utf8 "SquareSubsetEqual" "\226\138\145" +let _ = Hashtbl.replace macro2utf8 "NotGreaterEqual" "\226\137\177\226\131\165" +let _ = Hashtbl.replace macro2utf8 "vfr" "\240\157\148\179" +let _ = Hashtbl.replace macro2utf8 "utri" "\226\150\181" +let _ = Hashtbl.replace macro2utf8 "simne" "\226\137\134" +let _ = Hashtbl.replace macro2utf8 "LeftUpVectorBar" "\226\165\152" +let _ = Hashtbl.replace macro2utf8 "hksearow" "\226\164\165" +let _ = Hashtbl.replace macro2utf8 "boxv" "\226\148\130" +let _ = Hashtbl.replace macro2utf8 "curvearrowleft" "\226\134\182" +let _ = Hashtbl.replace macro2utf8 "eng" "\197\139" +let _ = Hashtbl.replace macro2utf8 "gtrarr" "\226\165\184" +let _ = Hashtbl.replace macro2utf8 "iecy" "\208\181" +let _ = Hashtbl.replace macro2utf8 "varr" "\226\134\149" +let _ = Hashtbl.replace macro2utf8 "lBarr" "\226\164\142" +let _ = Hashtbl.replace macro2utf8 "ker" "ker" +let _ = Hashtbl.replace macro2utf8 "imath" "\196\177" +let _ = Hashtbl.replace macro2utf8 "Dstrok" "\196\144" +let _ = Hashtbl.replace macro2utf8 "rlarr" "\226\135\132" +let _ = Hashtbl.replace macro2utf8 "leftleftarrows" "\226\135\135" +let _ = Hashtbl.replace macro2utf8 "DifferentialD" "\226\133\134" +let _ = Hashtbl.replace macro2utf8 "because" "\226\136\181" +let _ = Hashtbl.replace macro2utf8 "ulcrop" "\226\140\143" +let _ = Hashtbl.replace macro2utf8 "prE" "\226\170\175" +let _ = Hashtbl.replace macro2utf8 "oast" "\226\138\155" +let _ = Hashtbl.replace macro2utf8 "DotEqual" "\226\137\144" +let _ = Hashtbl.replace macro2utf8 "vsubne" "\226\138\138\239\184\128" +let _ = Hashtbl.replace macro2utf8 "hbar" "\226\132\143\239\184\128" +let _ = Hashtbl.replace macro2utf8 "subset" "\226\138\130" +let _ = Hashtbl.replace macro2utf8 "UpTeeArrow" "\226\134\165" +let _ = Hashtbl.replace macro2utf8 "LeftFloor" "\226\140\138" +let _ = Hashtbl.replace macro2utf8 "kfr" "\240\157\148\168" +let _ = Hashtbl.replace macro2utf8 "nisd" "\226\139\186" +let _ = Hashtbl.replace macro2utf8 "scnE" "\226\170\182" +let _ = Hashtbl.replace macro2utf8 "Ucy" "\208\163" +let _ = Hashtbl.replace macro2utf8 "nprec" "\226\138\128" +let _ = Hashtbl.replace macro2utf8 "ltrPar" "\226\166\150" +let _ = Hashtbl.replace macro2utf8 "Scaron" "\197\160" +let _ = Hashtbl.replace macro2utf8 "InvisibleComma" "\226\128\139" +let _ = Hashtbl.replace macro2utf8 "SquareUnion" "\226\138\148" +let _ = Hashtbl.replace macro2utf8 "ffllig" "\239\172\132" +let _ = Hashtbl.replace macro2utf8 "approxeq" "\226\137\138" +let _ = Hashtbl.replace macro2utf8 "yacute" "\195\189" +let _ = Hashtbl.replace macro2utf8 "pre" "\226\170\175" +let _ = Hashtbl.replace macro2utf8 "nsqsupe" "\226\139\163" +let _ = Hashtbl.replace macro2utf8 "supset" "\226\138\131" +let _ = Hashtbl.replace macro2utf8 "bsolhsub" "\\\226\138\130" +let _ = Hashtbl.replace macro2utf8 "nshortparallel" "\226\136\166\239\184\128" +let _ = Hashtbl.replace macro2utf8 "lozenge" "\226\151\138" +let _ = Hashtbl.replace macro2utf8 "lnot" "\194\172" +let _ = Hashtbl.replace macro2utf8 "Dopf" "\240\157\148\187" +let _ = Hashtbl.replace macro2utf8 "leftharpoonup" "\226\134\188" +let _ = Hashtbl.replace macro2utf8 "Jcy" "\208\153" +let _ = Hashtbl.replace macro2utf8 "rightarrow" "\226\134\146" +let _ = Hashtbl.replace macro2utf8 "ntriangleright" "\226\139\171" +let _ = Hashtbl.replace macro2utf8 "Ccirc" "\196\136" +let _ = Hashtbl.replace macro2utf8 "eacute" "\195\169" +let _ = Hashtbl.replace macro2utf8 "acute" "\194\180" +let _ = Hashtbl.replace macro2utf8 "Precedes" "\226\137\186" +let _ = Hashtbl.replace macro2utf8 "middot" "\194\183" +let _ = Hashtbl.replace macro2utf8 "lHar" "\226\165\162" +let _ = Hashtbl.replace macro2utf8 "eparsl" "\226\167\163" +let _ = Hashtbl.replace macro2utf8 "psi" "\207\136" +let _ = Hashtbl.replace macro2utf8 "parsl" "\226\136\165\239\184\128" +let _ = Hashtbl.replace macro2utf8 "UpperLeftArrow" "\226\134\150" +let _ = Hashtbl.replace macro2utf8 "oror" "\226\169\150" +let _ = Hashtbl.replace macro2utf8 "Kopf" "\240\157\149\130" +let _ = Hashtbl.replace macro2utf8 "apacir" "\226\169\175" +let _ = Hashtbl.replace macro2utf8 "dharl" "\226\135\131" +let _ = Hashtbl.replace macro2utf8 "nequiv" "\226\137\162" +let _ = Hashtbl.replace macro2utf8 "rightleftarrows" "\226\135\132" +let _ = Hashtbl.replace macro2utf8 "UnderParenthesis" "\239\184\182" +let _ = Hashtbl.replace macro2utf8 "notni" "\226\136\140" +let _ = Hashtbl.replace macro2utf8 "dagger" "\226\128\160" +let _ = Hashtbl.replace macro2utf8 "dharr" "\226\135\130" +let _ = Hashtbl.replace macro2utf8 "twoheadleftarrow" "\226\134\158" +let _ = Hashtbl.replace macro2utf8 "frac12" "\194\189" +let _ = Hashtbl.replace macro2utf8 "varsubsetneqq" "\226\138\138\239\184\128" +let _ = Hashtbl.replace macro2utf8 "frac13" "\226\133\147" +let _ = Hashtbl.replace macro2utf8 "Ufr" "\240\157\148\152" +let _ = Hashtbl.replace macro2utf8 "NestedLessLess" "\226\137\170" +let _ = Hashtbl.replace macro2utf8 "llarr" "\226\135\135" +let _ = Hashtbl.replace macro2utf8 "frac14" "\194\188" +let _ = Hashtbl.replace macro2utf8 "frac15" "\226\133\149" +let _ = Hashtbl.replace macro2utf8 "Ropf" "\226\132\157" +let _ = Hashtbl.replace macro2utf8 "frac16" "\226\133\153" +let _ = Hashtbl.replace macro2utf8 "lrtri" "\226\138\191" +let _ = Hashtbl.replace macro2utf8 "frac18" "\226\133\155" +let _ = Hashtbl.replace macro2utf8 "cedil" "\194\184" +let _ = Hashtbl.replace macro2utf8 "subsim" "\226\171\135" +let _ = Hashtbl.replace macro2utf8 "PrecedesTilde" "\226\137\190" +let _ = Hashtbl.replace macro2utf8 "igrave" "\195\172" +let _ = Hashtbl.replace macro2utf8 "gjcy" "\209\147" +let _ = Hashtbl.replace macro2utf8 "LeftVector" "\226\134\188" +let _ = Hashtbl.replace macro2utf8 "notniva" "\226\136\140" +let _ = Hashtbl.replace macro2utf8 "notnivb" "\226\139\190" +let _ = Hashtbl.replace macro2utf8 "ogon" "\203\155" +let _ = Hashtbl.replace macro2utf8 "notnivc" "\226\139\189" +let _ = Hashtbl.replace macro2utf8 "Yopf" "\240\157\149\144" +let _ = Hashtbl.replace macro2utf8 "there4" "\226\136\180" +let _ = Hashtbl.replace macro2utf8 "udarr" "\226\135\133" +let _ = Hashtbl.replace macro2utf8 "bkarow" "\226\164\141" +let _ = Hashtbl.replace macro2utf8 "frac23" "\226\133\148" +let _ = Hashtbl.replace macro2utf8 "frac25" "\226\133\150" +let _ = Hashtbl.replace macro2utf8 "njcy" "\209\154" +let _ = Hashtbl.replace macro2utf8 "Dashv" "\226\171\164" +let _ = Hashtbl.replace macro2utf8 "eta" "\206\183" +let _ = Hashtbl.replace macro2utf8 "bcong" "\226\137\140" +let _ = Hashtbl.replace macro2utf8 "Ugrave" "\195\153" +let _ = Hashtbl.replace macro2utf8 "csube" "\226\171\145" +let _ = Hashtbl.replace macro2utf8 "clubs" "\226\153\163" +let _ = Hashtbl.replace macro2utf8 "supmult" "\226\171\130" +let _ = Hashtbl.replace macro2utf8 "MinusPlus" "\226\136\147" +let _ = Hashtbl.replace macro2utf8 "Jfr" "\240\157\148\141" +let _ = Hashtbl.replace macro2utf8 "ensp" "\226\128\130" +let _ = Hashtbl.replace macro2utf8 "ucirc" "\195\187" +let _ = Hashtbl.replace macro2utf8 "supsim" "\226\171\136" +let _ = Hashtbl.replace macro2utf8 "eth" "\195\176" +let _ = Hashtbl.replace macro2utf8 "OverBrace" "\239\184\183" +let _ = Hashtbl.replace macro2utf8 "Dot" "\194\168" +let _ = Hashtbl.replace macro2utf8 "xcap" "\226\139\130" +let _ = Hashtbl.replace macro2utf8 "vangrt" "\226\138\190" +let _ = Hashtbl.replace macro2utf8 "NotSubsetEqual" "\226\138\136" +let _ = Hashtbl.replace macro2utf8 "frac34" "\194\190" +let _ = Hashtbl.replace macro2utf8 "frac35" "\226\133\151" +let _ = Hashtbl.replace macro2utf8 "planck" "\226\132\143\239\184\128" +let _ = Hashtbl.replace macro2utf8 "lnsim" "\226\139\166" +let _ = Hashtbl.replace macro2utf8 "gopf" "\240\157\149\152" +let _ = Hashtbl.replace macro2utf8 "frac38" "\226\133\156" +let _ = Hashtbl.replace macro2utf8 "DotDot" "\226\131\156" +let _ = Hashtbl.replace macro2utf8 "mapstoup" "\226\134\165" +let _ = Hashtbl.replace macro2utf8 "Escr" "\226\132\176" +let _ = Hashtbl.replace macro2utf8 "Integral" "\226\136\171" +let _ = Hashtbl.replace macro2utf8 "Agrave" "\195\128" +let _ = Hashtbl.replace macro2utf8 "longleftarrow" "????;" +let _ = Hashtbl.replace macro2utf8 "Tcaron" "\197\164" +let _ = Hashtbl.replace macro2utf8 "nopf" "\240\157\149\159" +let _ = Hashtbl.replace macro2utf8 "LongLeftRightArrow" "\239\149\184" +let _ = Hashtbl.replace macro2utf8 "Emacr" "\196\146" +let _ = Hashtbl.replace macro2utf8 "omid" "\226\166\182" +let _ = Hashtbl.replace macro2utf8 "spades" "\226\153\160" +let _ = Hashtbl.replace macro2utf8 "naturals" "\226\132\149" +let _ = Hashtbl.replace macro2utf8 "Lscr" "\226\132\146" +let _ = Hashtbl.replace macro2utf8 "udblac" "\197\177" +let _ = Hashtbl.replace macro2utf8 "SucceedsTilde" "\226\137\191" +let _ = Hashtbl.replace macro2utf8 "frac45" "\226\133\152" +let _ = Hashtbl.replace macro2utf8 "clubsuit" "\226\153\163" +let _ = Hashtbl.replace macro2utf8 "mumap" "\226\138\184" +let _ = Hashtbl.replace macro2utf8 "vltri" "\226\138\178" +let _ = Hashtbl.replace macro2utf8 "LeftArrowBar" "\226\135\164" +let _ = Hashtbl.replace macro2utf8 "zacute" "\197\186" +let _ = Hashtbl.replace macro2utf8 "szlig" "\195\159" +let _ = Hashtbl.replace macro2utf8 "suplarr" "\226\165\187" +let _ = Hashtbl.replace macro2utf8 "RightDownVector" "\226\135\130" +let _ = Hashtbl.replace macro2utf8 "male" "\226\153\130" +let _ = Hashtbl.replace macro2utf8 "RightDownVectorBar" "\226\165\149" +let _ = Hashtbl.replace macro2utf8 "gdot" "\196\161" +let _ = Hashtbl.replace macro2utf8 "nleqq" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "uopf" "\240\157\149\166" +let _ = Hashtbl.replace macro2utf8 "YIcy" "\208\135" +let _ = Hashtbl.replace macro2utf8 "Sscr" "\240\157\146\174" +let _ = Hashtbl.replace macro2utf8 "empty" "\226\136\133\239\184\128" +let _ = Hashtbl.replace macro2utf8 "Vdash" "\226\138\169" +let _ = Hashtbl.replace macro2utf8 "sqsubset" "\226\138\143" +let _ = Hashtbl.replace macro2utf8 "efDot" "\226\137\146" +let _ = Hashtbl.replace macro2utf8 "times" "\195\151" +let _ = Hashtbl.replace macro2utf8 "Oslash" "\195\152" +let _ = Hashtbl.replace macro2utf8 "itilde" "\196\169" +let _ = Hashtbl.replace macro2utf8 "frac56" "\226\133\154" +let _ = Hashtbl.replace macro2utf8 "numero" "\226\132\150" +let _ = Hashtbl.replace macro2utf8 "malt" "\226\156\160" +let _ = Hashtbl.replace macro2utf8 "npart" "\226\136\130\204\184" +let _ = Hashtbl.replace macro2utf8 "frac58" "\226\133\157" +let _ = Hashtbl.replace macro2utf8 "Zscr" "\240\157\146\181" +let _ = Hashtbl.replace macro2utf8 "integers" "\226\132\164" +let _ = Hashtbl.replace macro2utf8 "CloseCurlyQuote" "\226\128\153" +let _ = Hashtbl.replace macro2utf8 "NewLine" "\n" +let _ = Hashtbl.replace macro2utf8 "fcy" "\209\132" +let _ = Hashtbl.replace macro2utf8 "nwarr" "\226\134\150" +let _ = Hashtbl.replace macro2utf8 "thicksim" "\226\136\188\239\184\128" +let _ = Hashtbl.replace macro2utf8 "nprcue" "\226\139\160" +let _ = Hashtbl.replace macro2utf8 "lcub" "{" +let _ = Hashtbl.replace macro2utf8 "forall" "\226\136\128" +let _ = Hashtbl.replace macro2utf8 "plusacir" "\226\168\163" +let _ = Hashtbl.replace macro2utf8 "ascr" "\240\157\146\182" +let _ = Hashtbl.replace macro2utf8 "plustwo" "\226\168\167" +let _ = Hashtbl.replace macro2utf8 "Utilde" "\197\168" +let _ = Hashtbl.replace macro2utf8 "lambda" "\206\187" +let _ = Hashtbl.replace macro2utf8 "odash" "\226\138\157" +let _ = Hashtbl.replace macro2utf8 "iukcy" "\209\150" +let _ = Hashtbl.replace macro2utf8 "sqsupset" "\226\138\144" +let _ = Hashtbl.replace macro2utf8 "Racute" "\197\148" +let _ = Hashtbl.replace macro2utf8 "Longleftarrow" "????" +let _ = Hashtbl.replace macro2utf8 "capcap" "\226\169\139" +let _ = Hashtbl.replace macro2utf8 "ocirc" "\195\180" +let _ = Hashtbl.replace macro2utf8 "nless" "\226\137\174" +let _ = Hashtbl.replace macro2utf8 "Wedge" "\226\139\128" +let _ = Hashtbl.replace macro2utf8 "qfr" "\240\157\148\174" +let _ = Hashtbl.replace macro2utf8 "natur" "\226\153\174" +let _ = Hashtbl.replace macro2utf8 "hscr" "\240\157\146\189" +let _ = Hashtbl.replace macro2utf8 "ldca" "\226\164\182" +let _ = Hashtbl.replace macro2utf8 "ClockwiseContourIntegral" "\226\136\178" +let _ = Hashtbl.replace macro2utf8 "exp" "exp" +let _ = Hashtbl.replace macro2utf8 "RightTeeArrow" "\226\134\166" +let _ = Hashtbl.replace macro2utf8 "orarr" "\226\134\187" +let _ = Hashtbl.replace macro2utf8 "tanh" "tanh" +let _ = Hashtbl.replace macro2utf8 "frac78" "\226\133\158" +let _ = Hashtbl.replace macro2utf8 "Atilde" "\195\131" +let _ = Hashtbl.replace macro2utf8 "arcsin" "arcsin" +let _ = Hashtbl.replace macro2utf8 "Rcedil" "\197\150" +let _ = Hashtbl.replace macro2utf8 "oscr" "\226\132\180" +let _ = Hashtbl.replace macro2utf8 "InvisibleTimes" "\226\129\162" +let _ = Hashtbl.replace macro2utf8 "sime" "\226\137\131" +let _ = Hashtbl.replace macro2utf8 "simg" "\226\170\158" +let _ = Hashtbl.replace macro2utf8 "Conint" "\226\136\175" +let _ = Hashtbl.replace macro2utf8 "Yuml" "\197\184" +let _ = Hashtbl.replace macro2utf8 "rlhar" "\226\135\140" +let _ = Hashtbl.replace macro2utf8 "rarrbfs" "\226\164\160" +let _ = Hashtbl.replace macro2utf8 "siml" "\226\170\157" +let _ = Hashtbl.replace macro2utf8 "DownRightVectorBar" "\226\165\151" +let _ = Hashtbl.replace macro2utf8 "vscr" "\240\157\147\139" +let _ = Hashtbl.replace macro2utf8 "divide" "\195\183" +let _ = Hashtbl.replace macro2utf8 "PlusMinus" "\194\177" +let _ = Hashtbl.replace macro2utf8 "ffr" "\240\157\148\163" +let _ = Hashtbl.replace macro2utf8 "DownLeftTeeVector" "\226\165\158" +let _ = Hashtbl.replace macro2utf8 "EmptySmallSquare" "\226\151\189" +let _ = Hashtbl.replace macro2utf8 "SHCHcy" "\208\169" +let _ = Hashtbl.replace macro2utf8 "cirmid" "\226\171\175" +let _ = Hashtbl.replace macro2utf8 "sigmav" "\207\130" +let _ = Hashtbl.replace macro2utf8 "csub" "\226\171\143" +let _ = Hashtbl.replace macro2utf8 "npar" "\226\136\166" +let _ = Hashtbl.replace macro2utf8 "bsemi" "\226\129\143" +let _ = Hashtbl.replace macro2utf8 "swArr" "\226\135\153" +let _ = Hashtbl.replace macro2utf8 "Pcy" "\208\159" +let _ = Hashtbl.replace macro2utf8 "sinh" "sinh" +let _ = Hashtbl.replace macro2utf8 "lharul" "\226\165\170" +let _ = Hashtbl.replace macro2utf8 "Jukcy" "\208\132" +let _ = Hashtbl.replace macro2utf8 "permil" "\226\128\176" +let _ = Hashtbl.replace macro2utf8 "ndivides" "\226\136\164" +let _ = Hashtbl.replace macro2utf8 "Aring" "\195\133" +let _ = Hashtbl.replace macro2utf8 "longmapsto" "????" +let _ = Hashtbl.replace macro2utf8 "Esim" "\226\169\179" +let _ = Hashtbl.replace macro2utf8 "csup" "\226\171\144" +let _ = Hashtbl.replace macro2utf8 "trie" "\226\137\156" +let _ = Hashtbl.replace macro2utf8 "ubrcy" "\209\158" +let _ = Hashtbl.replace macro2utf8 "NotEqualTilde" "\226\137\130\204\184" +let _ = Hashtbl.replace macro2utf8 "dotminus" "\226\136\184" +let _ = Hashtbl.replace macro2utf8 "diamondsuit" "\226\153\162" +let _ = Hashtbl.replace macro2utf8 "xnis" "\226\139\187" +let _ = Hashtbl.replace macro2utf8 "Eogon" "\196\152" +let _ = Hashtbl.replace macro2utf8 "cuvee" "\226\139\142" +let _ = Hashtbl.replace macro2utf8 "DZcy" "\208\143" +let _ = Hashtbl.replace macro2utf8 "nRightarrow" "\226\135\143" +let _ = Hashtbl.replace macro2utf8 "sqsupe" "\226\138\146" +let _ = Hashtbl.replace macro2utf8 "nsccue" "\226\139\161" +let _ = Hashtbl.replace macro2utf8 "drcrop" "\226\140\140" +let _ = Hashtbl.replace macro2utf8 "DownBreve" "\204\145" +let _ = Hashtbl.replace macro2utf8 "Ecy" "\208\173" +let _ = Hashtbl.replace macro2utf8 "rdquor" "\226\128\157" +let _ = Hashtbl.replace macro2utf8 "rAtail" "\226\164\156" +let _ = Hashtbl.replace macro2utf8 "icirc" "\195\174" +let _ = Hashtbl.replace macro2utf8 "gacute" "\199\181" +let _ = Hashtbl.replace macro2utf8 "hyphen" "\226\128\144" +let _ = Hashtbl.replace macro2utf8 "uuml" "\195\188" +let _ = Hashtbl.replace macro2utf8 "thorn" "\195\190" +let _ = Hashtbl.replace macro2utf8 "ltri" "\226\151\131" +let _ = Hashtbl.replace macro2utf8 "eqslantgtr" "\226\139\157" +let _ = Hashtbl.replace macro2utf8 "DoubleContourIntegral" "\226\136\175" +let _ = Hashtbl.replace macro2utf8 "lescc" "\226\170\168" +let _ = Hashtbl.replace macro2utf8 "DiacriticalGrave" "`" +let _ = Hashtbl.replace macro2utf8 "NotPrecedesEqual" "\226\170\175\204\184" +let _ = Hashtbl.replace macro2utf8 "RightArrow" "\226\134\146" +let _ = Hashtbl.replace macro2utf8 "race" "\226\167\154" +let _ = Hashtbl.replace macro2utf8 "topbot" "\226\140\182" +let _ = Hashtbl.replace macro2utf8 "Pfr" "\240\157\148\147" +let _ = Hashtbl.replace macro2utf8 "napprox" "\226\137\137" +let _ = Hashtbl.replace macro2utf8 "Sacute" "\197\154" +let _ = Hashtbl.replace macro2utf8 "cupor" "\226\169\133" +let _ = Hashtbl.replace macro2utf8 "OverBar" "\194\175" +let _ = Hashtbl.replace macro2utf8 "bepsi" "\207\182" +let _ = Hashtbl.replace macro2utf8 "plankv" "\226\132\143" +let _ = Hashtbl.replace macro2utf8 "lap" "\226\137\178" +let _ = Hashtbl.replace macro2utf8 "orslope" "\226\169\151" +let _ = Hashtbl.replace macro2utf8 "beta" "\206\178" +let _ = Hashtbl.replace macro2utf8 "ShortDownArrow" "\226\140\132\239\184\128" +let _ = Hashtbl.replace macro2utf8 "perp" "\226\138\165" +let _ = Hashtbl.replace macro2utf8 "lat" "\226\170\171" +let _ = Hashtbl.replace macro2utf8 "CenterDot" "\194\183" +let _ = Hashtbl.replace macro2utf8 "urcorner" "\226\140\157" +let _ = Hashtbl.replace macro2utf8 "models" "\226\138\167" +let _ = Hashtbl.replace macro2utf8 "beth" "\226\132\182" +let _ = Hashtbl.replace macro2utf8 "subE" "\226\138\134" +let _ = Hashtbl.replace macro2utf8 "subnE" "\226\138\138" +let _ = Hashtbl.replace macro2utf8 "ldots" "\226\128\166" +let _ = Hashtbl.replace macro2utf8 "yacy" "\209\143" +let _ = Hashtbl.replace macro2utf8 "udhar" "\226\165\174" +let _ = Hashtbl.replace macro2utf8 "Scedil" "\197\158" +let _ = Hashtbl.replace macro2utf8 "subsub" "\226\171\149" +let _ = Hashtbl.replace macro2utf8 "nvrtrie" "\226\139\173\204\184" +let _ = Hashtbl.replace macro2utf8 "Phi" "\206\166" +let _ = Hashtbl.replace macro2utf8 "Efr" "\240\157\148\136" +let _ = Hashtbl.replace macro2utf8 "larrfs" "\226\164\157" +let _ = Hashtbl.replace macro2utf8 "angle" "\226\136\160" +let _ = Hashtbl.replace macro2utf8 "TildeFullEqual" "\226\137\133" +let _ = Hashtbl.replace macro2utf8 "Jcirc" "\196\180" +let _ = Hashtbl.replace macro2utf8 "THORN" "\195\158" +let _ = Hashtbl.replace macro2utf8 "acE" "\226\167\155" +let _ = Hashtbl.replace macro2utf8 "Longleftrightarrow" "????" +let _ = Hashtbl.replace macro2utf8 "xuplus" "\226\138\142" +let _ = Hashtbl.replace macro2utf8 "searr" "\226\134\152" +let _ = Hashtbl.replace macro2utf8 "gvertneqq" "\226\137\169\239\184\128" +let _ = Hashtbl.replace macro2utf8 "subsup" "\226\171\147" +let _ = Hashtbl.replace macro2utf8 "NotSucceedsEqual" "\226\170\176\204\184" +let _ = Hashtbl.replace macro2utf8 "gtrsim" "\226\137\179" +let _ = Hashtbl.replace macro2utf8 "nrArr" "\226\135\143" +let _ = Hashtbl.replace macro2utf8 "NotSquareSupersetEqual" "\226\139\163" +let _ = Hashtbl.replace macro2utf8 "notindot" "\226\139\182\239\184\128" +let _ = Hashtbl.replace macro2utf8 "HARDcy" "\208\170" +let _ = Hashtbl.replace macro2utf8 "jmath" "j\239\184\128" +let _ = Hashtbl.replace macro2utf8 "aelig" "\195\166" +let _ = Hashtbl.replace macro2utf8 "slarr" "\226\134\144\239\184\128" +let _ = Hashtbl.replace macro2utf8 "dlcrop" "\226\140\141" +let _ = Hashtbl.replace macro2utf8 "sube" "\226\138\134" +let _ = Hashtbl.replace macro2utf8 "cuepr" "\226\139\158" +let _ = Hashtbl.replace macro2utf8 "supsub" "\226\171\148" +let _ = Hashtbl.replace macro2utf8 "trianglelefteq" "\226\138\180" +let _ = Hashtbl.replace macro2utf8 "subne" "\226\138\138" +let _ = Hashtbl.replace macro2utf8 "between" "\226\137\172" +let _ = Hashtbl.replace macro2utf8 "measuredangle" "\226\136\161" +let _ = Hashtbl.replace macro2utf8 "swnwar" "\226\164\170" +let _ = Hashtbl.replace macro2utf8 "lcy" "\208\187" +let _ = Hashtbl.replace macro2utf8 "ccirc" "\196\137" +let _ = Hashtbl.replace macro2utf8 "larrhk" "\226\134\169" +let _ = Hashtbl.replace macro2utf8 "DiacriticalTilde" "\203\156" +let _ = Hashtbl.replace macro2utf8 "brvbar" "\194\166" +let _ = Hashtbl.replace macro2utf8 "triangledown" "\226\150\191" +let _ = Hashtbl.replace macro2utf8 "dtrif" "\226\150\190" +let _ = Hashtbl.replace macro2utf8 "Bopf" "\240\157\148\185" +let _ = Hashtbl.replace macro2utf8 "xwedge" "\226\139\128" +let _ = Hashtbl.replace macro2utf8 "rightsquigarrow" "\226\134\157" +let _ = Hashtbl.replace macro2utf8 "acd" "\226\136\191" +let _ = Hashtbl.replace macro2utf8 "supsup" "\226\171\150" +let _ = Hashtbl.replace macro2utf8 "UpEquilibrium" "\226\165\174" +let _ = Hashtbl.replace macro2utf8 "succ" "\226\137\187" +let _ = Hashtbl.replace macro2utf8 "eqslantless" "\226\139\156" +let _ = Hashtbl.replace macro2utf8 "coprod" "\226\136\144" +let _ = Hashtbl.replace macro2utf8 "OpenCurlyDoubleQuote" "\226\128\156" +let _ = Hashtbl.replace macro2utf8 "NotGreaterSlantEqual" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "solb" "\226\167\132" +let _ = Hashtbl.replace macro2utf8 "HumpDownHump" "\226\137\142" +let _ = Hashtbl.replace macro2utf8 "gtrapprox" "\226\137\179" +let _ = Hashtbl.replace macro2utf8 "Iopf" "\240\157\149\128" +let _ = Hashtbl.replace macro2utf8 "leg" "\226\139\154" +let _ = Hashtbl.replace macro2utf8 "wfr" "\240\157\148\180" +let _ = Hashtbl.replace macro2utf8 "mapstoleft" "\226\134\164" +let _ = Hashtbl.replace macro2utf8 "gnapprox" "\226\170\138" +let _ = Hashtbl.replace macro2utf8 "lgE" "\226\170\145" +let _ = Hashtbl.replace macro2utf8 "CloseCurlyDoubleQuote" "\226\128\157" +let _ = Hashtbl.replace macro2utf8 "NotNestedLessLess" "\226\146\161\204\184" +let _ = Hashtbl.replace macro2utf8 "acy" "\208\176" +let _ = Hashtbl.replace macro2utf8 "leq" "\226\137\164" +let _ = Hashtbl.replace macro2utf8 "Popf" "\226\132\153" +let _ = Hashtbl.replace macro2utf8 "les" "\226\169\189" +let _ = Hashtbl.replace macro2utf8 "succcurlyeq" "\226\137\189" +let _ = Hashtbl.replace macro2utf8 "heartsuit" "\226\153\161" +let _ = Hashtbl.replace macro2utf8 "angmsd" "\226\136\161" +let _ = Hashtbl.replace macro2utf8 "cuesc" "\226\139\159" +let _ = Hashtbl.replace macro2utf8 "lesseqgtr" "\226\139\154" +let _ = Hashtbl.replace macro2utf8 "vartriangleright" "\226\138\179" +let _ = Hashtbl.replace macro2utf8 "csupe" "\226\171\146" +let _ = Hashtbl.replace macro2utf8 "rthree" "\226\139\140" +let _ = Hashtbl.replace macro2utf8 "Idot" "\196\176" +let _ = Hashtbl.replace macro2utf8 "gtdot" "\226\139\151" +let _ = Hashtbl.replace macro2utf8 "dashv" "\226\138\163" +let _ = Hashtbl.replace macro2utf8 "Odblac" "\197\144" +let _ = Hashtbl.replace macro2utf8 "Lmidot" "\196\191" +let _ = Hashtbl.replace macro2utf8 "andd" "\226\169\156" +let _ = Hashtbl.replace macro2utf8 "Wopf" "\240\157\149\142" +let _ = Hashtbl.replace macro2utf8 "nvltrie" "\226\139\172\204\184" +let _ = Hashtbl.replace macro2utf8 "nhpar" "\226\171\178" +let _ = Hashtbl.replace macro2utf8 "geqslant" "\226\169\190" +let _ = Hashtbl.replace macro2utf8 "xlArr" "\239\149\185" +let _ = Hashtbl.replace macro2utf8 "SquareSubset" "\226\138\143" +let _ = Hashtbl.replace macro2utf8 "intcal" "\226\138\186" +let _ = Hashtbl.replace macro2utf8 "ljcy" "\209\153" +let _ = Hashtbl.replace macro2utf8 "lfr" "\240\157\148\169" +let _ = Hashtbl.replace macro2utf8 "gtlPar" "\226\166\149" +let _ = Hashtbl.replace macro2utf8 "zigrarr" "\226\135\157" +let _ = Hashtbl.replace macro2utf8 "nvap" "\226\137\137\204\184" +let _ = Hashtbl.replace macro2utf8 "boxtimes" "\226\138\160" +let _ = Hashtbl.replace macro2utf8 "raquo" "\194\187" +let _ = Hashtbl.replace macro2utf8 "CircleMinus" "\226\138\150" +let _ = Hashtbl.replace macro2utf8 "centerdot" "\194\183" +let _ = Hashtbl.replace macro2utf8 "xoplus" "\226\138\149" +let _ = Hashtbl.replace macro2utf8 "simdot" "\226\169\170" +let _ = Hashtbl.replace macro2utf8 "Vcy" "\208\146" +let _ = Hashtbl.replace macro2utf8 "profline" "\226\140\146" +let _ = Hashtbl.replace macro2utf8 "ltquest" "\226\169\187" +let _ = Hashtbl.replace macro2utf8 "andv" "\226\169\154" +let _ = Hashtbl.replace macro2utf8 "lessgtr" "\226\137\182" +let _ = Hashtbl.replace macro2utf8 "lesdoto" "\226\170\129" +let _ = Hashtbl.replace macro2utf8 "NotSquareSubset" "\226\138\143\204\184" +let _ = Hashtbl.replace macro2utf8 "bullet" "\226\128\162" +let _ = Hashtbl.replace macro2utf8 "rarrsim" "\226\165\180" +let _ = Hashtbl.replace macro2utf8 "Tcedil" "\197\162" +let _ = Hashtbl.replace macro2utf8 "Hstrok" "\196\166" +let _ = Hashtbl.replace macro2utf8 "eopf" "\240\157\149\150" +let _ = Hashtbl.replace macro2utf8 "Theta" "\206\152" +let _ = Hashtbl.replace macro2utf8 "Cscr" "\240\157\146\158" +let _ = Hashtbl.replace macro2utf8 "emacr" "\196\147" +let _ = Hashtbl.replace macro2utf8 "UnionPlus" "\226\138\142" +let _ = Hashtbl.replace macro2utf8 "Vee" "\226\139\129" +let _ = Hashtbl.replace macro2utf8 "arctan" "arctan" +let _ = Hashtbl.replace macro2utf8 "afr" "\240\157\148\158" +let _ = Hashtbl.replace macro2utf8 "thinsp" "\226\128\137" +let _ = Hashtbl.replace macro2utf8 "bottom" "\226\138\165" +let _ = Hashtbl.replace macro2utf8 "lopf" "\240\157\149\157" +let _ = Hashtbl.replace macro2utf8 "larrlp" "\226\134\171" +let _ = Hashtbl.replace macro2utf8 "lbrace" "{" +let _ = Hashtbl.replace macro2utf8 "Jscr" "\240\157\146\165" +let _ = Hashtbl.replace macro2utf8 "Kcy" "\208\154" +let _ = Hashtbl.replace macro2utf8 "shortparallel" "\226\136\165\239\184\128" +let _ = Hashtbl.replace macro2utf8 "hairsp" "\226\128\138" +let _ = Hashtbl.replace macro2utf8 "osol" "\226\138\152" +let _ = Hashtbl.replace macro2utf8 "lbrack" "[" +let _ = Hashtbl.replace macro2utf8 "hArr" "\226\135\148" +let _ = Hashtbl.replace macro2utf8 "vdash" "\226\138\162" +let _ = Hashtbl.replace macro2utf8 "UpDownArrow" "\226\134\149" +let _ = Hashtbl.replace macro2utf8 "edot" "\196\151" +let _ = Hashtbl.replace macro2utf8 "vzigzag" "\226\166\154" +let _ = Hashtbl.replace macro2utf8 "sopf" "\240\157\149\164" +let _ = Hashtbl.replace macro2utf8 "NotLessGreater" "\226\137\184" +let _ = Hashtbl.replace macro2utf8 "Qscr" "\240\157\146\172" +let _ = Hashtbl.replace macro2utf8 "Gammad" "\207\156" +let _ = Hashtbl.replace macro2utf8 "SubsetEqual" "\226\138\134" +let _ = Hashtbl.replace macro2utf8 "uplus" "\226\138\142" +let _ = Hashtbl.replace macro2utf8 "LeftTriangle" "\226\138\178" +let _ = Hashtbl.replace macro2utf8 "ange" "\226\166\164" +let _ = Hashtbl.replace macro2utf8 "lim" "lim" +let _ = Hashtbl.replace macro2utf8 "triangleright" "\226\150\185" +let _ = Hashtbl.replace macro2utf8 "angrt" "\226\136\159" +let _ = Hashtbl.replace macro2utf8 "rfloor" "\226\140\139" +let _ = Hashtbl.replace macro2utf8 "bigtriangledown" "\226\150\189" +let _ = Hashtbl.replace macro2utf8 "ofcir" "\226\166\191" +let _ = Hashtbl.replace macro2utf8 "Vfr" "\240\157\148\153" +let _ = Hashtbl.replace macro2utf8 "zopf" "\240\157\149\171" +let _ = Hashtbl.replace macro2utf8 "UpArrowDownArrow" "\226\135\133" +let _ = Hashtbl.replace macro2utf8 "Xscr" "\240\157\146\179" +let _ = Hashtbl.replace macro2utf8 "digamma" "\207\156" +let _ = Hashtbl.replace macro2utf8 "SmallCircle" "\226\136\152" +let _ = Hashtbl.replace macro2utf8 "vArr" "\226\135\149" +let _ = Hashtbl.replace macro2utf8 "eqsim" "\226\137\130" +let _ = Hashtbl.replace macro2utf8 "downharpoonright" "\226\135\130" +let _ = Hashtbl.replace macro2utf8 "Ccaron" "\196\140" +let _ = Hashtbl.replace macro2utf8 "sdot" "\226\139\133" +let _ = Hashtbl.replace macro2utf8 "frown" "\226\140\162" +let _ = Hashtbl.replace macro2utf8 "angst" "\226\132\171" +let _ = Hashtbl.replace macro2utf8 "lesges" "\226\170\147" +let _ = Hashtbl.replace macro2utf8 "iacute" "\195\173" +let _ = Hashtbl.replace macro2utf8 "wedge" "\226\136\167" +let _ = Hashtbl.replace macro2utf8 "ssetmn" "\226\136\150\239\184\128" +let _ = Hashtbl.replace macro2utf8 "rotimes" "\226\168\181" +let _ = Hashtbl.replace macro2utf8 "laquo" "\194\171" +let _ = Hashtbl.replace macro2utf8 "bigstar" "\226\152\133" +let _ = Hashtbl.replace macro2utf8 "Rrightarrow" "\226\135\155" +let _ = Hashtbl.replace macro2utf8 "erDot" "\226\137\147" +let _ = Hashtbl.replace macro2utf8 "subseteq" "\226\138\134" +let _ = Hashtbl.replace macro2utf8 "leftharpoondown" "\226\134\189" +let _ = Hashtbl.replace macro2utf8 "infin" "\226\136\158" +let _ = Hashtbl.replace macro2utf8 "zdot" "\197\188" +let _ = Hashtbl.replace macro2utf8 "solbar" "\226\140\191" +let _ = Hashtbl.replace macro2utf8 "Iuml" "\195\143" +let _ = Hashtbl.replace macro2utf8 "Kfr" "\240\157\148\142" +let _ = Hashtbl.replace macro2utf8 "fscr" "\240\157\146\187" +let _ = Hashtbl.replace macro2utf8 "DJcy" "\208\130" +let _ = Hashtbl.replace macro2utf8 "veeeq" "\226\137\154" +let _ = Hashtbl.replace macro2utf8 "Star" "\226\139\134" +let _ = Hashtbl.replace macro2utf8 "lsquor" "\226\128\154" +let _ = Hashtbl.replace macro2utf8 "Uacute" "\195\154" +let _ = Hashtbl.replace macro2utf8 "weierp" "\226\132\152" +let _ = Hashtbl.replace macro2utf8 "rang" "\226\140\170" +let _ = Hashtbl.replace macro2utf8 "hamilt" "\226\132\139" +let _ = Hashtbl.replace macro2utf8 "angsph" "\226\136\162" +let _ = Hashtbl.replace macro2utf8 "YUcy" "\208\174" +let _ = Hashtbl.replace macro2utf8 "Wcirc" "\197\180" +let _ = Hashtbl.replace macro2utf8 "supsetneq" "\226\138\139" +let _ = Hashtbl.replace macro2utf8 "gap" "\226\137\179" +let _ = Hashtbl.replace macro2utf8 "mscr" "\240\157\147\130" +let _ = Hashtbl.replace macro2utf8 "KJcy" "\208\140" +let _ = Hashtbl.replace macro2utf8 "qprime" "\226\129\151" +let _ = Hashtbl.replace macro2utf8 "EqualTilde" "\226\137\130" +let _ = Hashtbl.replace macro2utf8 "vBar" "\226\171\168" +let _ = Hashtbl.replace macro2utf8 "larrpl" "\226\164\185" +let _ = Hashtbl.replace macro2utf8 "nvge" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "approx" "\226\137\136" +let _ = Hashtbl.replace macro2utf8 "lnE" "\226\137\168" +let _ = Hashtbl.replace macro2utf8 "NotGreaterLess" "\226\137\185" +let _ = Hashtbl.replace macro2utf8 "epar" "\226\139\149" +let _ = Hashtbl.replace macro2utf8 "bigotimes" "\226\138\151" +let _ = Hashtbl.replace macro2utf8 "xharr" "\239\149\184" +let _ = Hashtbl.replace macro2utf8 "roang" "\239\149\153" +let _ = Hashtbl.replace macro2utf8 "xcup" "\226\139\131" +let _ = Hashtbl.replace macro2utf8 "tscr" "\240\157\147\137" +let _ = Hashtbl.replace macro2utf8 "thkap" "\226\137\136\239\184\128" +let _ = Hashtbl.replace macro2utf8 "Aacute" "\195\129" +let _ = Hashtbl.replace macro2utf8 "rcy" "\209\128" +let _ = Hashtbl.replace macro2utf8 "jukcy" "\209\148" +let _ = Hashtbl.replace macro2utf8 "hookleftarrow" "\226\134\169" +let _ = Hashtbl.replace macro2utf8 "napid" "\226\137\139\204\184" +let _ = Hashtbl.replace macro2utf8 "tscy" "\209\134" +let _ = Hashtbl.replace macro2utf8 "nvgt" "\226\137\175" +let _ = Hashtbl.replace macro2utf8 "lpar" "(" +let _ = Hashtbl.replace macro2utf8 "ldsh" "\226\134\178" +let _ = Hashtbl.replace macro2utf8 "aring" "\195\165" +let _ = Hashtbl.replace macro2utf8 "nGg" "\226\139\153\204\184" +let _ = Hashtbl.replace macro2utf8 "LessEqualGreater" "\226\139\154" +let _ = Hashtbl.replace macro2utf8 "gcd" "gcd" +let _ = Hashtbl.replace macro2utf8 "oplus" "\226\138\149" +let _ = Hashtbl.replace macro2utf8 "lcaron" "\196\190" +let _ = Hashtbl.replace macro2utf8 "DownArrow" "\226\134\147" +let _ = Hashtbl.replace macro2utf8 "xutri" "\226\150\179" +let _ = Hashtbl.replace macro2utf8 "Psi" "\206\168" +let _ = Hashtbl.replace macro2utf8 "lesssim" "\226\137\178" +let _ = Hashtbl.replace macro2utf8 "topcir" "\226\171\177" +let _ = Hashtbl.replace macro2utf8 "puncsp" "\226\128\136" +let _ = Hashtbl.replace macro2utf8 "origof" "\226\138\182" +let _ = Hashtbl.replace macro2utf8 "gnsim" "\226\139\167" +let _ = Hashtbl.replace macro2utf8 "eogon" "\196\153" +let _ = Hashtbl.replace macro2utf8 "spar" "\226\136\165\239\184\128" +let _ = Hashtbl.replace macro2utf8 "LowerRightArrow" "\226\134\152" +let _ = Hashtbl.replace macro2utf8 "Lleftarrow" "\226\135\154" +let _ = Hashtbl.replace macro2utf8 "nGt" "\226\137\171\204\184" +let _ = Hashtbl.replace macro2utf8 "euml" "\195\171" +let _ = Hashtbl.replace macro2utf8 "reg" "\194\174" +let _ = Hashtbl.replace macro2utf8 "exponentiale" "\226\133\135" +let _ = Hashtbl.replace macro2utf8 "qint" "\226\168\140" +let _ = Hashtbl.replace macro2utf8 "sqcups" "\226\138\148\239\184\128" +let _ = Hashtbl.replace macro2utf8 "lne" "\226\137\168" +let _ = Hashtbl.replace macro2utf8 "LessSlantEqual" "\226\169\189" +let _ = Hashtbl.replace macro2utf8 "Egrave" "\195\136" +let _ = Hashtbl.replace macro2utf8 "orderof" "\226\132\180" +let _ = Hashtbl.replace macro2utf8 "cirE" "\226\167\131" +let _ = Hashtbl.replace macro2utf8 "nleqslant" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "gcy" "\208\179" +let _ = Hashtbl.replace macro2utf8 "curvearrowright" "\226\134\183" +let _ = Hashtbl.replace macro2utf8 "ratail" "\226\134\163" +let _ = Hashtbl.replace macro2utf8 "emsp13" "\226\128\132" +let _ = Hashtbl.replace macro2utf8 "sdotb" "\226\138\161" +let _ = Hashtbl.replace macro2utf8 "horbar" "\226\128\149" +let _ = Hashtbl.replace macro2utf8 "emsp14" "\226\128\133" +let _ = Hashtbl.replace macro2utf8 "npre" "\226\170\175\204\184" +let _ = Hashtbl.replace macro2utf8 "rbrksld" "\226\166\142" +let _ = Hashtbl.replace macro2utf8 "sdote" "\226\169\166" +let _ = Hashtbl.replace macro2utf8 "varsupsetneqq" "\226\138\139\239\184\128" +let _ = Hashtbl.replace macro2utf8 "VeryThinSpace" "\226\128\138" +let _ = Hashtbl.replace macro2utf8 "DownArrowBar" "\226\164\147" +let _ = Hashtbl.replace macro2utf8 "Rightarrow" "\226\135\146" +let _ = Hashtbl.replace macro2utf8 "ocir" "\226\138\154" +let _ = Hashtbl.replace macro2utf8 "NotHumpDownHump" "\226\137\142\204\184" +let _ = Hashtbl.replace macro2utf8 "darr" "\226\134\147" +let _ = Hashtbl.replace macro2utf8 "geqq" "\226\137\167" +let _ = Hashtbl.replace macro2utf8 "sup1" "\194\185" +let _ = Hashtbl.replace macro2utf8 "log" "log" +let _ = Hashtbl.replace macro2utf8 "sup2" "\194\178" +let _ = Hashtbl.replace macro2utf8 "micro" "\194\181" +let _ = Hashtbl.replace macro2utf8 "amp" "&" +let _ = Hashtbl.replace macro2utf8 "arccos" "arccos" +let _ = Hashtbl.replace macro2utf8 "sup3" "\194\179" +let _ = Hashtbl.replace macro2utf8 "GreaterTilde" "\226\137\179" +let _ = Hashtbl.replace macro2utf8 "circeq" "\226\137\151" +let _ = Hashtbl.replace macro2utf8 "rfr" "\240\157\148\175" +let _ = Hashtbl.replace macro2utf8 "dash" "\226\128\144" +let _ = Hashtbl.replace macro2utf8 "rbrkslu" "\226\166\144" +let _ = Hashtbl.replace macro2utf8 "Dcaron" "\196\142" +let _ = Hashtbl.replace macro2utf8 "and" "\226\136\167" +let _ = Hashtbl.replace macro2utf8 "Vbar" "\226\171\171" +let _ = Hashtbl.replace macro2utf8 "angzarr" "\226\141\188" +let _ = Hashtbl.replace macro2utf8 "gel" "\226\139\155" +let _ = Hashtbl.replace macro2utf8 "ang" "\226\136\160" +let _ = Hashtbl.replace macro2utf8 "lor" "\226\136\168" +let _ = Hashtbl.replace macro2utf8 "circ" "\226\136\152" +let _ = Hashtbl.replace macro2utf8 "upharpoonright" "\226\134\190" +let _ = Hashtbl.replace macro2utf8 "dblac" "\203\157" +let _ = Hashtbl.replace macro2utf8 "subsetneqq" "\226\138\138" +let _ = Hashtbl.replace macro2utf8 "rhard" "\226\135\129" +let _ = Hashtbl.replace macro2utf8 "Intersection" "\226\139\130" +let _ = Hashtbl.replace macro2utf8 "cire" "\226\137\151" +let _ = Hashtbl.replace macro2utf8 "apE" "\226\137\138" +let _ = Hashtbl.replace macro2utf8 "sung" "\226\153\170" +let _ = Hashtbl.replace macro2utf8 "geq" "\226\137\165" +let _ = Hashtbl.replace macro2utf8 "succsim" "\226\137\191" +let _ = Hashtbl.replace macro2utf8 "ges" "\226\169\190" +let _ = Hashtbl.replace macro2utf8 "Gbreve" "\196\158" +let _ = Hashtbl.replace macro2utf8 "intercal" "\226\138\186" +let _ = Hashtbl.replace macro2utf8 "supE" "\226\138\135" +let _ = Hashtbl.replace macro2utf8 "NotCupCap" "\226\137\173" +let _ = Hashtbl.replace macro2utf8 "loz" "\226\151\138" +let _ = Hashtbl.replace macro2utf8 "capcup" "\226\169\135" +let _ = Hashtbl.replace macro2utf8 "larrtl" "\226\134\162" +let _ = Hashtbl.replace macro2utf8 "AElig" "\195\134" +let _ = Hashtbl.replace macro2utf8 "rarr" "\226\134\146" +let _ = Hashtbl.replace macro2utf8 "varkappa" "\207\176" +let _ = Hashtbl.replace macro2utf8 "upsi" "\207\133" +let _ = Hashtbl.replace macro2utf8 "loang" "\239\149\152" +let _ = Hashtbl.replace macro2utf8 "looparrowleft" "\226\134\171" +let _ = Hashtbl.replace macro2utf8 "IOcy" "\208\129" +let _ = Hashtbl.replace macro2utf8 "backprime" "\226\128\181" +let _ = Hashtbl.replace macro2utf8 "sstarf" "\226\139\134" +let _ = Hashtbl.replace macro2utf8 "rharu" "\226\135\128" +let _ = Hashtbl.replace macro2utf8 "gesl" "\226\139\155\239\184\128" +let _ = Hashtbl.replace macro2utf8 "xotime" "\226\138\151" +let _ = Hashtbl.replace macro2utf8 "minus" "\226\136\146" +let _ = Hashtbl.replace macro2utf8 "gvnE" "\226\137\169\239\184\128" +let _ = Hashtbl.replace macro2utf8 "gfr" "\240\157\148\164" +let _ = Hashtbl.replace macro2utf8 "lfisht" "\226\165\188" +let _ = Hashtbl.replace macro2utf8 "jcirc" "\196\181" +let _ = Hashtbl.replace macro2utf8 "roarr" "\226\135\190" +let _ = Hashtbl.replace macro2utf8 "rho" "\207\129" +let _ = Hashtbl.replace macro2utf8 "nvle" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "sect" "\194\167" +let _ = Hashtbl.replace macro2utf8 "ggg" "\226\139\153" +let _ = Hashtbl.replace macro2utf8 "plusb" "\226\138\158" +let _ = Hashtbl.replace macro2utf8 "NotTildeFullEqual" "\226\137\135" +let _ = Hashtbl.replace macro2utf8 "NegativeVeryThinSpace" "\226\128\138\239\184\128" +let _ = Hashtbl.replace macro2utf8 "ape" "\226\137\138" +let _ = Hashtbl.replace macro2utf8 "pluse" "\226\169\178" +let _ = Hashtbl.replace macro2utf8 "dollar" "$" +let _ = Hashtbl.replace macro2utf8 "divonx" "\226\139\135" +let _ = Hashtbl.replace macro2utf8 "partial" "\226\136\130" +let _ = Hashtbl.replace macro2utf8 "DoubleLeftRightArrow" "\226\135\148" +let _ = Hashtbl.replace macro2utf8 "varepsilon" "\206\181" +let _ = Hashtbl.replace macro2utf8 "supe" "\226\138\135" +let _ = Hashtbl.replace macro2utf8 "nvlt" "\226\137\174" +let _ = Hashtbl.replace macro2utf8 "angrtvb" "\226\166\157\239\184\128" +let _ = Hashtbl.replace macro2utf8 "gets" "\226\134\144" +let _ = Hashtbl.replace macro2utf8 "nparallel" "\226\136\166" +let _ = Hashtbl.replace macro2utf8 "varphi" "\207\134" +let _ = Hashtbl.replace macro2utf8 "nsupseteq" "\226\138\137" +let _ = Hashtbl.replace macro2utf8 "circledR" "\194\174" +let _ = Hashtbl.replace macro2utf8 "circledS" "\226\147\136" +let _ = Hashtbl.replace macro2utf8 "primes" "\226\132\153" +let _ = Hashtbl.replace macro2utf8 "cuwed" "\226\139\143" +let _ = Hashtbl.replace macro2utf8 "cupcap" "\226\169\134" +let _ = Hashtbl.replace macro2utf8 "nLl" "\226\139\152\204\184" +let _ = Hashtbl.replace macro2utf8 "lozf" "\226\167\171" +let _ = Hashtbl.replace macro2utf8 "ShortLeftArrow" "\226\134\144\239\184\128" +let _ = Hashtbl.replace macro2utf8 "nLt" "\226\137\170\204\184" +let _ = Hashtbl.replace macro2utf8 "lesdotor" "\226\170\131" +let _ = Hashtbl.replace macro2utf8 "Fcy" "\208\164" +let _ = Hashtbl.replace macro2utf8 "scnsim" "\226\139\169" +let _ = Hashtbl.replace macro2utf8 "VerticalLine" "|" +let _ = Hashtbl.replace macro2utf8 "nwArr" "\226\135\150" +let _ = Hashtbl.replace macro2utf8 "LeftTeeArrow" "\226\134\164" +let _ = Hashtbl.replace macro2utf8 "iprod" "\226\168\188" +let _ = Hashtbl.replace macro2utf8 "lsh" "\226\134\176" +let _ = Hashtbl.replace macro2utf8 "Congruent" "\226\137\161" +let _ = Hashtbl.replace macro2utf8 "NotLeftTriangle" "\226\139\170" +let _ = Hashtbl.replace macro2utf8 "rdldhar" "\226\165\169" +let _ = Hashtbl.replace macro2utf8 "varpropto" "\226\136\157" +let _ = Hashtbl.replace macro2utf8 "nvlArr" "\226\135\141" +let _ = Hashtbl.replace macro2utf8 "arg" "arg" +let _ = Hashtbl.replace macro2utf8 "lhard" "\226\134\189" +let _ = Hashtbl.replace macro2utf8 "surd" "????" +let _ = Hashtbl.replace macro2utf8 "napos" "\197\137" +let _ = Hashtbl.replace macro2utf8 "lparlt" "\226\166\147" +let _ = Hashtbl.replace macro2utf8 "hslash" "\226\132\143" +let _ = Hashtbl.replace macro2utf8 "Gopf" "\240\157\148\190" +let _ = Hashtbl.replace macro2utf8 "SHcy" "\208\168" +let _ = Hashtbl.replace macro2utf8 "triangle" "\226\150\181" +let _ = Hashtbl.replace macro2utf8 "Qfr" "\240\157\148\148" +let _ = Hashtbl.replace macro2utf8 "DiacriticalAcute" "\194\180" +let _ = Hashtbl.replace macro2utf8 "tbrk" "\226\142\180" +let _ = Hashtbl.replace macro2utf8 "Implies" "\226\135\146" +let _ = Hashtbl.replace macro2utf8 "comp" "\226\136\129" +let _ = Hashtbl.replace macro2utf8 "ddarr" "\226\135\138" +let _ = Hashtbl.replace macro2utf8 "Colone" "\226\169\180" +let _ = Hashtbl.replace macro2utf8 "smashp" "\226\168\179" +let _ = Hashtbl.replace macro2utf8 "ccups" "\226\169\140" +let _ = Hashtbl.replace macro2utf8 "triangleq" "\226\137\156" +let _ = Hashtbl.replace macro2utf8 "NotSquareSubsetEqual" "\226\139\162" +let _ = Hashtbl.replace macro2utf8 "Nopf" "\226\132\149" +let _ = Hashtbl.replace macro2utf8 "ZHcy" "\208\150" +let _ = Hashtbl.replace macro2utf8 "map" "\226\134\166" +let _ = Hashtbl.replace macro2utf8 "lharu" "\226\134\188" +let _ = Hashtbl.replace macro2utf8 "glE" "\226\170\146" +let _ = Hashtbl.replace macro2utf8 "cong" "\226\137\133" +let _ = Hashtbl.replace macro2utf8 "Ecaron" "\196\154" +let _ = Hashtbl.replace macro2utf8 "Uring" "\197\174" +let _ = Hashtbl.replace macro2utf8 "blacktriangleright" "\226\150\184" +let _ = Hashtbl.replace macro2utf8 "ntilde" "\195\177" +let _ = Hashtbl.replace macro2utf8 "max" "max" +let _ = Hashtbl.replace macro2utf8 "loarr" "\226\135\189" +let _ = Hashtbl.replace macro2utf8 "LeftArrow" "\226\134\144" +let _ = Hashtbl.replace macro2utf8 "Gdot" "\196\160" +let _ = Hashtbl.replace macro2utf8 "Uopf" "\240\157\149\140" +let _ = Hashtbl.replace macro2utf8 "bigsqcup" "\226\138\148" +let _ = Hashtbl.replace macro2utf8 "wedgeq" "\226\137\153" +let _ = Hashtbl.replace macro2utf8 "RoundImplies" "\226\165\176" +let _ = Hashtbl.replace macro2utf8 "prap" "\226\137\190" +let _ = Hashtbl.replace macro2utf8 "gescc" "\226\170\169" +let _ = Hashtbl.replace macro2utf8 "realine" "\226\132\155" +let _ = Hashtbl.replace macro2utf8 "ast" "*" +let _ = Hashtbl.replace macro2utf8 "subedot" "\226\171\131" +let _ = Hashtbl.replace macro2utf8 "LeftTeeVector" "\226\165\154" +let _ = Hashtbl.replace macro2utf8 "female" "\226\153\128" +let _ = Hashtbl.replace macro2utf8 "circlearrowleft" "\226\134\186" +let _ = Hashtbl.replace macro2utf8 "Ffr" "\240\157\148\137" +let _ = Hashtbl.replace macro2utf8 "VDash" "\226\138\171" +let _ = Hashtbl.replace macro2utf8 "jsercy" "\209\152" +let _ = Hashtbl.replace macro2utf8 "Proportional" "\226\136\157" +let _ = Hashtbl.replace macro2utf8 "OverBracket" "\226\142\180" +let _ = Hashtbl.replace macro2utf8 "gla" "\226\170\165" +let _ = Hashtbl.replace macro2utf8 "NotElement" "\226\136\137" +let _ = Hashtbl.replace macro2utf8 "theta" "\206\184" +let _ = Hashtbl.replace macro2utf8 "kcedil" "\196\183" +let _ = Hashtbl.replace macro2utf8 "smeparsl" "\226\167\164" +let _ = Hashtbl.replace macro2utf8 "rarrb" "\226\135\165" +let _ = Hashtbl.replace macro2utf8 "rarrc" "\226\164\179" +let _ = Hashtbl.replace macro2utf8 "ograve" "\195\178" +let _ = Hashtbl.replace macro2utf8 "glj" "\226\170\164" +let _ = Hashtbl.replace macro2utf8 "infty" "\226\136\158" +let _ = Hashtbl.replace macro2utf8 "gnE" "\226\137\169" +let _ = Hashtbl.replace macro2utf8 "copf" "\240\157\149\148" +let _ = Hashtbl.replace macro2utf8 "LeftArrowRightArrow" "\226\135\134" +let _ = Hashtbl.replace macro2utf8 "cwconint" "\226\136\178" +let _ = Hashtbl.replace macro2utf8 "Ascr" "\240\157\146\156" +let _ = Hashtbl.replace macro2utf8 "NegativeThinSpace" "\226\128\137\239\184\128" +let _ = Hashtbl.replace macro2utf8 "varsubsetneq" "\226\138\138\239\184\128" +let _ = Hashtbl.replace macro2utf8 "trisb" "\226\167\141" +let _ = Hashtbl.replace macro2utf8 "rightharpoonup" "\226\135\128" +let _ = Hashtbl.replace macro2utf8 "imagline" "\226\132\144" +let _ = Hashtbl.replace macro2utf8 "mcy" "\208\188" +let _ = Hashtbl.replace macro2utf8 "Cacute" "\196\134" +let _ = Hashtbl.replace macro2utf8 "bumpeq" "\226\137\143" +let _ = Hashtbl.replace macro2utf8 "jopf" "\240\157\149\155" +let _ = Hashtbl.replace macro2utf8 "shchcy" "\209\137" +let _ = Hashtbl.replace macro2utf8 "rarrw" "\226\134\157" +let _ = Hashtbl.replace macro2utf8 "uuarr" "\226\135\136" +let _ = Hashtbl.replace macro2utf8 "doteq" "\226\137\144" +let _ = Hashtbl.replace macro2utf8 "cudarrl" "\226\164\184" +let _ = Hashtbl.replace macro2utf8 "varsigma" "\207\130" +let _ = Hashtbl.replace macro2utf8 "Hscr" "\226\132\139" +let _ = Hashtbl.replace macro2utf8 "DownArrowUpArrow" "\226\135\181" +let _ = Hashtbl.replace macro2utf8 "Ecirc" "\195\138" +let _ = Hashtbl.replace macro2utf8 "DD" "\226\133\133" +let _ = Hashtbl.replace macro2utf8 "copy" "\194\169" +let _ = Hashtbl.replace macro2utf8 "SquareIntersection" "\226\138\147" +let _ = Hashtbl.replace macro2utf8 "RightUpVector" "\226\134\190" +let _ = Hashtbl.replace macro2utf8 "NotSucceedsSlantEqual" "\226\139\161" +let _ = Hashtbl.replace macro2utf8 "cudarrr" "\226\164\181" +let _ = Hashtbl.replace macro2utf8 "verbar" "|" +let _ = Hashtbl.replace macro2utf8 "ncaron" "\197\136" +let _ = Hashtbl.replace macro2utf8 "prurel" "\226\138\176" +let _ = Hashtbl.replace macro2utf8 "nearr" "\226\134\151" +let _ = Hashtbl.replace macro2utf8 "cdot" "\196\139" +let _ = Hashtbl.replace macro2utf8 "qopf" "\240\157\149\162" +let _ = Hashtbl.replace macro2utf8 "SucceedsSlantEqual" "\226\137\189" +let _ = Hashtbl.replace macro2utf8 "Oscr" "\240\157\146\170" +let _ = Hashtbl.replace macro2utf8 "xfr" "\240\157\148\181" +let _ = Hashtbl.replace macro2utf8 "gne" "\226\137\169" +let _ = Hashtbl.replace macro2utf8 "Ccedil" "\195\135" +let _ = Hashtbl.replace macro2utf8 "nlarr" "\226\134\154" +let _ = Hashtbl.replace macro2utf8 "inodot" "\196\177" +let _ = Hashtbl.replace macro2utf8 "prec" "\226\137\186" +let _ = Hashtbl.replace macro2utf8 "percnt" "%" +let _ = Hashtbl.replace macro2utf8 "Exists" "\226\136\131" +let _ = Hashtbl.replace macro2utf8 "bcy" "\208\177" +let _ = Hashtbl.replace macro2utf8 "xopf" "\240\157\149\169" +let _ = Hashtbl.replace macro2utf8 "nsimeq" "\226\137\132" +let _ = Hashtbl.replace macro2utf8 "nrtri" "\226\139\171" +let _ = Hashtbl.replace macro2utf8 "barvee" "\226\138\189" +let _ = Hashtbl.replace macro2utf8 "Vscr" "\240\157\146\177" +let _ = Hashtbl.replace macro2utf8 "Zcaron" "\197\189" +let _ = Hashtbl.replace macro2utf8 "ReverseElement" "\226\136\139" +let _ = Hashtbl.replace macro2utf8 "npolint" "\226\168\148" +let _ = Hashtbl.replace macro2utf8 "NotGreaterTilde" "\226\137\181" +let _ = Hashtbl.replace macro2utf8 "lmoustache" "\226\142\176" +let _ = Hashtbl.replace macro2utf8 "forkv" "\226\171\153" +let _ = Hashtbl.replace macro2utf8 "rmoustache" "\226\142\177" +let _ = Hashtbl.replace macro2utf8 "DownLeftVectorBar" "\226\165\150" +let _ = Hashtbl.replace macro2utf8 "cosh" "cosh" +let _ = Hashtbl.replace macro2utf8 "mfr" "\240\157\148\170" +let _ = Hashtbl.replace macro2utf8 "LessGreater" "\226\137\182" +let _ = Hashtbl.replace macro2utf8 "zeetrf" "\226\132\168" +let _ = Hashtbl.replace macro2utf8 "DiacriticalDot" "\203\153" +let _ = Hashtbl.replace macro2utf8 "Poincareplane" "\226\132\140" +let _ = Hashtbl.replace macro2utf8 "curlyeqsucc" "\226\139\159" +let _ = Hashtbl.replace macro2utf8 "Equal" "\226\169\181" +let _ = Hashtbl.replace macro2utf8 "divides" "\226\136\163" +let _ = Hashtbl.replace macro2utf8 "scpolint" "\226\168\147" +let _ = Hashtbl.replace macro2utf8 "ngsim" "\226\137\181" +let _ = Hashtbl.replace macro2utf8 "larrbfs" "\226\164\159" +let _ = Hashtbl.replace macro2utf8 "HilbertSpace" "\226\132\139" +let _ = Hashtbl.replace macro2utf8 "otilde" "\195\181" +let _ = Hashtbl.replace macro2utf8 "larrb" "\226\135\164" +let _ = Hashtbl.replace macro2utf8 "wcirc" "\197\181" +let _ = Hashtbl.replace macro2utf8 "dscr" "\240\157\146\185" +let _ = Hashtbl.replace macro2utf8 "phmmat" "\226\132\179" +let _ = Hashtbl.replace macro2utf8 "lacute" "\196\186" +let _ = Hashtbl.replace macro2utf8 "tstrok" "\197\167" +let _ = Hashtbl.replace macro2utf8 "NotDoubleVerticalBar" "\226\136\166" +let _ = Hashtbl.replace macro2utf8 "lagran" "\226\132\146" +let _ = Hashtbl.replace macro2utf8 "NotRightTriangle" "\226\139\171" +let _ = Hashtbl.replace macro2utf8 "dscy" "\209\149" +let _ = Hashtbl.replace macro2utf8 "rightrightarrows" "\226\135\137" +let _ = Hashtbl.replace macro2utf8 "seArr" "\226\135\152" +let _ = Hashtbl.replace macro2utf8 "RightTriangleBar" "\226\167\144" +let _ = Hashtbl.replace macro2utf8 "coth" "coth" +let _ = Hashtbl.replace macro2utf8 "swarrow" "\226\134\153" +let _ = Hashtbl.replace macro2utf8 "semi" ";" +let _ = Hashtbl.replace macro2utf8 "kscr" "\240\157\147\128" +let _ = Hashtbl.replace macro2utf8 "NotLessEqual" "\226\137\176\226\131\165" +let _ = Hashtbl.replace macro2utf8 "cularr" "\226\134\182" +let _ = Hashtbl.replace macro2utf8 "blacklozenge" "\226\167\171" +let _ = Hashtbl.replace macro2utf8 "realpart" "\226\132\156" +let _ = Hashtbl.replace macro2utf8 "LeftTriangleEqual" "\226\138\180" +let _ = Hashtbl.replace macro2utf8 "bfr" "\240\157\148\159" +let _ = Hashtbl.replace macro2utf8 "Uuml" "\195\156" +let _ = Hashtbl.replace macro2utf8 "longleftrightarrow" "????" +let _ = Hashtbl.replace macro2utf8 "lcedil" "\196\188" +let _ = Hashtbl.replace macro2utf8 "complement" "\226\136\129" +let _ = Hashtbl.replace macro2utf8 "rscr" "\240\157\147\135" +let _ = Hashtbl.replace macro2utf8 "mho" "\226\132\167" +let _ = Hashtbl.replace macro2utf8 "mcomma" "\226\168\169" +let _ = Hashtbl.replace macro2utf8 "wedbar" "\226\169\159" +let _ = Hashtbl.replace macro2utf8 "NotVerticalBar" "\226\136\164" +let _ = Hashtbl.replace macro2utf8 "Lcy" "\208\155" +let _ = Hashtbl.replace macro2utf8 "tprime" "\226\128\180" +let _ = Hashtbl.replace macro2utf8 "precneqq" "\226\170\181" +let _ = Hashtbl.replace macro2utf8 "Downarrow" "\226\135\147" +let _ = Hashtbl.replace macro2utf8 "rsh" "\226\134\177" +let _ = Hashtbl.replace macro2utf8 "mid" "\226\136\163" +let _ = Hashtbl.replace macro2utf8 "blank" "\226\144\163" +let _ = Hashtbl.replace macro2utf8 "square" "\226\150\161" +let _ = Hashtbl.replace macro2utf8 "squarf" "\226\150\170" +let _ = Hashtbl.replace macro2utf8 "fflig" "\239\172\128" +let _ = Hashtbl.replace macro2utf8 "downdownarrows" "\226\135\138" +let _ = Hashtbl.replace macro2utf8 "yscr" "\240\157\147\142" +let _ = Hashtbl.replace macro2utf8 "subdot" "\226\170\189" +let _ = Hashtbl.replace macro2utf8 "ShortRightArrow" "\226\134\146\239\184\128" +let _ = Hashtbl.replace macro2utf8 "NotCongruent" "\226\137\162" +let _ = Hashtbl.replace macro2utf8 "Gg" "\226\139\153" +let _ = Hashtbl.replace macro2utf8 "Lstrok" "\197\129" +let _ = Hashtbl.replace macro2utf8 "min" "max" +let _ = Hashtbl.replace macro2utf8 "Laplacetrf" "\226\132\146" +let _ = Hashtbl.replace macro2utf8 "rarrap" "\226\165\181" +let _ = Hashtbl.replace macro2utf8 "NotLessSlantEqual" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "DoubleRightArrow" "\226\135\146" +let _ = Hashtbl.replace macro2utf8 "Wfr" "\240\157\148\154" +let _ = Hashtbl.replace macro2utf8 "subrarr" "\226\165\185" +let _ = Hashtbl.replace macro2utf8 "numsp" "\226\128\135" +let _ = Hashtbl.replace macro2utf8 "khcy" "\209\133" +let _ = Hashtbl.replace macro2utf8 "oint" "\226\136\174" +let _ = Hashtbl.replace macro2utf8 "vprop" "\226\136\157" +let _ = Hashtbl.replace macro2utf8 "hardcy" "\209\138" +let _ = Hashtbl.replace macro2utf8 "boxminus" "\226\138\159" +let _ = Hashtbl.replace macro2utf8 "GreaterLess" "\226\137\183" +let _ = Hashtbl.replace macro2utf8 "thetav" "\207\145" +let _ = Hashtbl.replace macro2utf8 "scE" "\226\137\190" +let _ = Hashtbl.replace macro2utf8 "Gt" "\226\137\171" +let _ = Hashtbl.replace macro2utf8 "Acy" "\208\144" +let _ = Hashtbl.replace macro2utf8 "backcong" "\226\137\140" +let _ = Hashtbl.replace macro2utf8 "gtquest" "\226\169\188" +let _ = Hashtbl.replace macro2utf8 "awint" "\226\168\145" +let _ = Hashtbl.replace macro2utf8 "profsurf" "\226\140\147" +let _ = Hashtbl.replace macro2utf8 "capdot" "\226\169\128" +let _ = Hashtbl.replace macro2utf8 "supdot" "\226\170\190" +let _ = Hashtbl.replace macro2utf8 "oelig" "\197\147" +let _ = Hashtbl.replace macro2utf8 "doteqdot" "\226\137\145" +let _ = Hashtbl.replace macro2utf8 "rharul" "\226\165\172" +let _ = Hashtbl.replace macro2utf8 "cylcty" "\226\140\173" +let _ = Hashtbl.replace macro2utf8 "epsi" "\206\181" +let _ = Hashtbl.replace macro2utf8 "eqcirc" "\226\137\150" +let _ = Hashtbl.replace macro2utf8 "nLeftarrow" "\226\135\141" +let _ = Hashtbl.replace macro2utf8 "rtrie" "\226\138\181" +let _ = Hashtbl.replace macro2utf8 "para" "\194\182" +let _ = Hashtbl.replace macro2utf8 "Lfr" "\240\157\148\143" +let _ = Hashtbl.replace macro2utf8 "rtrif" "\226\150\184" +let _ = Hashtbl.replace macro2utf8 "NotReverseElement" "\226\136\140" +let _ = Hashtbl.replace macro2utf8 "emptyv" "\226\136\133" +let _ = Hashtbl.replace macro2utf8 "nldr" "\226\128\165" +let _ = Hashtbl.replace macro2utf8 "leqq" "\226\137\166" +let _ = Hashtbl.replace macro2utf8 "CapitalDifferentialD" "\226\133\133" +let _ = Hashtbl.replace macro2utf8 "supsetneqq" "\226\138\139" +let _ = Hashtbl.replace macro2utf8 "boxDL" "\226\149\151" +let _ = Hashtbl.replace macro2utf8 "Im" "\226\132\145" +let _ = Hashtbl.replace macro2utf8 "sce" "\226\137\189" +let _ = Hashtbl.replace macro2utf8 "prsim" "\226\137\190" +let _ = Hashtbl.replace macro2utf8 "diams" "\226\153\166" +let _ = Hashtbl.replace macro2utf8 "gtreqqless" "\226\139\155" +let _ = Hashtbl.replace macro2utf8 "boxDR" "\226\149\148" +let _ = Hashtbl.replace macro2utf8 "vartriangleleft" "\226\138\178" +let _ = Hashtbl.replace macro2utf8 "SupersetEqual" "\226\138\135" +let _ = Hashtbl.replace macro2utf8 "Omega" "\206\169" +let _ = Hashtbl.replace macro2utf8 "nsubseteqq" "\226\138\136" +let _ = Hashtbl.replace macro2utf8 "Subset" "\226\139\144" +let _ = Hashtbl.replace macro2utf8 "ncongdot" "\226\169\173\204\184" +let _ = Hashtbl.replace macro2utf8 "minusb" "\226\138\159" +let _ = Hashtbl.replace macro2utf8 "ltimes" "\226\139\137" +let _ = Hashtbl.replace macro2utf8 "seswar" "\226\164\169" +let _ = Hashtbl.replace macro2utf8 "part" "\226\136\130" +let _ = Hashtbl.replace macro2utf8 "bumpE" "\226\170\174" +let _ = Hashtbl.replace macro2utf8 "minusd" "\226\136\184" +let _ = Hashtbl.replace macro2utf8 "Amacr" "\196\128" +let _ = Hashtbl.replace macro2utf8 "nleq" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "nles" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "NotLess" "\226\137\174" +let _ = Hashtbl.replace macro2utf8 "scy" "\209\129" +let _ = Hashtbl.replace macro2utf8 "iinfin" "\226\167\156" +let _ = Hashtbl.replace macro2utf8 "Afr" "\240\157\148\132" +let _ = Hashtbl.replace macro2utf8 "isinsv" "\226\139\179" +let _ = Hashtbl.replace macro2utf8 "prnE" "\226\170\181" +let _ = Hashtbl.replace macro2utf8 "lesg" "\226\139\154\239\184\128" +let _ = Hashtbl.replace macro2utf8 "cups" "\226\136\170\239\184\128" +let _ = Hashtbl.replace macro2utf8 "thickapprox" "\226\137\136\239\184\128" +let _ = Hashtbl.replace macro2utf8 "RightTeeVector" "\226\165\155" +let _ = Hashtbl.replace macro2utf8 "LowerLeftArrow" "\226\134\153" +let _ = Hashtbl.replace macro2utf8 "utdot" "\226\139\176" +let _ = Hashtbl.replace macro2utf8 "homtht" "\226\136\187" +let _ = Hashtbl.replace macro2utf8 "ddotseq" "\226\169\183" +let _ = Hashtbl.replace macro2utf8 "bowtie" "\226\139\136" +let _ = Hashtbl.replace macro2utf8 "succnsim" "\226\139\169" +let _ = Hashtbl.replace macro2utf8 "boxDl" "\226\149\150" +let _ = Hashtbl.replace macro2utf8 "quot" "\"" +let _ = Hashtbl.replace macro2utf8 "lvnE" "\226\137\168\239\184\128" +let _ = Hashtbl.replace macro2utf8 "CircleDot" "\226\138\153" +let _ = Hashtbl.replace macro2utf8 "lsime" "\226\170\141" +let _ = Hashtbl.replace macro2utf8 "Yacute" "\195\157" +let _ = Hashtbl.replace macro2utf8 "esdot" "\226\137\144" +let _ = Hashtbl.replace macro2utf8 "Supset" "\226\139\145" +let _ = Hashtbl.replace macro2utf8 "lsimg" "\226\170\143" +let _ = Hashtbl.replace macro2utf8 "eDot" "\226\137\145" +let _ = Hashtbl.replace macro2utf8 "sec" "sec" +let _ = Hashtbl.replace macro2utf8 "boxDr" "\226\149\147" +let _ = Hashtbl.replace macro2utf8 "plus" "+" +let _ = Hashtbl.replace macro2utf8 "ddagger" "\226\128\161" +let _ = Hashtbl.replace macro2utf8 "Vdashl" "\226\171\166" +let _ = Hashtbl.replace macro2utf8 "equest" "\226\137\159" +let _ = Hashtbl.replace macro2utf8 "quest" "?" +let _ = Hashtbl.replace macro2utf8 "divideontimes" "\226\139\135" +let _ = Hashtbl.replace macro2utf8 "nsmid" "\226\136\164\239\184\128" +let _ = Hashtbl.replace macro2utf8 "fnof" "\198\146" +let _ = Hashtbl.replace macro2utf8 "bumpe" "\226\137\143" +let _ = Hashtbl.replace macro2utf8 "lhblk" "\226\150\132" +let _ = Hashtbl.replace macro2utf8 "prnap" "\226\139\168" +let _ = Hashtbl.replace macro2utf8 "compfn" "\226\136\152" +let _ = Hashtbl.replace macro2utf8 "nsucceq" "\226\170\176\204\184" +let _ = Hashtbl.replace macro2utf8 "RightArrowLeftArrow" "\226\135\132" +let _ = Hashtbl.replace macro2utf8 "sharp" "\226\153\175" +let _ = Hashtbl.replace macro2utf8 "CHcy" "\208\167" +let _ = Hashtbl.replace macro2utf8 "dwangle" "\226\166\166" +let _ = Hashtbl.replace macro2utf8 "angrtvbd" "\226\166\157" +let _ = Hashtbl.replace macro2utf8 "period" "." +let _ = Hashtbl.replace macro2utf8 "phone" "\226\152\142" +let _ = Hashtbl.replace macro2utf8 "Eacute" "\195\137" +let _ = Hashtbl.replace macro2utf8 "dzigrarr" "\239\150\162" +let _ = Hashtbl.replace macro2utf8 "Ll" "\226\139\152" +let _ = Hashtbl.replace macro2utf8 "succapprox" "\226\137\191" +let _ = Hashtbl.replace macro2utf8 "rarrfs" "\226\164\158" +let _ = Hashtbl.replace macro2utf8 "dbkarow" "\226\164\143" +let _ = Hashtbl.replace macro2utf8 "zeta" "\206\182" +let _ = Hashtbl.replace macro2utf8 "Lt" "\226\137\170" +let _ = Hashtbl.replace macro2utf8 "triminus" "\226\168\186" +let _ = Hashtbl.replace macro2utf8 "odiv" "\226\168\184" +let _ = Hashtbl.replace macro2utf8 "ltrie" "\226\138\180" +let _ = Hashtbl.replace macro2utf8 "Dagger" "\226\128\161" +let _ = Hashtbl.replace macro2utf8 "ltrif" "\226\151\130" +let _ = Hashtbl.replace macro2utf8 "boxHD" "\226\149\166" +let _ = Hashtbl.replace macro2utf8 "timesb" "\226\138\160" +let _ = Hashtbl.replace macro2utf8 "check" "\226\156\147" +let _ = Hashtbl.replace macro2utf8 "urcorn" "\226\140\157" +let _ = Hashtbl.replace macro2utf8 "timesd" "\226\168\176" +let _ = Hashtbl.replace macro2utf8 "tshcy" "\209\155" +let _ = Hashtbl.replace macro2utf8 "sfr" "\240\157\148\176" +let _ = Hashtbl.replace macro2utf8 "lmoust" "\226\142\176" +let _ = Hashtbl.replace macro2utf8 "ruluhar" "\226\165\168" +let _ = Hashtbl.replace macro2utf8 "bne" "=\226\131\165" +let _ = Hashtbl.replace macro2utf8 "prod" "\226\136\143" +let _ = Hashtbl.replace macro2utf8 "Eopf" "\240\157\148\188" +let _ = Hashtbl.replace macro2utf8 "scsim" "\226\137\191" +let _ = Hashtbl.replace macro2utf8 "GreaterEqualLess" "\226\139\155" +let _ = Hashtbl.replace macro2utf8 "Igrave" "\195\140" +let _ = Hashtbl.replace macro2utf8 "Longrightarrow" "\226\135\146" +let _ = Hashtbl.replace macro2utf8 "bigcap" "\226\139\130" +let _ = Hashtbl.replace macro2utf8 "boxHU" "\226\149\169" +let _ = Hashtbl.replace macro2utf8 "uring" "\197\175" +let _ = Hashtbl.replace macro2utf8 "equivDD" "\226\169\184" +let _ = Hashtbl.replace macro2utf8 "prop" "\226\136\157" +let _ = Hashtbl.replace macro2utf8 "Lopf" "\240\157\149\131" +let _ = Hashtbl.replace macro2utf8 "ldrushar" "\226\165\139" +let _ = Hashtbl.replace macro2utf8 "rarrhk" "\226\134\170" +let _ = Hashtbl.replace macro2utf8 "Leftarrow" "\226\135\144" +let _ = Hashtbl.replace macro2utf8 "lltri" "\226\151\186" +let _ = Hashtbl.replace macro2utf8 "NestedGreaterGreater" "\226\137\171" +let _ = Hashtbl.replace macro2utf8 "GreaterFullEqual" "\226\137\167" +let _ = Hashtbl.replace macro2utf8 "robrk" "\227\128\155" +let _ = Hashtbl.replace macro2utf8 "larrsim" "\226\165\179" +let _ = Hashtbl.replace macro2utf8 "boxHd" "\226\149\164" +let _ = Hashtbl.replace macro2utf8 "vDash" "\226\138\168" +let _ = Hashtbl.replace macro2utf8 "hfr" "\240\157\148\165" +let _ = Hashtbl.replace macro2utf8 "Edot" "\196\150" +let _ = Hashtbl.replace macro2utf8 "Vvdash" "\226\138\170" +let _ = Hashtbl.replace macro2utf8 "Sopf" "\240\157\149\138" +let _ = Hashtbl.replace macro2utf8 "upuparrows" "\226\135\136" +let _ = Hashtbl.replace macro2utf8 "RightUpTeeVector" "\226\165\156" +let _ = Hashtbl.replace macro2utf8 "DownLeftVector" "\226\134\189" +let _ = Hashtbl.replace macro2utf8 "xhArr" "\239\149\187" +let _ = Hashtbl.replace macro2utf8 "triplus" "\226\168\185" +let _ = Hashtbl.replace macro2utf8 "bot" "\226\138\165" +let _ = Hashtbl.replace macro2utf8 "Rcy" "\208\160" +let _ = Hashtbl.replace macro2utf8 "eDDot" "\226\169\183" +let _ = Hashtbl.replace macro2utf8 "subseteqq" "\226\138\134" +let _ = Hashtbl.replace macro2utf8 "cirfnint" "\226\168\144" +let _ = Hashtbl.replace macro2utf8 "spadesuit" "\226\153\160" +let _ = Hashtbl.replace macro2utf8 "nacute" "\197\132" +let _ = Hashtbl.replace macro2utf8 "Zopf" "\226\132\164" +let _ = Hashtbl.replace macro2utf8 "upharpoonleft" "\226\134\191" +let _ = Hashtbl.replace macro2utf8 "shy" "\194\173" +let _ = Hashtbl.replace macro2utf8 "nparsl" "\226\136\165\239\184\128\226\131\165" +let _ = Hashtbl.replace macro2utf8 "boxHu" "\226\149\167" +let _ = Hashtbl.replace macro2utf8 "ThickSpace" "\226\128\137\226\128\138\226\128\138" +let _ = Hashtbl.replace macro2utf8 "Or" "\226\169\148" +let _ = Hashtbl.replace macro2utf8 "raemptyv" "\226\166\179" +let _ = Hashtbl.replace macro2utf8 "Aogon" "\196\132" +let _ = Hashtbl.replace macro2utf8 "IEcy" "\208\149" +let _ = Hashtbl.replace macro2utf8 "sim" "\226\136\188" +let _ = Hashtbl.replace macro2utf8 "sin" "sin" +let _ = Hashtbl.replace macro2utf8 "copysr" "\226\132\151" +let _ = Hashtbl.replace macro2utf8 "scnap" "\226\139\169" +let _ = Hashtbl.replace macro2utf8 "rdquo" "\226\128\157" +let _ = Hashtbl.replace macro2utf8 "aopf" "\240\157\149\146" +let _ = Hashtbl.replace macro2utf8 "Pi" "\206\160" +let _ = Hashtbl.replace macro2utf8 "Udblac" "\197\176" +let _ = Hashtbl.replace macro2utf8 "expectation" "\226\132\176" +let _ = Hashtbl.replace macro2utf8 "Zacute" "\197\185" +let _ = Hashtbl.replace macro2utf8 "urtri" "\226\151\185" +let _ = Hashtbl.replace macro2utf8 "NotTildeEqual" "\226\137\132" +let _ = Hashtbl.replace macro2utf8 "ncedil" "\197\134" +let _ = Hashtbl.replace macro2utf8 "Gamma" "\206\147" +let _ = Hashtbl.replace macro2utf8 "ecirc" "\195\170" +let _ = Hashtbl.replace macro2utf8 "dsol" "\226\167\182" +let _ = Hashtbl.replace macro2utf8 "Gcy" "\208\147" +let _ = Hashtbl.replace macro2utf8 "Pr" "Pr" +let _ = Hashtbl.replace macro2utf8 "Zdot" "\197\187" +let _ = Hashtbl.replace macro2utf8 "mnplus" "\226\136\147" +let _ = Hashtbl.replace macro2utf8 "hopf" "\240\157\149\153" +let _ = Hashtbl.replace macro2utf8 "blacktriangledown" "\226\150\190" +let _ = Hashtbl.replace macro2utf8 "LeftCeiling" "\226\140\136" +let _ = Hashtbl.replace macro2utf8 "ulcorn" "\226\140\156" +let _ = Hashtbl.replace macro2utf8 "searrow" "\226\134\152" +let _ = Hashtbl.replace macro2utf8 "GreaterGreater" "\226\170\162" +let _ = Hashtbl.replace macro2utf8 "Fscr" "\226\132\177" +let _ = Hashtbl.replace macro2utf8 "cupcup" "\226\169\138" +let _ = Hashtbl.replace macro2utf8 "NotEqual" "\226\137\160" +let _ = Hashtbl.replace macro2utf8 "sext" "\226\156\182" +let _ = Hashtbl.replace macro2utf8 "CirclePlus" "\226\138\149" +let _ = Hashtbl.replace macro2utf8 "erarr" "\226\165\177" +let _ = Hashtbl.replace macro2utf8 "dArr" "\226\135\147" +let _ = Hashtbl.replace macro2utf8 "PrecedesSlantEqual" "\226\137\188" +let _ = Hashtbl.replace macro2utf8 "Itilde" "\196\168" +let _ = Hashtbl.replace macro2utf8 "gesdoto" "\226\170\130" +let _ = Hashtbl.replace macro2utf8 "Rang" "\227\128\139" +let _ = Hashtbl.replace macro2utf8 "nwarhk" "\226\164\163" +let _ = Hashtbl.replace macro2utf8 "minusdu" "\226\168\170" +let _ = Hashtbl.replace macro2utf8 "oopf" "\240\157\149\160" +let _ = Hashtbl.replace macro2utf8 "Mscr" "\226\132\179" +let _ = Hashtbl.replace macro2utf8 "Rfr" "\226\132\156" +let _ = Hashtbl.replace macro2utf8 "langle" "\226\140\169" +let _ = Hashtbl.replace macro2utf8 "And" "\226\169\147" +let _ = Hashtbl.replace macro2utf8 "bprime" "\226\128\181" +let _ = Hashtbl.replace macro2utf8 "nLeftrightarrow" "\226\135\142" +let _ = Hashtbl.replace macro2utf8 "Re" "\226\132\156" +let _ = Hashtbl.replace macro2utf8 "OpenCurlyQuote" "\226\128\152" +let _ = Hashtbl.replace macro2utf8 "vopf" "\240\157\149\167" +let _ = Hashtbl.replace macro2utf8 "ulcorner" "\226\140\156" +let _ = Hashtbl.replace macro2utf8 "nap" "\226\137\137" +let _ = Hashtbl.replace macro2utf8 "Tscr" "\240\157\146\175" +let _ = Hashtbl.replace macro2utf8 "gtreqless" "\226\139\155" +let _ = Hashtbl.replace macro2utf8 "rarrlp" "\226\134\172" +let _ = Hashtbl.replace macro2utf8 "Lambda" "\206\155" +let _ = Hashtbl.replace macro2utf8 "lobrk" "\227\128\154" +let _ = Hashtbl.replace macro2utf8 "rbrace" "}" +let _ = Hashtbl.replace macro2utf8 "rArr" "\226\135\146" +let _ = Hashtbl.replace macro2utf8 "coloneq" "\226\137\148" +let _ = Hashtbl.replace macro2utf8 "UpArrow" "\226\134\145" +let _ = Hashtbl.replace macro2utf8 "odot" "\226\138\153" +let _ = Hashtbl.replace macro2utf8 "LeftDownTeeVector" "\226\165\161" +let _ = Hashtbl.replace macro2utf8 "complexes" "\226\132\130" +let _ = Hashtbl.replace macro2utf8 "rbrack" "]" +let _ = Hashtbl.replace macro2utf8 "DownTeeArrow" "\226\134\167" +let _ = Hashtbl.replace macro2utf8 "sqcap" "\226\138\147" +let _ = Hashtbl.replace macro2utf8 "Sc" "\226\170\188" +let _ = Hashtbl.replace macro2utf8 "ycy" "\209\139" +let _ = Hashtbl.replace macro2utf8 "Prime" "\226\128\179" +let _ = Hashtbl.replace macro2utf8 "Gfr" "\240\157\148\138" +let _ = Hashtbl.replace macro2utf8 "trianglerighteq" "\226\138\181" +let _ = Hashtbl.replace macro2utf8 "rangd" "\226\166\146" +let _ = Hashtbl.replace macro2utf8 "gtrdot" "\226\139\151" +let _ = Hashtbl.replace macro2utf8 "range" "\226\166\165" +let _ = Hashtbl.replace macro2utf8 "rsqb" "]" +let _ = Hashtbl.replace macro2utf8 "Euml" "\195\139" +let _ = Hashtbl.replace macro2utf8 "Therefore" "\226\136\180" +let _ = Hashtbl.replace macro2utf8 "nesim" "\226\137\130\204\184" +let _ = Hashtbl.replace macro2utf8 "order" "\226\132\180" +let _ = Hashtbl.replace macro2utf8 "vsupnE" "\226\138\139\239\184\128" +let _ = Hashtbl.replace macro2utf8 "awconint" "\226\136\179" +let _ = Hashtbl.replace macro2utf8 "bscr" "\240\157\146\183" +let _ = Hashtbl.replace macro2utf8 "lesseqqgtr" "\226\139\154" +let _ = Hashtbl.replace macro2utf8 "cap" "\226\136\169" +let _ = Hashtbl.replace macro2utf8 "ldquo" "\226\128\156" +let _ = Hashtbl.replace macro2utf8 "nsubseteq" "\226\138\136" +let _ = Hashtbl.replace macro2utf8 "rhov" "\207\177" +let _ = Hashtbl.replace macro2utf8 "xvee" "\226\139\129" +let _ = Hashtbl.replace macro2utf8 "olarr" "\226\134\186" +let _ = Hashtbl.replace macro2utf8 "nang" "\226\136\160\204\184" +let _ = Hashtbl.replace macro2utf8 "uwangle" "\226\166\167" +let _ = Hashtbl.replace macro2utf8 "nlsim" "\226\137\180" +let _ = Hashtbl.replace macro2utf8 "smt" "\226\170\170" +let _ = Hashtbl.replace macro2utf8 "nVdash" "\226\138\174" +let _ = Hashtbl.replace macro2utf8 "napE" "\226\169\176\204\184" +let _ = Hashtbl.replace macro2utf8 "ngeq" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "iscr" "\240\157\146\190" +let _ = Hashtbl.replace macro2utf8 "GJcy" "\208\131" +let _ = Hashtbl.replace macro2utf8 "nges" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "exist" "\226\136\131" +let _ = Hashtbl.replace macro2utf8 "cent" "\194\162" +let _ = Hashtbl.replace macro2utf8 "oacute" "\195\179" +let _ = Hashtbl.replace macro2utf8 "Darr" "\226\134\161" +let _ = Hashtbl.replace macro2utf8 "yen" "\194\165" +let _ = Hashtbl.replace macro2utf8 "bigcirc" "\226\151\175" +let _ = Hashtbl.replace macro2utf8 "ncy" "\208\189" +let _ = Hashtbl.replace macro2utf8 "midast" "*" +let _ = Hashtbl.replace macro2utf8 "UpperRightArrow" "\226\134\151" +let _ = Hashtbl.replace macro2utf8 "precnapprox" "\226\139\168" +let _ = Hashtbl.replace macro2utf8 "OElig" "\197\146" +let _ = Hashtbl.replace macro2utf8 "hybull" "\226\129\131" +let _ = Hashtbl.replace macro2utf8 "cupbrcap" "\226\169\136" +let _ = Hashtbl.replace macro2utf8 "rationals" "\226\132\154" +let _ = Hashtbl.replace macro2utf8 "VerticalTilde" "\226\137\128" +let _ = Hashtbl.replace macro2utf8 "pscr" "\240\157\147\133" +let _ = Hashtbl.replace macro2utf8 "NJcy" "\208\138" +let _ = Hashtbl.replace macro2utf8 "NotSucceedsTilde" "\226\137\191\204\184" +let _ = Hashtbl.replace macro2utf8 "vsupne" "\226\138\139\239\184\128" +let _ = Hashtbl.replace macro2utf8 "Updownarrow" "\226\135\149" +let _ = Hashtbl.replace macro2utf8 "Lsh" "\226\134\176" +let _ = Hashtbl.replace macro2utf8 "rAarr" "\226\135\155" +let _ = Hashtbl.replace macro2utf8 "precapprox" "\226\137\190" +let _ = Hashtbl.replace macro2utf8 "rsquor" "\226\128\153" +let _ = Hashtbl.replace macro2utf8 "pound" "\194\163" +let _ = Hashtbl.replace macro2utf8 "lbrksld" "\226\166\143" +let _ = Hashtbl.replace macro2utf8 "gesdot" "\226\170\128" +let _ = Hashtbl.replace macro2utf8 "Element" "\226\136\136" +let _ = Hashtbl.replace macro2utf8 "xcirc" "\226\151\175" +let _ = Hashtbl.replace macro2utf8 "wscr" "\240\157\147\140" +let _ = Hashtbl.replace macro2utf8 "toea" "\226\164\168" +let _ = Hashtbl.replace macro2utf8 "setmn" "\226\136\150" +let _ = Hashtbl.replace macro2utf8 "neg" "\194\172" +let _ = Hashtbl.replace macro2utf8 "sol" "/" +let _ = Hashtbl.replace macro2utf8 "yfr" "\240\157\148\182" +let _ = Hashtbl.replace macro2utf8 "DoubleDownArrow" "\226\135\147" +let _ = Hashtbl.replace macro2utf8 "Rarr" "\226\134\160" +let _ = Hashtbl.replace macro2utf8 "ngE" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "Upsi" "\207\146" +let _ = Hashtbl.replace macro2utf8 "opar" "\226\166\183" +let _ = Hashtbl.replace macro2utf8 "rarrpl" "\226\165\133" +let _ = Hashtbl.replace macro2utf8 "auml" "\195\164" +let _ = Hashtbl.replace macro2utf8 "bmod" "mod" +let _ = Hashtbl.replace macro2utf8 "SquareSuperset" "\226\138\144" +let _ = Hashtbl.replace macro2utf8 "neq" "\226\137\160" +let _ = Hashtbl.replace macro2utf8 "circleddash" "\226\138\157" +let _ = Hashtbl.replace macro2utf8 "xrarr" "\239\149\183" +let _ = Hashtbl.replace macro2utf8 "barwed" "\226\138\188" +let _ = Hashtbl.replace macro2utf8 "lbrkslu" "\226\166\141" +let _ = Hashtbl.replace macro2utf8 "planckh" "\226\132\142" +let _ = Hashtbl.replace macro2utf8 "ldrdhar" "\226\165\167" +let _ = Hashtbl.replace macro2utf8 "circledcirc" "\226\138\154" +let _ = Hashtbl.replace macro2utf8 "ctdot" "\226\139\175" +let _ = Hashtbl.replace macro2utf8 "fallingdotseq" "\226\137\146" +let _ = Hashtbl.replace macro2utf8 "Map" "\226\164\133" +let _ = Hashtbl.replace macro2utf8 "VerticalBar" "\226\136\163" +let _ = Hashtbl.replace macro2utf8 "succeq" "\226\137\189" +let _ = Hashtbl.replace macro2utf8 "tint" "\226\136\173" +let _ = Hashtbl.replace macro2utf8 "imof" "\226\138\183" +let _ = Hashtbl.replace macro2utf8 "diam" "\226\139\132" +let _ = Hashtbl.replace macro2utf8 "twixt" "\226\137\172" +let _ = Hashtbl.replace macro2utf8 "NoBreak" "\239\187\191" +let _ = Hashtbl.replace macro2utf8 "langd" "\226\166\145" +let _ = Hashtbl.replace macro2utf8 "Bernoullis" "\226\132\172" +let _ = Hashtbl.replace macro2utf8 "rcaron" "\197\153" +let _ = Hashtbl.replace macro2utf8 "hom" "hom" +let _ = Hashtbl.replace macro2utf8 "nfr" "\240\157\148\171" +let _ = Hashtbl.replace macro2utf8 "backsimeq" "\226\139\141" +let _ = Hashtbl.replace macro2utf8 "target" "\226\140\150" +let _ = Hashtbl.replace macro2utf8 "ouml" "\195\182" +let _ = Hashtbl.replace macro2utf8 "nge" "\226\137\177\226\131\165" +let _ = Hashtbl.replace macro2utf8 "LeftTriangleBar" "\226\167\143" +let _ = Hashtbl.replace macro2utf8 "subplus" "\226\170\191" +let _ = Hashtbl.replace macro2utf8 "parsim" "\226\171\179" +let _ = Hashtbl.replace macro2utf8 "Gcedil" "\196\162" +let _ = Hashtbl.replace macro2utf8 "bnequiv" "\226\137\161\226\131\165" +let _ = Hashtbl.replace macro2utf8 "ubreve" "\197\173" +let _ = Hashtbl.replace macro2utf8 "iexcl" "\194\161" +let _ = Hashtbl.replace macro2utf8 "Xi" "\206\158" +let _ = Hashtbl.replace macro2utf8 "omega" "\207\137" +let _ = Hashtbl.replace macro2utf8 "elsdot" "\226\170\151" +let _ = Hashtbl.replace macro2utf8 "propto" "\226\136\157" +let _ = Hashtbl.replace macro2utf8 "squ" "\226\150\161" +let _ = Hashtbl.replace macro2utf8 "Ycirc" "\197\182" +let _ = Hashtbl.replace macro2utf8 "amacr" "\196\129" +let _ = Hashtbl.replace macro2utf8 "curlyeqprec" "\226\139\158" +let _ = Hashtbl.replace macro2utf8 "ngt" "\226\137\175" +let _ = Hashtbl.replace macro2utf8 "plusdo" "\226\136\148" +let _ = Hashtbl.replace macro2utf8 "ngeqslant" "\226\137\177" +let _ = Hashtbl.replace macro2utf8 "LongRightArrow" "\239\149\183" +let _ = Hashtbl.replace macro2utf8 "LeftUpVector" "\226\134\191" +let _ = Hashtbl.replace macro2utf8 "asymp" "\226\137\141" +let _ = Hashtbl.replace macro2utf8 "imped" "\240\157\149\131" +let _ = Hashtbl.replace macro2utf8 "tritime" "\226\168\187" +let _ = Hashtbl.replace macro2utf8 "rpargt" "\226\166\148" +let _ = Hashtbl.replace macro2utf8 "DDotrahd" "\226\164\145" +let _ = Hashtbl.replace macro2utf8 "prnsim" "\226\139\168" +let _ = Hashtbl.replace macro2utf8 "plusdu" "\226\168\165" +let _ = Hashtbl.replace macro2utf8 "cfr" "\240\157\148\160" +let _ = Hashtbl.replace macro2utf8 "abreve" "\196\131" +let _ = Hashtbl.replace macro2utf8 "suphsol" "\226\138\131/" +let _ = Hashtbl.replace macro2utf8 "NegativeThickSpace" "\226\128\133\239\184\128" +let _ = Hashtbl.replace macro2utf8 "Mcy" "\208\156" +let _ = Hashtbl.replace macro2utf8 "uarr" "\226\134\145" +let _ = Hashtbl.replace macro2utf8 "LeftRightVector" "\226\165\142" +let _ = Hashtbl.replace macro2utf8 "lAarr" "\226\135\154" +let _ = Hashtbl.replace macro2utf8 "bsim" "\226\136\189" +let _ = Hashtbl.replace macro2utf8 "simrarr" "\226\165\178" +let _ = Hashtbl.replace macro2utf8 "otimes" "\226\138\151" +let _ = Hashtbl.replace macro2utf8 "NotSucceeds" "\226\138\129" +let _ = Hashtbl.replace macro2utf8 "Cross" "\226\168\175" +let _ = Hashtbl.replace macro2utf8 "downarrow" "\226\134\147" +let _ = Hashtbl.replace macro2utf8 "blacktriangle" "\226\150\180" +let _ = Hashtbl.replace macro2utf8 "TripleDot" "\226\131\155" +let _ = Hashtbl.replace macro2utf8 "smallsetminus" "\226\136\150\239\184\128" +let _ = Hashtbl.replace macro2utf8 "supedot" "\226\171\132" +let _ = Hashtbl.replace macro2utf8 "NotPrecedesSlantEqual" "\226\139\160" +let _ = Hashtbl.replace macro2utf8 "neArr" "\226\135\151" +let _ = Hashtbl.replace macro2utf8 "rarrtl" "\226\134\163" +let _ = Hashtbl.replace macro2utf8 "isin" "\226\136\136" +let _ = Hashtbl.replace macro2utf8 "rrarr" "\226\135\137" +let _ = Hashtbl.replace macro2utf8 "Upsilon" "\207\146" +let _ = Hashtbl.replace macro2utf8 "sqsub" "\226\138\143" +let _ = Hashtbl.replace macro2utf8 "boxUL" "\226\149\157" +let _ = Hashtbl.replace macro2utf8 "LessTilde" "\226\137\178" +let _ = Hashtbl.replace macro2utf8 "Xfr" "\240\157\148\155" +let _ = Hashtbl.replace macro2utf8 "nis" "\226\139\188" +let _ = Hashtbl.replace macro2utf8 "chi" "\207\135" +let _ = Hashtbl.replace macro2utf8 "DownRightVector" "\226\135\129" +let _ = Hashtbl.replace macro2utf8 "niv" "\226\136\139" +let _ = Hashtbl.replace macro2utf8 "boxUR" "\226\149\154" +let _ = Hashtbl.replace macro2utf8 "nlArr" "\226\135\141" +let _ = Hashtbl.replace macro2utf8 "Bcy" "\208\145" +let _ = Hashtbl.replace macro2utf8 "tan" "tan" +let _ = Hashtbl.replace macro2utf8 "EmptyVerySmallSquare" "\239\150\156" +let _ = Hashtbl.replace macro2utf8 "dstrok" "\196\145" +let _ = Hashtbl.replace macro2utf8 "rfisht" "\226\165\189" +let _ = Hashtbl.replace macro2utf8 "easter" "\226\137\155" +let _ = Hashtbl.replace macro2utf8 "nlE" "\226\137\176" +let _ = Hashtbl.replace macro2utf8 "Mellintrf" "\226\132\179" +let _ = Hashtbl.replace macro2utf8 "lotimes" "\226\168\180" +let _ = Hashtbl.replace macro2utf8 "sqsup" "\226\138\144" +let _ = Hashtbl.replace macro2utf8 "boxVH" "\226\149\172" +let _ = Hashtbl.replace macro2utf8 "bbrk" "\226\142\181" +let _ = Hashtbl.replace macro2utf8 "tau" "\207\132" +let _ = Hashtbl.replace macro2utf8 "UpTee" "\226\138\165" +let _ = Hashtbl.replace macro2utf8 "NotLeftTriangleBar" "\226\167\143\204\184" +let _ = Hashtbl.replace macro2utf8 "boxVL" "\226\149\163" +let _ = Hashtbl.replace macro2utf8 "Proportion" "\226\136\183" +let _ = Hashtbl.replace macro2utf8 "equiv" "\226\137\161" +let _ = Hashtbl.replace macro2utf8 "blk12" "\226\150\146" +let _ = Hashtbl.replace macro2utf8 "blk14" "\226\150\145" +let _ = Hashtbl.replace macro2utf8 "fpartint" "\226\168\141" +let _ = Hashtbl.replace macro2utf8 "boxVR" "\226\149\160" +let _ = Hashtbl.replace macro2utf8 "starf" "\226\152\133" +let _ = Hashtbl.replace macro2utf8 "risingdotseq" "\226\137\147" +let _ = Hashtbl.replace macro2utf8 "Equilibrium" "\226\135\140" +let _ = Hashtbl.replace macro2utf8 "ijlig" "\196\179" +let _ = Hashtbl.replace macro2utf8 "yicy" "\209\151" +let _ = Hashtbl.replace macro2utf8 "sum" "\226\136\145" +let _ = Hashtbl.replace macro2utf8 "cir" "\226\151\139" +let _ = Hashtbl.replace macro2utf8 "telrec" "\226\140\149" +let _ = Hashtbl.replace macro2utf8 "Mfr" "\240\157\148\144" +let _ = Hashtbl.replace macro2utf8 "dHar" "\226\165\165" +let _ = Hashtbl.replace macro2utf8 "boxUl" "\226\149\156" +let _ = Hashtbl.replace macro2utf8 "apid" "\226\137\139" +let _ = Hashtbl.replace macro2utf8 "nleftarrow" "\226\134\154" +let _ = Hashtbl.replace macro2utf8 "curarrm" "\226\164\188" +let _ = Hashtbl.replace macro2utf8 "Scirc" "\197\156" +let _ = Hashtbl.replace macro2utf8 "Copf" "\226\132\130" +let _ = Hashtbl.replace macro2utf8 "RightTriangleEqual" "\226\138\181" +let _ = Hashtbl.replace macro2utf8 "boxUr" "\226\149\153" +let _ = Hashtbl.replace macro2utf8 "loplus" "\226\168\173" +let _ = Hashtbl.replace macro2utf8 "varsupsetneq" "\226\138\139\239\184\128" +let _ = Hashtbl.replace macro2utf8 "scaron" "\197\161" +let _ = Hashtbl.replace macro2utf8 "Diamond" "\226\139\132" +let _ = Hashtbl.replace macro2utf8 "lowast" "\226\136\151" +let _ = Hashtbl.replace macro2utf8 "nle" "\226\137\176\226\131\165" +let _ = Hashtbl.replace macro2utf8 "phiv" "\207\149" +let _ = Hashtbl.replace macro2utf8 "gesdotol" "\226\170\132" +let _ = Hashtbl.replace macro2utf8 "boxVh" "\226\149\171" +let _ = Hashtbl.replace macro2utf8 "nleftrightarrow" "\226\134\174" +let _ = Hashtbl.replace macro2utf8 "Jopf" "\240\157\149\129" +let _ = Hashtbl.replace macro2utf8 "boxVl" "\226\149\162" +let _ = Hashtbl.replace macro2utf8 "nearhk" "\226\164\164" +let _ = Hashtbl.replace macro2utf8 "vBarv" "\226\171\169" +let _ = Hashtbl.replace macro2utf8 "rHar" "\226\165\164" +let _ = Hashtbl.replace macro2utf8 "boxVr" "\226\149\159" +let _ = Hashtbl.replace macro2utf8 "lessdot" "\226\139\150" +let _ = Hashtbl.replace macro2utf8 "LeftDoubleBracket" "\227\128\154" +let _ = Hashtbl.replace macro2utf8 "Delta" "\206\148" +let _ = Hashtbl.replace macro2utf8 "limsup" "limsup" +let _ = Hashtbl.replace macro2utf8 "tcy" "\209\130" +let _ = Hashtbl.replace macro2utf8 "nlt" "\226\137\174" +let _ = Hashtbl.replace macro2utf8 "Cdot" "\196\138" +let _ = Hashtbl.replace macro2utf8 "blk34" "\226\150\147" +let _ = Hashtbl.replace macro2utf8 "Bfr" "\240\157\148\133" +let _ = Hashtbl.replace macro2utf8 "lowbar" "_" +let _ = Hashtbl.replace macro2utf8 "lneqq" "\226\137\168" +let _ = Hashtbl.replace macro2utf8 "TildeEqual" "\226\137\131" +let _ = Hashtbl.replace macro2utf8 "shortmid" "\226\136\163\239\184\128" +let _ = Hashtbl.replace macro2utf8 "Qopf" "\226\132\154" +let _ = Hashtbl.replace macro2utf8 "drcorn" "\226\140\159" +let _ = Hashtbl.replace macro2utf8 "ZeroWidthSpace" "\226\128\139" +let _ = Hashtbl.replace macro2utf8 "aogon" "\196\133" +let _ = Hashtbl.replace macro2utf8 "Rsh" "\226\134\177" +let _ = Hashtbl.replace macro2utf8 "lrarr" "\226\135\134" +let _ = Hashtbl.replace macro2utf8 "cupdot" "\226\138\141" +let _ = Hashtbl.replace macro2utf8 "Xopf" "\240\157\149\143" +let _ = Hashtbl.replace macro2utf8 "Backslash" "\226\136\150" +let _ = Hashtbl.replace macro2utf8 "Union" "\226\139\131" +let _ = Hashtbl.replace macro2utf8 "ratio" "\226\136\182" +let _ = Hashtbl.replace macro2utf8 "duarr" "\226\135\181" +let _ = Hashtbl.replace macro2utf8 "lates" "\226\170\173\239\184\128" +let _ = Hashtbl.replace macro2utf8 "suphsub" "\226\171\151" +let _ = Hashtbl.replace macro2utf8 "squf" "\226\150\170" +let _ = Hashtbl.replace macro2utf8 "gamma" "\206\179" +let _ = Hashtbl.replace macro2utf8 "lrhard" "\226\165\173" +let _ = Hashtbl.replace macro2utf8 "intprod" "\226\168\188" +let _ = Hashtbl.replace macro2utf8 "ReverseUpEquilibrium" "\226\165\175" +let _ = Hashtbl.replace macro2utf8 "icy" "\208\184" +let _ = Hashtbl.replace macro2utf8 "quatint" "\226\168\150" +let _ = Hashtbl.replace macro2utf8 "nbump" "\226\137\142\204\184" +let _ = Hashtbl.replace macro2utf8 "downharpoonleft" "\226\135\131" +let _ = Hashtbl.replace macro2utf8 "otimesas" "\226\168\182" +let _ = Hashtbl.replace macro2utf8 "nvHarr" "\226\135\142" +let _ = Hashtbl.replace macro2utf8 "ContourIntegral" "\226\136\174" +let _ = Hashtbl.replace macro2utf8 "bsol" "\\" +let _ = Hashtbl.replace macro2utf8 "DoubleUpDownArrow" "\226\135\149" +let _ = Hashtbl.replace macro2utf8 "disin" "\226\139\178" +let _ = Hashtbl.replace macro2utf8 "Breve" "\203\152" +let _ = Hashtbl.replace macro2utf8 "YAcy" "\208\175" +let _ = Hashtbl.replace macro2utf8 "precsim" "\226\137\190" +let _ = Hashtbl.replace macro2utf8 "NotGreaterGreater" "\226\137\171\204\184\239\184\128" +let _ = Hashtbl.replace macro2utf8 "fopf" "\240\157\149\151" +let _ = Hashtbl.replace macro2utf8 "SquareSupersetEqual" "\226\138\146" +let _ = Hashtbl.replace macro2utf8 "Dscr" "\240\157\146\159" +let _ = Hashtbl.replace macro2utf8 "gsime" "\226\170\142" +let _ = Hashtbl.replace macro2utf8 "PartialD" "\226\136\130" +let _ = Hashtbl.replace macro2utf8 "Umacr" "\197\170" +let _ = Hashtbl.replace macro2utf8 "tfr" "\240\157\148\177" +let _ = Hashtbl.replace macro2utf8 "cularrp" "\226\164\189" +let _ = Hashtbl.replace macro2utf8 "UnderBracket" "\226\142\181" +let _ = Hashtbl.replace macro2utf8 "ugrave" "\195\185" +let _ = Hashtbl.replace macro2utf8 "mopf" "\240\157\149\158" +let _ = Hashtbl.replace macro2utf8 "gsiml" "\226\170\144" +let _ = Hashtbl.replace macro2utf8 "iquest" "\194\191" +let _ = Hashtbl.replace macro2utf8 "nmid" "\226\136\164" +let _ = Hashtbl.replace macro2utf8 "leftarrowtail" "\226\134\162" +let _ = Hashtbl.replace macro2utf8 "not" "\194\172" +let _ = Hashtbl.replace macro2utf8 "Kscr" "\240\157\146\166" +let _ = Hashtbl.replace macro2utf8 "xsqcup" "\226\138\148" +let _ = Hashtbl.replace macro2utf8 "triangleleft" "\226\151\131" +let _ = Hashtbl.replace macro2utf8 "amalg" "\226\168\191" +let _ = Hashtbl.replace macro2utf8 "prcue" "\226\137\188" +let _ = Hashtbl.replace macro2utf8 "ac" "\226\164\143" +let _ = Hashtbl.replace macro2utf8 "nharr" "\226\134\174" +let _ = Hashtbl.replace macro2utf8 "dzcy" "\209\159" +let _ = Hashtbl.replace macro2utf8 "topf" "\240\157\149\165" +let _ = Hashtbl.replace macro2utf8 "iff" "\226\135\148" +let _ = Hashtbl.replace macro2utf8 "af" "\226\129\161" +let _ = Hashtbl.replace macro2utf8 "Uparrow" "\226\135\145" +let _ = Hashtbl.replace macro2utf8 "Iacute" "\195\141" +let _ = Hashtbl.replace macro2utf8 "Rscr" "\226\132\155" +let _ = Hashtbl.replace macro2utf8 "vrtri" "\226\138\179" +let _ = Hashtbl.replace macro2utf8 "multimap" "\226\138\184" +let _ = Hashtbl.replace macro2utf8 "Hat" "\204\130" +let _ = Hashtbl.replace macro2utf8 "rtriltri" "\226\167\142" +let _ = Hashtbl.replace macro2utf8 "npr" "\226\138\128" +let _ = Hashtbl.replace macro2utf8 "agrave" "\195\160" +let _ = Hashtbl.replace macro2utf8 "UnderBar" "\204\178" +let _ = Hashtbl.replace macro2utf8 "prime" "\226\128\178" +let _ = Hashtbl.replace macro2utf8 "plusmn" "\194\177" +let _ = Hashtbl.replace macro2utf8 "eplus" "\226\169\177" +let _ = Hashtbl.replace macro2utf8 "ap" "\226\137\136" +let _ = Hashtbl.replace macro2utf8 "dlcorn" "\226\140\158" +let _ = Hashtbl.replace macro2utf8 "backsim" "\226\136\189" +let _ = Hashtbl.replace macro2utf8 "ifr" "\240\157\148\166" +let _ = Hashtbl.replace macro2utf8 "bigcup" "\226\139\131" +let _ = Hashtbl.replace macro2utf8 "tcaron" "\197\165" +let _ = Hashtbl.replace macro2utf8 "sqcaps" "\226\138\147\239\184\128" +let _ = Hashtbl.replace macro2utf8 "equals" "=" +let _ = Hashtbl.replace macro2utf8 "curlywedge" "\226\139\143" +let _ = Hashtbl.replace macro2utf8 "Yscr" "\240\157\146\180" +let _ = Hashtbl.replace macro2utf8 "longrightarrow" "????" +let _ = Hashtbl.replace macro2utf8 "fork" "\226\139\148" +let _ = Hashtbl.replace macro2utf8 "cos" "cos" +let _ = Hashtbl.replace macro2utf8 "cot" "cot" +let _ = Hashtbl.replace macro2utf8 "ImaginaryI" "\226\133\136" +let _ = Hashtbl.replace macro2utf8 "Scy" "\208\161" +let _ = Hashtbl.replace macro2utf8 "mapsto" "\226\134\166" +let _ = Hashtbl.replace macro2utf8 "tdot" "\226\131\155" +let _ = Hashtbl.replace macro2utf8 "vellip" "\226\139\174" +let _ = Hashtbl.replace macro2utf8 "sqsupseteq" "\226\138\146" +let _ = Hashtbl.replace macro2utf8 "nvdash" "\226\138\172" +let _ = Hashtbl.replace macro2utf8 "NotSuperset" "\226\138\133" +let _ = Hashtbl.replace macro2utf8 "DoubleUpArrow" "\226\135\145" +let _ = Hashtbl.replace macro2utf8 "land" "\226\136\167" +let _ = Hashtbl.replace macro2utf8 "topfork" "\226\171\154" +let _ = Hashtbl.replace macro2utf8 "llhard" "\226\165\171" +let _ = Hashtbl.replace macro2utf8 "apos" "'" +let _ = Hashtbl.replace macro2utf8 "oslash" "\195\184" +let _ = Hashtbl.replace macro2utf8 "lang" "\226\140\169" +let _ = Hashtbl.replace macro2utf8 "bernou" "\226\132\172" +let _ = Hashtbl.replace macro2utf8 "varrho" "\207\177" +let _ = Hashtbl.replace macro2utf8 "rcub" "}" +let _ = Hashtbl.replace macro2utf8 "Cedilla" "\194\184" +let _ = Hashtbl.replace macro2utf8 "ApplyFunction" "\226\129\161" +let _ = Hashtbl.replace macro2utf8 "nsce" "\226\170\176\204\184" +let _ = Hashtbl.replace macro2utf8 "gscr" "\226\132\138" +let _ = Hashtbl.replace macro2utf8 "imagpart" "\226\132\145" +let _ = Hashtbl.replace macro2utf8 "ngtr" "\226\137\175" +let _ = Hashtbl.replace macro2utf8 "nsc" "\226\138\129" +let _ = Hashtbl.replace macro2utf8 "Barv" "\226\171\167" +let _ = Hashtbl.replace macro2utf8 "tosa" "\226\164\169" +let _ = Hashtbl.replace macro2utf8 "nwnear" "\226\164\167" +let _ = Hashtbl.replace macro2utf8 "ltlarr" "\226\165\182" +let _ = Hashtbl.replace macro2utf8 "PrecedesEqual" "\226\170\175" +let _ = Hashtbl.replace macro2utf8 "lessapprox" "\226\137\178" +let _ = Hashtbl.replace macro2utf8 "Lcaron" "\196\189" +let _ = Hashtbl.replace utf82macro "\204\130" "Hat" +let _ = Hashtbl.replace utf82macro "\t" "Tab" +let _ = Hashtbl.replace utf82macro "\203\152" "Breve" +let _ = Hashtbl.replace utf82macro "\n" "NewLine" +let _ = Hashtbl.replace utf82macro "\203\153" "dot" +let _ = Hashtbl.replace utf82macro "\203\154" "ring" +let _ = Hashtbl.replace utf82macro "\203\155" "ogon" +let _ = Hashtbl.replace utf82macro "\203\156" "tilde" +let _ = Hashtbl.replace utf82macro "\203\157" "DiacriticalDoubleAcute" +let _ = Hashtbl.replace utf82macro "\226\137\171\204\184" "nGt" +let _ = Hashtbl.replace utf82macro "\204\145" "DownBreve" +let _ = Hashtbl.replace utf82macro "csc" "csc" +let _ = Hashtbl.replace utf82macro "\239\187\191" "NoBreak" +let _ = Hashtbl.replace utf82macro "!" "excl" +let _ = Hashtbl.replace utf82macro "\"" "quot" +let _ = Hashtbl.replace utf82macro "#" "num" +let _ = Hashtbl.replace utf82macro "$" "dollar" +let _ = Hashtbl.replace utf82macro "%" "percnt" +let _ = Hashtbl.replace utf82macro "&" "amp" +let _ = Hashtbl.replace utf82macro "'" "apos" +let _ = Hashtbl.replace utf82macro "(" "lpar" +let _ = Hashtbl.replace utf82macro ")" "rpar" +let _ = Hashtbl.replace utf82macro "\226\139\155\239\184\128" "gesl" +let _ = Hashtbl.replace utf82macro "*" "ast" +let _ = Hashtbl.replace utf82macro "+" "plus" +let _ = Hashtbl.replace utf82macro "\226\167\144\204\184" "NotRightTriangleBar" +let _ = Hashtbl.replace utf82macro "," "comma" +let _ = Hashtbl.replace utf82macro "." "period" +let _ = Hashtbl.replace utf82macro "/" "sol" +let _ = Hashtbl.replace utf82macro "\204\178" "UnderBar" +let _ = Hashtbl.replace utf82macro ":" "colon" +let _ = Hashtbl.replace utf82macro ";" "semi" +let _ = Hashtbl.replace utf82macro "<" "lt" +let _ = Hashtbl.replace utf82macro "\207\128" "pi" +let _ = Hashtbl.replace utf82macro "\206\147" "Gamma" +let _ = Hashtbl.replace utf82macro "=" "equals" +let _ = Hashtbl.replace utf82macro "\207\129" "rho" +let _ = Hashtbl.replace utf82macro ">" "gt" +let _ = Hashtbl.replace utf82macro "\206\148" "Delta" +let _ = Hashtbl.replace utf82macro "\207\130" "varsigma" +let _ = Hashtbl.replace utf82macro "?" "quest" +let _ = Hashtbl.replace utf82macro "\207\131" "sigma" +let _ = Hashtbl.replace utf82macro "@" "commat" +let _ = Hashtbl.replace utf82macro "\207\132" "tau" +let _ = Hashtbl.replace utf82macro "\207\133" "upsilon" +let _ = Hashtbl.replace utf82macro "\206\152" "Theta" +let _ = Hashtbl.replace utf82macro "\207\134" "varphi" +let _ = Hashtbl.replace utf82macro "\207\135" "chi" +let _ = Hashtbl.replace utf82macro "\207\136" "psi" +let _ = Hashtbl.replace utf82macro "\206\155" "Lambda" +let _ = Hashtbl.replace utf82macro "\207\137" "omega" +let _ = Hashtbl.replace utf82macro "\206\158" "Xi" +let _ = Hashtbl.replace utf82macro "\206\160" "Pi" +let _ = Hashtbl.replace utf82macro "\206\163" "Sigma" +let _ = Hashtbl.replace utf82macro "\207\145" "vartheta" +let _ = Hashtbl.replace utf82macro "\207\146" "Upsilon" +let _ = Hashtbl.replace utf82macro "\206\166" "Phi" +let _ = Hashtbl.replace utf82macro "\208\129" "IOcy" +let _ = Hashtbl.replace utf82macro "\206\168" "Psi" +let _ = Hashtbl.replace utf82macro "\207\149" "phi" +let _ = Hashtbl.replace utf82macro "\208\130" "DJcy" +let _ = Hashtbl.replace utf82macro "\207\150" "varpi" +let _ = Hashtbl.replace utf82macro "\206\169" "Omega" +let _ = Hashtbl.replace utf82macro "\208\131" "GJcy" +let _ = Hashtbl.replace utf82macro "\208\132" "Jukcy" +let _ = Hashtbl.replace utf82macro "\208\133" "DScy" +let _ = Hashtbl.replace utf82macro "\208\134" "Iukcy" +let _ = Hashtbl.replace utf82macro "\208\135" "YIcy" +let _ = Hashtbl.replace utf82macro "\208\136" "Jsercy" +let _ = Hashtbl.replace utf82macro "\208\137" "LJcy" +let _ = Hashtbl.replace utf82macro "\207\156" "Gammad" +let _ = Hashtbl.replace utf82macro "\208\138" "NJcy" +let _ = Hashtbl.replace utf82macro "\208\139" "TSHcy" +let _ = Hashtbl.replace utf82macro "[" "lbrack" +let _ = Hashtbl.replace utf82macro "\206\177" "alpha" +let _ = Hashtbl.replace utf82macro "\208\140" "KJcy" +let _ = Hashtbl.replace utf82macro "\\" "backslash" +let _ = Hashtbl.replace utf82macro "\206\178" "beta" +let _ = Hashtbl.replace utf82macro "]" "rbrack" +let _ = Hashtbl.replace utf82macro "\206\179" "gamma" +let _ = Hashtbl.replace utf82macro "\208\142" "Ubrcy" +let _ = Hashtbl.replace utf82macro "\206\180" "delta" +let _ = Hashtbl.replace utf82macro "^" "circ" +let _ = Hashtbl.replace utf82macro "_" "lowbar" +let _ = Hashtbl.replace utf82macro "\206\181" "varepsilon" +let _ = Hashtbl.replace utf82macro "\208\143" "DZcy" +let _ = Hashtbl.replace utf82macro "\206\182" "zeta" +let _ = Hashtbl.replace utf82macro "`" "grave" +let _ = Hashtbl.replace utf82macro "\208\144" "Acy" +let _ = Hashtbl.replace utf82macro "inf" "inf" +let _ = Hashtbl.replace utf82macro "\206\183" "eta" +let _ = Hashtbl.replace utf82macro "\208\145" "Bcy" +let _ = Hashtbl.replace utf82macro "\208\146" "Vcy" +let _ = Hashtbl.replace utf82macro "\206\184" "theta" +let _ = Hashtbl.replace utf82macro "\209\128" "rcy" +let _ = Hashtbl.replace utf82macro "\226\139\172\204\184" "nvltrie" +let _ = Hashtbl.replace utf82macro "\206\185" "iota" +let _ = Hashtbl.replace utf82macro "\208\147" "Gcy" +let _ = Hashtbl.replace utf82macro "\209\129" "scy" +let _ = Hashtbl.replace utf82macro "\206\186" "kappa" +let _ = Hashtbl.replace utf82macro "\208\148" "Dcy" +let _ = Hashtbl.replace utf82macro "\209\130" "tcy" +let _ = Hashtbl.replace utf82macro "\226\164\179\204\184" "nrarrc" +let _ = Hashtbl.replace utf82macro "\206\187" "lambda" +let _ = Hashtbl.replace utf82macro "\208\149" "IEcy" +let _ = Hashtbl.replace utf82macro "\208\150" "ZHcy" +let _ = Hashtbl.replace utf82macro "\209\131" "ucy" +let _ = Hashtbl.replace utf82macro "\206\188" "mu" +let _ = Hashtbl.replace utf82macro "\208\151" "Zcy" +let _ = Hashtbl.replace utf82macro "\206\189" "nu" +let _ = Hashtbl.replace utf82macro "\209\132" "fcy" +let _ = Hashtbl.replace utf82macro "\206\190" "xi" +let _ = Hashtbl.replace utf82macro "\209\133" "khcy" +let _ = Hashtbl.replace utf82macro "\208\152" "Icy" +let _ = Hashtbl.replace utf82macro "\206\191" "o" +let _ = Hashtbl.replace utf82macro "\209\134" "tscy" +let _ = Hashtbl.replace utf82macro "\208\153" "Jcy" +let _ = Hashtbl.replace utf82macro "\208\154" "Kcy" +let _ = Hashtbl.replace utf82macro "\209\135" "chcy" +let _ = Hashtbl.replace utf82macro "\209\136" "shcy" +let _ = Hashtbl.replace utf82macro "\208\155" "Lcy" +let _ = Hashtbl.replace utf82macro "\209\137" "shchcy" +let _ = Hashtbl.replace utf82macro "\208\156" "Mcy" +let _ = Hashtbl.replace utf82macro "\208\157" "Ncy" +let _ = Hashtbl.replace utf82macro "\207\176" "varkappa" +let _ = Hashtbl.replace utf82macro "\209\138" "hardcy" +let _ = Hashtbl.replace utf82macro "\209\139" "ycy" +let _ = Hashtbl.replace utf82macro "\207\177" "varrho" +let _ = Hashtbl.replace utf82macro "\208\158" "Ocy" +let _ = Hashtbl.replace utf82macro "\209\140" "softcy" +let _ = Hashtbl.replace utf82macro "\208\159" "Pcy" +let _ = Hashtbl.replace utf82macro "\208\160" "Rcy" +let _ = Hashtbl.replace utf82macro "\209\141" "ecy" +let _ = Hashtbl.replace utf82macro "\209\142" "yucy" +let _ = Hashtbl.replace utf82macro "\208\161" "Scy" +let _ = Hashtbl.replace utf82macro "\207\181" "epsilon" +let _ = Hashtbl.replace utf82macro "\209\143" "yacy" +let _ = Hashtbl.replace utf82macro "\208\162" "Tcy" +let _ = Hashtbl.replace utf82macro "\208\163" "Ucy" +let _ = Hashtbl.replace utf82macro "\207\182" "bepsi" +let _ = Hashtbl.replace utf82macro "\209\145" "iocy" +let _ = Hashtbl.replace utf82macro "\208\164" "Fcy" +let _ = Hashtbl.replace utf82macro "\208\165" "KHcy" +let _ = Hashtbl.replace utf82macro "\209\146" "djcy" +let _ = Hashtbl.replace utf82macro "\208\166" "TScy" +let _ = Hashtbl.replace utf82macro "\209\147" "gjcy" +let _ = Hashtbl.replace utf82macro "\209\148" "jukcy" +let _ = Hashtbl.replace utf82macro "\208\167" "CHcy" +let _ = Hashtbl.replace utf82macro "????" "longmapsto" +let _ = Hashtbl.replace utf82macro "\208\168" "SHcy" +let _ = Hashtbl.replace utf82macro "\209\149" "dscy" +let _ = Hashtbl.replace utf82macro "\208\169" "SHCHcy" +let _ = Hashtbl.replace utf82macro "\209\150" "iukcy" +let _ = Hashtbl.replace utf82macro "deg" "deg" +let _ = Hashtbl.replace utf82macro "\209\151" "yicy" +let _ = Hashtbl.replace utf82macro "\208\170" "HARDcy" +let _ = Hashtbl.replace utf82macro "\208\171" "Ycy" +let _ = Hashtbl.replace utf82macro "{" "{" +let _ = Hashtbl.replace utf82macro "\209\152" "jsercy" +let _ = Hashtbl.replace utf82macro "|" "vert" +let _ = Hashtbl.replace utf82macro "\208\172" "SOFTcy" +let _ = Hashtbl.replace utf82macro "\209\153" "ljcy" +let _ = Hashtbl.replace utf82macro "liminf" "liminf" +let _ = Hashtbl.replace utf82macro "}" "}" +let _ = Hashtbl.replace utf82macro "\209\154" "njcy" +let _ = Hashtbl.replace utf82macro "\208\173" "Ecy" +let _ = Hashtbl.replace utf82macro "\208\174" "YUcy" +let _ = Hashtbl.replace utf82macro "\209\155" "tshcy" +let _ = Hashtbl.replace utf82macro "\208\175" "YAcy" +let _ = Hashtbl.replace utf82macro "\209\156" "kjcy" +let _ = Hashtbl.replace utf82macro "\208\176" "acy" +let _ = Hashtbl.replace utf82macro "\209\158" "ubrcy" +let _ = Hashtbl.replace utf82macro "\208\177" "bcy" +let _ = Hashtbl.replace utf82macro "\208\178" "vcy" +let _ = Hashtbl.replace utf82macro "\209\159" "dzcy" +let _ = Hashtbl.replace utf82macro "\208\179" "gcy" +let _ = Hashtbl.replace utf82macro "\208\180" "dcy" +let _ = Hashtbl.replace utf82macro "\208\181" "iecy" +let _ = Hashtbl.replace utf82macro "\208\182" "zhcy" +let _ = Hashtbl.replace utf82macro "det" "det" +let _ = Hashtbl.replace utf82macro "\208\183" "zcy" +let _ = Hashtbl.replace utf82macro "\208\184" "icy" +let _ = Hashtbl.replace utf82macro "\208\185" "jcy" +let _ = Hashtbl.replace utf82macro "\208\186" "kcy" +let _ = Hashtbl.replace utf82macro "\208\187" "lcy" +let _ = Hashtbl.replace utf82macro "\208\188" "mcy" +let _ = Hashtbl.replace utf82macro "\226\146\161\204\184" "NotNestedLessLess" +let _ = Hashtbl.replace utf82macro "\208\189" "ncy" +let _ = Hashtbl.replace utf82macro "\208\190" "ocy" +let _ = Hashtbl.replace utf82macro "\208\191" "pcy" +let _ = Hashtbl.replace utf82macro "\226\128\130" "ensp" +let _ = Hashtbl.replace utf82macro "\226\128\131" "emsp" +let _ = Hashtbl.replace utf82macro "\226\128\132" "emsp13" +let _ = Hashtbl.replace utf82macro "\226\128\133" "emsp14" +let _ = Hashtbl.replace utf82macro "\226\128\135" "numsp" +let _ = Hashtbl.replace utf82macro "\226\128\136" "puncsp" +let _ = Hashtbl.replace utf82macro "lg" "lg" +let _ = Hashtbl.replace utf82macro "\226\128\137" "ThinSpace" +let _ = Hashtbl.replace utf82macro "\226\128\138" "VeryThinSpace" +let _ = Hashtbl.replace utf82macro "\226\128\139" "ZeroWidthSpace" +let _ = Hashtbl.replace utf82macro "ln" "ln" +let _ = Hashtbl.replace utf82macro "\226\128\144" "hyphen" +let _ = Hashtbl.replace utf82macro "\226\128\147" "ndash" +let _ = Hashtbl.replace utf82macro "\226\128\148" "mdash" +let _ = Hashtbl.replace utf82macro "\226\129\129" "caret" +let _ = Hashtbl.replace utf82macro "\226\128\149" "horbar" +let _ = Hashtbl.replace utf82macro "\226\128\150" "Vert" +let _ = Hashtbl.replace utf82macro "\226\129\131" "hybull" +let _ = Hashtbl.replace utf82macro "\226\128\152" "OpenCurlyQuote" +let _ = Hashtbl.replace utf82macro "\226\128\153" "rsquor" +let _ = Hashtbl.replace utf82macro "\226\170\176\204\184" "nsucceq" +let _ = Hashtbl.replace utf82macro "\226\128\154" "lsquor" +let _ = Hashtbl.replace utf82macro "\226\128\156" "OpenCurlyDoubleQuote" +let _ = Hashtbl.replace utf82macro "\226\128\157" "rdquor" +let _ = Hashtbl.replace utf82macro "\226\128\158" "ldquor" +let _ = Hashtbl.replace utf82macro "\226\128\160" "dagger" +let _ = Hashtbl.replace utf82macro "\226\128\161" "ddagger" +let _ = Hashtbl.replace utf82macro "\226\136\133\239\184\128" "emptyset" +let _ = Hashtbl.replace utf82macro "\226\128\162" "bullet" +let _ = Hashtbl.replace utf82macro "\226\129\143" "bsemi" +let _ = Hashtbl.replace utf82macro "\226\128\165" "nldr" +let _ = Hashtbl.replace utf82macro "\226\128\166" "ldots" +let _ = Hashtbl.replace utf82macro "\226\129\151" "qprime" +let _ = Hashtbl.replace utf82macro "\226\128\176" "permil" +let _ = Hashtbl.replace utf82macro "\226\128\177" "pertenk" +let _ = Hashtbl.replace utf82macro "\226\128\178" "prime" +let _ = Hashtbl.replace utf82macro "\226\129\159" "MediumSpace" +let _ = Hashtbl.replace utf82macro "\226\128\179" "Prime" +let _ = Hashtbl.replace utf82macro "\226\128\180" "tprime" +let _ = Hashtbl.replace utf82macro "\226\129\161" "ApplyFunction" +let _ = Hashtbl.replace utf82macro "\226\129\162" "it" +let _ = Hashtbl.replace utf82macro "\226\128\181" "bprime" +let _ = Hashtbl.replace utf82macro "dim" "dim" +let _ = Hashtbl.replace utf82macro "\226\132\130" "Copf" +let _ = Hashtbl.replace utf82macro "\226\132\133" "incare" +let _ = Hashtbl.replace utf82macro "\226\131\155" "TripleDot" +let _ = Hashtbl.replace utf82macro "\226\169\173\204\184" "ncongdot" +let _ = Hashtbl.replace utf82macro "\226\131\156" "DotDot" +let _ = Hashtbl.replace utf82macro "\226\132\138" "gscr" +let _ = Hashtbl.replace utf82macro "\226\132\139" "Hscr" +let _ = Hashtbl.replace utf82macro "\226\132\140" "Poincareplane" +let _ = Hashtbl.replace utf82macro "\226\132\141" "quaternions" +let _ = Hashtbl.replace utf82macro "\226\132\142" "planckh" +let _ = Hashtbl.replace utf82macro "\226\132\143" "plankv" +let _ = Hashtbl.replace utf82macro "\226\132\144" "Iscr" +let _ = Hashtbl.replace utf82macro "\226\132\145" "Im" +let _ = Hashtbl.replace utf82macro "\226\132\146" "Lscr" +let _ = Hashtbl.replace utf82macro "\226\132\147" "ell" +let _ = Hashtbl.replace utf82macro "\226\132\149" "Nopf" +let _ = Hashtbl.replace utf82macro "\226\132\150" "numero" +let _ = Hashtbl.replace utf82macro "\226\132\151" "copysr" +let _ = Hashtbl.replace utf82macro "\226\132\152" "wp" +let _ = Hashtbl.replace utf82macro "\226\133\133" "DD" +let _ = Hashtbl.replace utf82macro "\226\132\153" "primes" +let _ = Hashtbl.replace utf82macro "\226\133\134" "DifferentialD" +let _ = Hashtbl.replace utf82macro "\226\132\154" "rationals" +let _ = Hashtbl.replace utf82macro "\226\133\135" "ExponentialE" +let _ = Hashtbl.replace utf82macro "\226\132\155" "Rscr" +let _ = Hashtbl.replace utf82macro "\226\133\136" "ImaginaryI" +let _ = Hashtbl.replace utf82macro "\226\132\156" "Re" +let _ = Hashtbl.replace utf82macro "\226\132\157" "Ropf" +let _ = Hashtbl.replace utf82macro "\226\132\158" "rx" +let _ = Hashtbl.replace utf82macro "\226\132\162" "trade" +let _ = Hashtbl.replace utf82macro "\226\132\164" "Zopf" +let _ = Hashtbl.replace utf82macro "\226\132\166" "ohm" +let _ = Hashtbl.replace utf82macro "\226\133\147" "frac13" +let _ = Hashtbl.replace utf82macro "\226\132\167" "mho" +let _ = Hashtbl.replace utf82macro "\226\133\148" "frac23" +let _ = Hashtbl.replace utf82macro "\226\132\168" "Zfr" +let _ = Hashtbl.replace utf82macro "\226\133\149" "frac15" +let _ = Hashtbl.replace utf82macro "\226\132\169" "iiota" +let _ = Hashtbl.replace utf82macro "\226\133\150" "frac25" +let _ = Hashtbl.replace utf82macro "\226\133\151" "frac35" +let _ = Hashtbl.replace utf82macro "\226\133\152" "frac45" +let _ = Hashtbl.replace utf82macro "\226\132\171" "angst" +let _ = Hashtbl.replace utf82macro "\226\133\153" "frac16" +let _ = Hashtbl.replace utf82macro "\226\132\172" "Bscr" +let _ = Hashtbl.replace utf82macro "\226\129\159\239\184\128" "NegativeMediumSpace" +let _ = Hashtbl.replace utf82macro "\226\133\154" "frac56" +let _ = Hashtbl.replace utf82macro "\226\132\173" "Cfr" +let _ = Hashtbl.replace utf82macro "\226\133\155" "frac18" +let _ = Hashtbl.replace utf82macro "\226\133\156" "frac38" +let _ = Hashtbl.replace utf82macro "\226\132\175" "escr" +let _ = Hashtbl.replace utf82macro "\226\133\157" "frac58" +let _ = Hashtbl.replace utf82macro "\226\132\176" "expectation" +let _ = Hashtbl.replace utf82macro "\226\133\158" "frac78" +let _ = Hashtbl.replace utf82macro "\226\132\177" "Fscr" +let _ = Hashtbl.replace utf82macro "\226\132\179" "phmmat" +let _ = Hashtbl.replace utf82macro "\226\132\180" "oscr" +let _ = Hashtbl.replace utf82macro "\226\132\181" "aleph" +let _ = Hashtbl.replace utf82macro "\226\134\144" "gets" +let _ = Hashtbl.replace utf82macro "\226\132\182" "beth" +let _ = Hashtbl.replace utf82macro "\226\134\145" "uparrow" +let _ = Hashtbl.replace utf82macro "\226\132\183" "gimel" +let _ = Hashtbl.replace utf82macro "\226\134\146" "to" +let _ = Hashtbl.replace utf82macro "\226\132\184" "daleth" +let _ = Hashtbl.replace utf82macro "\226\135\128" "RightVector" +let _ = Hashtbl.replace utf82macro "\226\134\147" "downarrow" +let _ = Hashtbl.replace utf82macro "\226\134\148" "leftrightarrow" +let _ = Hashtbl.replace utf82macro "\226\135\129" "rightharpoondown" +let _ = Hashtbl.replace utf82macro "\226\134\149" "updownarrow" +let _ = Hashtbl.replace utf82macro "\226\135\130" "RightDownVector" +let _ = Hashtbl.replace utf82macro "\226\134\150" "nwarrow" +let _ = Hashtbl.replace utf82macro "\226\135\131" "LeftDownVector" +let _ = Hashtbl.replace utf82macro "\226\135\132" "rlarr" +let _ = Hashtbl.replace utf82macro "\226\134\151" "nearrow" +let _ = Hashtbl.replace utf82macro "\226\135\133" "UpArrowDownArrow" +let _ = Hashtbl.replace utf82macro "\226\134\152" "searrow" +let _ = Hashtbl.replace utf82macro "\226\134\153" "swarrow" +let _ = Hashtbl.replace utf82macro "\226\135\134" "lrarr" +let _ = Hashtbl.replace utf82macro "\226\134\154" "nleftarrow" +let _ = Hashtbl.replace utf82macro "\226\135\135" "llarr" +let _ = Hashtbl.replace utf82macro "\226\135\136" "uuarr" +let _ = Hashtbl.replace utf82macro "\226\134\155" "nrightarrow" +let _ = Hashtbl.replace utf82macro "\226\135\137" "rrarr" +let _ = Hashtbl.replace utf82macro "\226\134\157" "rightsquigarrow" +let _ = Hashtbl.replace utf82macro "\226\135\138" "downdownarrows" +let _ = Hashtbl.replace utf82macro "\226\135\139" "ReverseEquilibrium" +let _ = Hashtbl.replace utf82macro "\226\134\158" "twoheadleftarrow" +let _ = Hashtbl.replace utf82macro "\226\134\159" "Uarr" +let _ = Hashtbl.replace utf82macro "\226\135\140" "rlhar" +let _ = Hashtbl.replace utf82macro "\226\134\160" "twoheadrightarrow" +let _ = Hashtbl.replace utf82macro "\226\135\141" "nvlArr" +let _ = Hashtbl.replace utf82macro "\226\135\142" "nvHarr" +let _ = Hashtbl.replace utf82macro "\226\134\161" "Darr" +let _ = Hashtbl.replace utf82macro "\226\135\143" "nvrArr" +let _ = Hashtbl.replace utf82macro "\226\134\162" "leftarrowtail" +let _ = Hashtbl.replace utf82macro "\226\134\163" "rightarrowtail" +let _ = Hashtbl.replace utf82macro "\226\135\144" "Leftarrow" +let _ = Hashtbl.replace utf82macro "\226\134\164" "mapstoleft" +let _ = Hashtbl.replace utf82macro "\226\135\145" "Uparrow" +let _ = Hashtbl.replace utf82macro "\226\134\165" "UpTeeArrow" +let _ = Hashtbl.replace utf82macro "\226\135\146" "Longrightarrow" +let _ = Hashtbl.replace utf82macro "\226\134\166" "mapsto" +let _ = Hashtbl.replace utf82macro "\226\136\128" "forall" +let _ = Hashtbl.replace utf82macro "\226\135\147" "Downarrow" +let _ = Hashtbl.replace utf82macro "\226\134\167" "mapstodown" +let _ = Hashtbl.replace utf82macro "\226\135\148" "Leftrightarrow" +let _ = Hashtbl.replace utf82macro "\226\136\129" "complement" +let _ = Hashtbl.replace utf82macro "\226\136\130" "partial" +let _ = Hashtbl.replace utf82macro "\226\135\149" "vArr" +let _ = Hashtbl.replace utf82macro "\226\135\150" "nwArr" +let _ = Hashtbl.replace utf82macro "\226\134\169" "hookleftarrow" +let _ = Hashtbl.replace utf82macro "\226\136\131" "exists" +let _ = Hashtbl.replace utf82macro "\226\136\132" "NotExists" +let _ = Hashtbl.replace utf82macro "\226\135\151" "neArr" +let _ = Hashtbl.replace utf82macro "\226\134\170" "hookrightarrow" +let _ = Hashtbl.replace utf82macro "\226\135\152" "seArr" +let _ = Hashtbl.replace utf82macro "\226\134\171" "looparrowleft" +let _ = Hashtbl.replace utf82macro "\226\136\133" "varnothing" +let _ = Hashtbl.replace utf82macro "\226\135\153" "swArr" +let _ = Hashtbl.replace utf82macro "\226\134\172" "rarrlp" +let _ = Hashtbl.replace utf82macro "\226\135\154" "Lleftarrow" +let _ = Hashtbl.replace utf82macro "\226\134\173" "leftrightsquigarrow" +let _ = Hashtbl.replace utf82macro "\226\136\135" "nabla" +let _ = Hashtbl.replace utf82macro "\226\135\155" "Rrightarrow" +let _ = Hashtbl.replace utf82macro "\226\134\174" "nleftrightarrow" +let _ = Hashtbl.replace utf82macro "\226\136\136" "in" +let _ = Hashtbl.replace utf82macro "\226\136\137" "notin" +let _ = Hashtbl.replace utf82macro "\226\135\157" "zigrarr" +let _ = Hashtbl.replace utf82macro "\226\134\176" "Lsh" +let _ = Hashtbl.replace utf82macro "\226\134\177" "Rsh" +let _ = Hashtbl.replace utf82macro "\226\136\139" "owns" +let _ = Hashtbl.replace utf82macro "\226\136\140" "NotReverseElement" +let _ = Hashtbl.replace utf82macro "\226\134\178" "ldsh" +let _ = Hashtbl.replace utf82macro "\226\134\179" "rdsh" +let _ = Hashtbl.replace utf82macro "\226\136\143" "prod" +let _ = Hashtbl.replace utf82macro "\226\134\182" "curvearrowleft" +let _ = Hashtbl.replace utf82macro "\226\136\144" "coprod" +let _ = Hashtbl.replace utf82macro "\226\136\145" "sum" +let _ = Hashtbl.replace utf82macro "\226\135\164" "LeftArrowBar" +let _ = Hashtbl.replace utf82macro "\226\134\183" "curvearrowright" +let _ = Hashtbl.replace utf82macro "\226\135\165" "RightArrowBar" +let _ = Hashtbl.replace utf82macro "\226\136\146" "minus" +let _ = Hashtbl.replace utf82macro "\226\137\128" "wr" +let _ = Hashtbl.replace utf82macro "\226\136\147" "mp" +let _ = Hashtbl.replace utf82macro "\226\137\129" "nsim" +let _ = Hashtbl.replace utf82macro "\226\136\148" "plusdo" +let _ = Hashtbl.replace utf82macro "\226\134\186" "olarr" +let _ = Hashtbl.replace utf82macro "\226\137\130" "esim" +let _ = Hashtbl.replace utf82macro "\226\134\187" "orarr" +let _ = Hashtbl.replace utf82macro "\226\137\131" "simeq" +let _ = Hashtbl.replace utf82macro "\226\134\188" "lharu" +let _ = Hashtbl.replace utf82macro "\226\136\150" "setminus" +let _ = Hashtbl.replace utf82macro "\226\137\132" "nsimeq" +let _ = Hashtbl.replace utf82macro "\226\136\151" "lowast" +let _ = Hashtbl.replace utf82macro "\226\134\189" "lhard" +let _ = Hashtbl.replace utf82macro "\226\134\190" "upharpoonright" +let _ = Hashtbl.replace utf82macro "\226\137\133" "cong" +let _ = Hashtbl.replace utf82macro "\226\136\152" "circ" +let _ = Hashtbl.replace utf82macro "\226\137\134" "simne" +let _ = Hashtbl.replace utf82macro "\226\134\191" "upharpoonleft" +let _ = Hashtbl.replace utf82macro "\226\136\154" "Sqrt" +let _ = Hashtbl.replace utf82macro "\226\137\135" "NotTildeFullEqual" +let _ = Hashtbl.replace utf82macro "\226\137\136" "approx" +let _ = Hashtbl.replace utf82macro "\226\137\137" "NotTildeTilde" +let _ = Hashtbl.replace utf82macro "\226\136\157" "propto" +let _ = Hashtbl.replace utf82macro "\226\137\138" "approxeq" +let _ = Hashtbl.replace utf82macro "\226\136\158" "infty" +let _ = Hashtbl.replace utf82macro "\226\137\139" "apid" +let _ = Hashtbl.replace utf82macro "\226\137\140" "bcong" +let _ = Hashtbl.replace utf82macro "\226\136\159" "angrt" +let _ = Hashtbl.replace utf82macro "\226\137\141" "asymp" +let _ = Hashtbl.replace utf82macro "\226\136\160" "angle" +let _ = Hashtbl.replace utf82macro "\226\137\142" "HumpDownHump" +let _ = Hashtbl.replace utf82macro "\226\136\161" "measuredangle" +let _ = Hashtbl.replace utf82macro "\226\135\181" "duarr" +let _ = Hashtbl.replace utf82macro "\226\137\143" "HumpEqual" +let _ = Hashtbl.replace utf82macro "\226\136\162" "angsph" +let _ = Hashtbl.replace utf82macro "\226\136\163" "divides" +let _ = Hashtbl.replace utf82macro "\226\137\144" "doteq" +let _ = Hashtbl.replace utf82macro "\226\136\164" "ndivides" +let _ = Hashtbl.replace utf82macro "\226\137\145" "eDot" +let _ = Hashtbl.replace utf82macro "\226\137\146" "fallingdotseq" +let _ = Hashtbl.replace utf82macro "\226\136\165" "parallel" +let _ = Hashtbl.replace utf82macro "\226\138\128" "nprec" +let _ = Hashtbl.replace utf82macro "\226\136\166" "nparallel" +let _ = Hashtbl.replace utf82macro "\226\137\147" "risingdotseq" +let _ = Hashtbl.replace utf82macro "\226\138\129" "nsucc" +let _ = Hashtbl.replace utf82macro "\226\137\148" "coloneq" +let _ = Hashtbl.replace utf82macro "\226\136\167" "land" +let _ = Hashtbl.replace utf82macro "\226\138\130" "subset" +let _ = Hashtbl.replace utf82macro "\226\136\168" "lor" +let _ = Hashtbl.replace utf82macro "\226\137\149" "eqcolon" +let _ = Hashtbl.replace utf82macro "????;" "longleftarrow" +let _ = Hashtbl.replace utf82macro "\226\138\131" "supset" +let _ = Hashtbl.replace utf82macro "\226\137\150" "eqcirc" +let _ = Hashtbl.replace utf82macro "\226\136\169" "cap" +let _ = Hashtbl.replace utf82macro "\226\138\132" "vnsub" +let _ = Hashtbl.replace utf82macro "\226\135\189" "loarr" +let _ = Hashtbl.replace utf82macro "\226\136\170" "cup" +let _ = Hashtbl.replace utf82macro "\226\137\151" "cire" +let _ = Hashtbl.replace utf82macro "\226\135\190" "roarr" +let _ = Hashtbl.replace utf82macro "\226\138\133" "vnsup" +let _ = Hashtbl.replace utf82macro "\226\136\171" "int" +let _ = Hashtbl.replace utf82macro "\226\137\153" "wedgeq" +let _ = Hashtbl.replace utf82macro "\226\138\134" "subseteq" +let _ = Hashtbl.replace utf82macro "\226\136\172" "Int" +let _ = Hashtbl.replace utf82macro "\226\135\191" "hoarr" +let _ = Hashtbl.replace utf82macro "\226\137\154" "veeeq" +let _ = Hashtbl.replace utf82macro "\226\138\135" "supseteq" +let _ = Hashtbl.replace utf82macro "\226\136\173" "tint" +let _ = Hashtbl.replace utf82macro "\226\138\136" "nsubseteqq" +let _ = Hashtbl.replace utf82macro "\226\137\155" "easter" +let _ = Hashtbl.replace utf82macro "\226\136\174" "oint" +let _ = Hashtbl.replace utf82macro "\226\137\156" "trie" +let _ = Hashtbl.replace utf82macro "\226\138\137" "nsupseteqq" +let _ = Hashtbl.replace utf82macro "\226\136\175" "DoubleContourIntegral" +let _ = Hashtbl.replace utf82macro "\226\137\157" "def" +let _ = Hashtbl.replace utf82macro "\226\138\138" "subsetneqq" +let _ = Hashtbl.replace utf82macro "\226\136\176" "Cconint" +let _ = Hashtbl.replace utf82macro "\226\138\139" "supsetneqq" +let _ = Hashtbl.replace utf82macro "\226\136\177" "cwint" +let _ = Hashtbl.replace utf82macro "\226\137\159" "questeq" +let _ = Hashtbl.replace utf82macro "\226\136\178" "cwconint" +let _ = Hashtbl.replace utf82macro "\226\137\160" "neq" +let _ = Hashtbl.replace utf82macro "\226\138\141" "cupdot" +let _ = Hashtbl.replace utf82macro "\226\136\179" "CounterClockwiseContourIntegral" +let _ = Hashtbl.replace utf82macro "\226\136\180" "Therefore" +let _ = Hashtbl.replace utf82macro "\226\137\161" "equiv" +let _ = Hashtbl.replace utf82macro "\226\138\142" "uplus" +let _ = Hashtbl.replace utf82macro "\226\138\143" "SquareSubset" +let _ = Hashtbl.replace utf82macro "\226\137\162" "NotCongruent" +let _ = Hashtbl.replace utf82macro "\226\136\181" "Because" +let _ = Hashtbl.replace utf82macro "\226\138\144" "SquareSuperset" +let _ = Hashtbl.replace utf82macro "\226\136\182" "ratio" +let _ = Hashtbl.replace utf82macro "\226\138\145" "SquareSubsetEqual" +let _ = Hashtbl.replace utf82macro "\226\137\164" "leq" +let _ = Hashtbl.replace utf82macro "\226\136\183" "Proportion" +let _ = Hashtbl.replace utf82macro "\226\138\146" "sqsupseteq" +let _ = Hashtbl.replace utf82macro "\226\137\165" "geq" +let _ = Hashtbl.replace utf82macro "\226\136\184" "minusd" +let _ = Hashtbl.replace utf82macro "\226\138\147" "sqcap" +let _ = Hashtbl.replace utf82macro "\226\137\166" "LessFullEqual" +let _ = Hashtbl.replace utf82macro "\226\139\128" "bigwedge" +let _ = Hashtbl.replace utf82macro "\226\136\186" "mDDot" +let _ = Hashtbl.replace utf82macro "\226\137\167" "GreaterFullEqual" +let _ = Hashtbl.replace utf82macro "\226\139\129" "bigvee" +let _ = Hashtbl.replace utf82macro "\226\138\148" "sqcup" +let _ = Hashtbl.replace utf82macro "\226\137\168" "lneqq" +let _ = Hashtbl.replace utf82macro "\226\136\187" "homtht" +let _ = Hashtbl.replace utf82macro "\226\138\149" "oplus" +let _ = Hashtbl.replace utf82macro "\226\139\130" "bigcap" +let _ = Hashtbl.replace utf82macro "\226\136\188" "sim" +let _ = Hashtbl.replace utf82macro "\226\137\169" "gneqq" +let _ = Hashtbl.replace utf82macro "\226\138\150" "ominus" +let _ = Hashtbl.replace utf82macro "\226\139\131" "bigcup" +let _ = Hashtbl.replace utf82macro "\226\137\170" "ll" +let _ = Hashtbl.replace utf82macro "\226\139\132" "diamond" +let _ = Hashtbl.replace utf82macro "\226\138\151" "otimes" +let _ = Hashtbl.replace utf82macro "\226\136\189" "bsim" +let _ = Hashtbl.replace utf82macro "\226\139\133" "sdot" +let _ = Hashtbl.replace utf82macro "\226\138\152" "osol" +let _ = Hashtbl.replace utf82macro "\226\136\130\204\184" "npart" +let _ = Hashtbl.replace utf82macro "\226\136\190" "mstpos" +let _ = Hashtbl.replace utf82macro "\226\137\171" "gg" +let _ = Hashtbl.replace utf82macro "\226\139\134" "star" +let _ = Hashtbl.replace utf82macro "\226\138\153" "odot" +let _ = Hashtbl.replace utf82macro "\226\137\172" "twixt" +let _ = Hashtbl.replace utf82macro "\226\136\191" "acd" +let _ = Hashtbl.replace utf82macro "\226\137\173" "NotCupCap" +let _ = Hashtbl.replace utf82macro "\226\139\135" "divonx" +let _ = Hashtbl.replace utf82macro "\226\138\154" "ocir" +let _ = Hashtbl.replace utf82macro "\226\137\174" "nvlt" +let _ = Hashtbl.replace utf82macro "\226\138\155" "oast" +let _ = Hashtbl.replace utf82macro "\226\139\136" "bowtie" +let _ = Hashtbl.replace utf82macro "\226\137\175" "nvgt" +let _ = Hashtbl.replace utf82macro "\226\139\137" "ltimes" +let _ = Hashtbl.replace utf82macro "\226\139\138" "rtimes" +let _ = Hashtbl.replace utf82macro "\226\137\176" "nleq" +let _ = Hashtbl.replace utf82macro "\226\138\157" "odash" +let _ = Hashtbl.replace utf82macro "\226\137\177" "ngeq" +let _ = Hashtbl.replace utf82macro "\226\139\139" "lthree" +let _ = Hashtbl.replace utf82macro "\226\138\158" "plusb" +let _ = Hashtbl.replace utf82macro "\226\139\140" "rthree" +let _ = Hashtbl.replace utf82macro "\226\137\178" "lsim" +let _ = Hashtbl.replace utf82macro "\226\138\159" "minusb" +let _ = Hashtbl.replace utf82macro "\226\137\179" "gtrsim" +let _ = Hashtbl.replace utf82macro "\226\138\160" "timesb" +let _ = Hashtbl.replace utf82macro "\226\139\141" "bsime" +let _ = Hashtbl.replace utf82macro "\226\137\180" "NotLessTilde" +let _ = Hashtbl.replace utf82macro "\226\138\161" "sdotb" +let _ = Hashtbl.replace utf82macro "\226\139\142" "cuvee" +let _ = Hashtbl.replace utf82macro "\226\138\162" "vdash" +let _ = Hashtbl.replace utf82macro "\226\137\181" "NotGreaterTilde" +let _ = Hashtbl.replace utf82macro "\226\139\143" "cuwed" +let _ = Hashtbl.replace utf82macro "\226\139\144" "Subset" +let _ = Hashtbl.replace utf82macro "\226\137\182" "lg" +let _ = Hashtbl.replace utf82macro "\226\138\163" "dashv" +let _ = Hashtbl.replace utf82macro "\226\139\145" "Supset" +let _ = Hashtbl.replace utf82macro "\226\137\183" "gtrless" +let _ = Hashtbl.replace utf82macro "\226\138\164" "top" +let _ = Hashtbl.replace utf82macro "\226\137\184" "ntlg" +let _ = Hashtbl.replace utf82macro "\226\139\146" "Cap" +let _ = Hashtbl.replace utf82macro "\226\138\165" "perp" +let _ = Hashtbl.replace utf82macro "\226\137\185" "ntgl" +let _ = Hashtbl.replace utf82macro "\226\139\147" "Cup" +let _ = Hashtbl.replace utf82macro "\226\137\186" "prec" +let _ = Hashtbl.replace utf82macro "\226\138\167" "models" +let _ = Hashtbl.replace utf82macro "\226\139\148" "pitchfork" +let _ = Hashtbl.replace utf82macro "\226\137\187" "succ" +let _ = Hashtbl.replace utf82macro "\226\139\149" "epar" +let _ = Hashtbl.replace utf82macro "\226\138\168" "vDash" +let _ = Hashtbl.replace utf82macro "\226\138\169" "Vdash" +let _ = Hashtbl.replace utf82macro "\226\137\188" "PrecedesSlantEqual" +let _ = Hashtbl.replace utf82macro "\226\139\150" "ltdot" +let _ = Hashtbl.replace utf82macro "\226\138\170" "Vvdash" +let _ = Hashtbl.replace utf82macro "\226\137\189" "succeq" +let _ = Hashtbl.replace utf82macro "\226\139\151" "gtrdot" +let _ = Hashtbl.replace utf82macro "\226\138\171" "VDash" +let _ = Hashtbl.replace utf82macro "\226\137\190" "scE" +let _ = Hashtbl.replace utf82macro "\226\139\152" "Ll" +let _ = Hashtbl.replace utf82macro "\226\137\191" "succsim" +let _ = Hashtbl.replace utf82macro "\226\138\172" "nvdash" +let _ = Hashtbl.replace utf82macro "\226\139\153" "ggg" +let _ = Hashtbl.replace utf82macro "\226\140\134" "doublebarwedge" +let _ = Hashtbl.replace utf82macro "\226\138\173" "nvDash" +let _ = Hashtbl.replace utf82macro "\226\139\154" "LessEqualGreater" +let _ = Hashtbl.replace utf82macro "\226\138\174" "nVdash" +let _ = Hashtbl.replace utf82macro "\226\140\136" "lceil" +let _ = Hashtbl.replace utf82macro "\226\139\155" "gtreqqless" +let _ = Hashtbl.replace utf82macro "\226\140\137" "rceil" +let _ = Hashtbl.replace utf82macro "\226\138\175" "nVDash" +let _ = Hashtbl.replace utf82macro "\226\139\156" "eqslantless" +let _ = Hashtbl.replace utf82macro "\226\138\176" "prurel" +let _ = Hashtbl.replace utf82macro "\226\140\138" "lfloor" +let _ = Hashtbl.replace utf82macro "\226\139\157" "eqslantgtr" +let _ = Hashtbl.replace utf82macro "\226\140\139" "rfloor" +let _ = Hashtbl.replace utf82macro "\226\139\158" "curlyeqprec" +let _ = Hashtbl.replace utf82macro "\226\138\178" "vltri" +let _ = Hashtbl.replace utf82macro "\226\140\140" "drcrop" +let _ = Hashtbl.replace utf82macro "\226\139\159" "curlyeqsucc" +let _ = Hashtbl.replace utf82macro "\226\138\179" "vrtri" +let _ = Hashtbl.replace utf82macro "\226\139\160" "nprcue" +let _ = Hashtbl.replace utf82macro "\226\140\141" "dlcrop" +let _ = Hashtbl.replace utf82macro "\226\140\142" "urcrop" +let _ = Hashtbl.replace utf82macro "\226\139\161" "nsccue" +let _ = Hashtbl.replace utf82macro "\226\138\180" "trianglelefteq" +let _ = Hashtbl.replace utf82macro "\226\140\143" "ulcrop" +let _ = Hashtbl.replace utf82macro "\226\138\181" "trianglerighteq" +let _ = Hashtbl.replace utf82macro "\226\134\157\204\184" "nrarrw" +let _ = Hashtbl.replace utf82macro "\226\139\162" "nsqsube" +let _ = Hashtbl.replace utf82macro "\226\138\182" "origof" +let _ = Hashtbl.replace utf82macro "\226\139\163" "nsqsupe" +let _ = Hashtbl.replace utf82macro "\226\140\144" "bnot" +let _ = Hashtbl.replace utf82macro "\226\138\183" "imof" +let _ = Hashtbl.replace utf82macro "\226\140\146" "profline" +let _ = Hashtbl.replace utf82macro "\226\138\184" "mumap" +let _ = Hashtbl.replace utf82macro "\226\140\147" "profsurf" +let _ = Hashtbl.replace utf82macro "\226\139\166" "lnsim" +let _ = Hashtbl.replace utf82macro "\226\138\185" "hercon" +let _ = Hashtbl.replace utf82macro "\226\138\186" "intercal" +let _ = Hashtbl.replace utf82macro "\226\139\167" "gnsim" +let _ = Hashtbl.replace utf82macro "\226\138\187" "veebar" +let _ = Hashtbl.replace utf82macro "\226\140\149" "telrec" +let _ = Hashtbl.replace utf82macro "\226\139\168" "prnsim" +let _ = Hashtbl.replace utf82macro "\226\140\150" "target" +let _ = Hashtbl.replace utf82macro "\226\139\169" "succnsim" +let _ = Hashtbl.replace utf82macro "\226\138\188" "barwedge" +let _ = Hashtbl.replace utf82macro "\226\139\170" "ntriangleleft" +let _ = Hashtbl.replace utf82macro "\226\138\189" "barvee" +let _ = Hashtbl.replace utf82macro "\226\138\190" "vangrt" +let _ = Hashtbl.replace utf82macro "\226\139\171" "ntriangleright" +let _ = Hashtbl.replace utf82macro "\226\139\172" "ntrianglelefteq" +let _ = Hashtbl.replace utf82macro "\226\138\191" "lrtri" +let _ = Hashtbl.replace utf82macro "\226\139\173" "ntrianglerighteq" +let _ = Hashtbl.replace utf82macro "\226\139\174" "vdots" +let _ = Hashtbl.replace utf82macro "\226\140\156" "ulcorner" +let _ = Hashtbl.replace utf82macro "\226\139\175" "cdots" +let _ = Hashtbl.replace utf82macro "\226\139\176" "utdot" +let _ = Hashtbl.replace utf82macro "\226\140\157" "urcorner" +let _ = Hashtbl.replace utf82macro "\226\139\177" "ddots" +let _ = Hashtbl.replace utf82macro "\226\140\158" "llcorner" +let _ = Hashtbl.replace utf82macro "\226\140\159" "lrcorner" +let _ = Hashtbl.replace utf82macro "\226\139\178" "disin" +let _ = Hashtbl.replace utf82macro "\226\139\179" "isinsv" +let _ = Hashtbl.replace utf82macro "\226\139\180" "isins" +let _ = Hashtbl.replace utf82macro "\226\139\181" "isindot" +let _ = Hashtbl.replace utf82macro "\226\140\162" "frown" +let _ = Hashtbl.replace utf82macro "\226\140\163" "smile" +let _ = Hashtbl.replace utf82macro "\226\139\182" "notinvc" +let _ = Hashtbl.replace utf82macro "\226\139\183" "notinvb" +let _ = Hashtbl.replace utf82macro "\226\139\185" "isinE" +let _ = Hashtbl.replace utf82macro "\226\139\186" "nisd" +let _ = Hashtbl.replace utf82macro "\226\139\187" "xnis" +let _ = Hashtbl.replace utf82macro "\226\139\188" "nis" +let _ = Hashtbl.replace utf82macro "\226\140\169" "langle" +let _ = Hashtbl.replace utf82macro "\226\140\170" "rangle" +let _ = Hashtbl.replace utf82macro "\226\139\189" "notnivc" +let _ = Hashtbl.replace utf82macro "\226\139\190" "notnivb" +let _ = Hashtbl.replace utf82macro "\226\140\173" "cylcty" +let _ = Hashtbl.replace utf82macro "\226\140\174" "profalar" +let _ = Hashtbl.replace utf82macro "\226\166\157\239\184\128" "angrtvb" +let _ = Hashtbl.replace utf82macro "\226\140\182" "topbot" +let _ = Hashtbl.replace utf82macro "\226\140\189" "ovbar" +let _ = Hashtbl.replace utf82macro "\226\140\191" "solbar" +let _ = Hashtbl.replace utf82macro "\226\141\188" "angzarr" +let _ = Hashtbl.replace utf82macro "\226\139\173\204\184" "nvrtrie" +let _ = Hashtbl.replace utf82macro "\226\142\176" "lmoustache" +let _ = Hashtbl.replace utf82macro "\226\142\177" "rmoustache" +let _ = Hashtbl.replace utf82macro "\226\142\180" "tbrk" +let _ = Hashtbl.replace utf82macro "\226\142\181" "UnderBracket" +let _ = Hashtbl.replace utf82macro "\226\137\139\204\184" "napid" +let _ = Hashtbl.replace utf82macro "\226\144\163" "blank" +let _ = Hashtbl.replace utf82macro "\226\138\131/" "suphsol" +let _ = Hashtbl.replace utf82macro "\226\146\162\204\184" "NotNestedGreaterGreater" +let _ = Hashtbl.replace utf82macro "\226\147\136" "oS" +let _ = Hashtbl.replace utf82macro "\227\128\138" "Lang" +let _ = Hashtbl.replace utf82macro "\227\128\139" "Rang" +let _ = Hashtbl.replace utf82macro "\226\148\128" "HorizontalLine" +let _ = Hashtbl.replace utf82macro "\226\136\166\239\184\128" "nspar" +let _ = Hashtbl.replace utf82macro "\227\128\148" "lbbrk" +let _ = Hashtbl.replace utf82macro "\227\128\149" "rbbrk" +let _ = Hashtbl.replace utf82macro "\226\148\130" "boxv" +let _ = Hashtbl.replace utf82macro "\227\128\152" "lopar" +let _ = Hashtbl.replace utf82macro "\227\128\153" "ropar" +let _ = Hashtbl.replace utf82macro "\227\128\154" "lobrk" +let _ = Hashtbl.replace utf82macro "\227\128\155" "robrk" +let _ = Hashtbl.replace utf82macro "\226\148\140" "boxdr" +let _ = Hashtbl.replace utf82macro "\226\148\144" "boxdl" +let _ = Hashtbl.replace utf82macro "\226\148\148" "boxur" +let _ = Hashtbl.replace utf82macro "\226\148\152" "boxul" +let _ = Hashtbl.replace utf82macro "\226\148\156" "boxvr" +let _ = Hashtbl.replace utf82macro "\226\149\144" "boxH" +let _ = Hashtbl.replace utf82macro "\226\148\164" "boxvl" +let _ = Hashtbl.replace utf82macro "\226\149\145" "boxV" +let _ = Hashtbl.replace utf82macro "\226\149\146" "boxdR" +let _ = Hashtbl.replace utf82macro "\226\150\128" "uhblk" +let _ = Hashtbl.replace utf82macro "\226\149\147" "boxDr" +let _ = Hashtbl.replace utf82macro "\226\149\148" "boxDR" +let _ = Hashtbl.replace utf82macro "\226\137\168\239\184\128" "lvnE" +let _ = Hashtbl.replace utf82macro "\226\149\149" "boxdL" +let _ = Hashtbl.replace utf82macro "\226\149\150" "boxDl" +let _ = Hashtbl.replace utf82macro "\226\150\132" "lhblk" +let _ = Hashtbl.replace utf82macro "\226\149\151" "boxDL" +let _ = Hashtbl.replace utf82macro "\226\149\152" "boxuR" +let _ = Hashtbl.replace utf82macro "\226\149\153" "boxUr" +let _ = Hashtbl.replace utf82macro "\226\148\172" "boxhd" +let _ = Hashtbl.replace utf82macro "\226\149\154" "boxUR" +let _ = Hashtbl.replace utf82macro "\226\149\155" "boxuL" +let _ = Hashtbl.replace utf82macro "\226\150\136" "block" +let _ = Hashtbl.replace utf82macro "\226\149\156" "boxUl" +let _ = Hashtbl.replace utf82macro "\226\149\157" "boxUL" +let _ = Hashtbl.replace utf82macro "\226\149\158" "boxvR" +let _ = Hashtbl.replace utf82macro "\226\149\159" "boxVr" +let _ = Hashtbl.replace utf82macro "\226\149\160" "boxVR" +let _ = Hashtbl.replace utf82macro "\226\149\161" "boxvL" +let _ = Hashtbl.replace utf82macro "\226\148\180" "boxhu" +let _ = Hashtbl.replace utf82macro "\226\149\162" "boxVl" +let _ = Hashtbl.replace utf82macro "\226\149\163" "boxVL" +let _ = Hashtbl.replace utf82macro "\226\149\164" "boxHd" +let _ = Hashtbl.replace utf82macro "\226\150\145" "blk14" +let _ = Hashtbl.replace utf82macro "\226\149\165" "boxhD" +let _ = Hashtbl.replace utf82macro "\226\150\146" "blk12" +let _ = Hashtbl.replace utf82macro "\226\149\166" "boxHD" +let _ = Hashtbl.replace utf82macro "\226\150\147" "blk34" +let _ = Hashtbl.replace utf82macro "\226\149\167" "boxHu" +let _ = Hashtbl.replace utf82macro "\226\149\168" "boxhU" +let _ = Hashtbl.replace utf82macro "\226\151\130" "ltrif" +let _ = Hashtbl.replace utf82macro "\226\151\131" "triangleleft" +let _ = Hashtbl.replace utf82macro "\226\148\188" "boxvh" +let _ = Hashtbl.replace utf82macro "\226\149\169" "boxHU" +let _ = Hashtbl.replace utf82macro "\226\149\170" "boxvH" +let _ = Hashtbl.replace utf82macro "\226\149\171" "boxVh" +let _ = Hashtbl.replace utf82macro "\226\149\172" "boxVH" +let _ = Hashtbl.replace utf82macro "\226\151\138" "lozenge" +let _ = Hashtbl.replace utf82macro "\226\151\139" "cir" +let _ = Hashtbl.replace utf82macro "\226\170\172\239\184\128" "smtes" +let _ = Hashtbl.replace utf82macro "\226\150\161" "Square" +let _ = Hashtbl.replace utf82macro "\226\140\132\239\184\128" "ShortDownArrow" +let _ = Hashtbl.replace utf82macro "\226\150\170" "squf" +let _ = Hashtbl.replace utf82macro "\226\152\133" "starf" +let _ = Hashtbl.replace utf82macro "\226\150\173" "rect" +let _ = Hashtbl.replace utf82macro "\226\150\174" "marker" +let _ = Hashtbl.replace utf82macro "\226\150\179" "bigtriangleup" +let _ = Hashtbl.replace utf82macro "\226\152\142" "phone" +let _ = Hashtbl.replace utf82macro "\226\150\180" "utrif" +let _ = Hashtbl.replace utf82macro "\226\150\181" "triangle" +let _ = Hashtbl.replace utf82macro "\226\150\184" "rtrif" +let _ = Hashtbl.replace utf82macro "\226\150\185" "triangleright" +let _ = Hashtbl.replace utf82macro "\226\153\128" "female" +let _ = Hashtbl.replace utf82macro "\226\153\130" "male" +let _ = Hashtbl.replace utf82macro "\226\150\189" "bigtriangledown" +let _ = Hashtbl.replace utf82macro "\226\150\190" "dtrif" +let _ = Hashtbl.replace utf82macro "\226\151\172" "tridot" +let _ = Hashtbl.replace utf82macro "\226\128\137\226\128\138\226\128\138" "ThickSpace" +let _ = Hashtbl.replace utf82macro "\226\150\191" "triangledown" +let _ = Hashtbl.replace utf82macro "\226\151\175" "bigcirc" +let _ = Hashtbl.replace utf82macro "\226\137\177\226\131\165" "NotGreaterEqual" +let _ = Hashtbl.replace utf82macro "\226\151\184" "ultri" +let _ = Hashtbl.replace utf82macro "=\226\131\165" "bne" +let _ = Hashtbl.replace utf82macro "\226\151\185" "urtri" +let _ = Hashtbl.replace utf82macro "\226\151\186" "lltri" +let _ = Hashtbl.replace utf82macro "\226\151\189" "EmptySmallSquare" +let _ = Hashtbl.replace utf82macro "\226\151\190" "FilledSmallSquare" +let _ = Hashtbl.replace utf82macro "\226\153\160" "spadesuit" +let _ = Hashtbl.replace utf82macro "\226\153\161" "heartsuit" +let _ = Hashtbl.replace utf82macro "\226\153\162" "diamondsuit" +let _ = Hashtbl.replace utf82macro "\226\153\163" "clubsuit" +let _ = Hashtbl.replace utf82macro "\226\153\166" "diams" +let _ = Hashtbl.replace utf82macro "ker" "ker" +let _ = Hashtbl.replace utf82macro "\226\153\170" "sung" +let _ = Hashtbl.replace utf82macro "\226\153\173" "flat" +let _ = Hashtbl.replace utf82macro "\226\153\174" "natural" +let _ = Hashtbl.replace utf82macro "\226\153\175" "sharp" +let _ = Hashtbl.replace utf82macro "\226\156\147" "checkmark" +let _ = Hashtbl.replace utf82macro "\226\156\151" "cross" +let _ = Hashtbl.replace utf82macro "\226\134\146\239\184\128" "srarr" +let _ = Hashtbl.replace utf82macro "\226\156\160" "maltese" +let _ = Hashtbl.replace utf82macro "\226\157\152" "VerticalSeparator" +let _ = Hashtbl.replace utf82macro "\226\156\182" "sext" +let _ = Hashtbl.replace utf82macro "\226\138\143\204\184" "NotSquareSubset" +let _ = Hashtbl.replace utf82macro "\226\136\150\239\184\128" "ssetmn" +let _ = Hashtbl.replace utf82macro "\226\136\164\239\184\128" "nsmid" +let _ = Hashtbl.replace utf82macro "\226\164\133" "Map" +let _ = Hashtbl.replace utf82macro "\226\164\140" "lbarr" +let _ = Hashtbl.replace utf82macro "\226\164\141" "rbarr" +let _ = Hashtbl.replace utf82macro "\226\164\142" "lBarr" +let _ = Hashtbl.replace utf82macro "\226\164\143" "rBarr" +let _ = Hashtbl.replace utf82macro "\226\164\144" "RBarr" +let _ = Hashtbl.replace utf82macro "\226\164\145" "DDotrahd" +let _ = Hashtbl.replace utf82macro "\226\164\146" "UpArrowBar" +let _ = Hashtbl.replace utf82macro "\226\138\147\239\184\128" "sqcaps" +let _ = Hashtbl.replace utf82macro "\226\164\147" "DownArrowBar" +let _ = Hashtbl.replace utf82macro "\226\164\150" "Rarrtl" +let _ = Hashtbl.replace utf82macro "exp" "exp" +let _ = Hashtbl.replace utf82macro "\226\165\133" "rarrpl" +let _ = Hashtbl.replace utf82macro "tanh" "tanh" +let _ = Hashtbl.replace utf82macro "\226\164\153" "latail" +let _ = Hashtbl.replace utf82macro "\226\164\155" "lAtail" +let _ = Hashtbl.replace utf82macro "\226\165\136" "harrcir" +let _ = Hashtbl.replace utf82macro "arcsin" "arcsin" +let _ = Hashtbl.replace utf82macro "\226\165\137" "Uarrocir" +let _ = Hashtbl.replace utf82macro "\226\164\156" "rAtail" +let _ = Hashtbl.replace utf82macro "\226\137\129\204\184" "nvsim" +let _ = Hashtbl.replace utf82macro "\226\165\138" "lurdshar" +let _ = Hashtbl.replace utf82macro "\226\164\157" "larrfs" +let _ = Hashtbl.replace utf82macro "\226\164\158" "rarrfs" +let _ = Hashtbl.replace utf82macro "\226\165\139" "ldrushar" +let _ = Hashtbl.replace utf82macro "\226\164\159" "larrbfs" +let _ = Hashtbl.replace utf82macro "\226\164\160" "rarrbfs" +let _ = Hashtbl.replace utf82macro "\226\165\142" "LeftRightVector" +let _ = Hashtbl.replace utf82macro "\226\165\143" "RightUpDownVector" +let _ = Hashtbl.replace utf82macro "\226\164\163" "nwarhk" +let _ = Hashtbl.replace utf82macro "\226\165\144" "DownLeftRightVector" +let _ = Hashtbl.replace utf82macro "\226\164\164" "nearhk" +let _ = Hashtbl.replace utf82macro "\226\165\145" "LeftUpDownVector" +let _ = Hashtbl.replace utf82macro "\226\165\146" "LeftVectorBar" +let _ = Hashtbl.replace utf82macro "\226\164\165" "searhk" +let _ = Hashtbl.replace utf82macro "\226\165\147" "RightVectorBar" +let _ = Hashtbl.replace utf82macro "\226\164\166" "swarhk" +let _ = Hashtbl.replace utf82macro "\226\165\148" "RightUpVectorBar" +let _ = Hashtbl.replace utf82macro "\226\164\167" "nwnear" +let _ = Hashtbl.replace utf82macro "\226\165\149" "RightDownVectorBar" +let _ = Hashtbl.replace utf82macro "\226\164\168" "toea" +let _ = Hashtbl.replace utf82macro "\226\164\169" "tosa" +let _ = Hashtbl.replace utf82macro "\226\165\150" "DownLeftVectorBar" +let _ = Hashtbl.replace utf82macro "\226\164\170" "swnwar" +let _ = Hashtbl.replace utf82macro "\226\165\151" "DownRightVectorBar" +let _ = Hashtbl.replace utf82macro "\226\165\152" "LeftUpVectorBar" +let _ = Hashtbl.replace utf82macro "\226\165\153" "LeftDownVectorBar" +let _ = Hashtbl.replace utf82macro "\226\165\154" "LeftTeeVector" +let _ = Hashtbl.replace utf82macro "\226\165\155" "RightTeeVector" +let _ = Hashtbl.replace utf82macro "\226\165\156" "RightUpTeeVector" +let _ = Hashtbl.replace utf82macro "\226\165\157" "RightDownTeeVector" +let _ = Hashtbl.replace utf82macro "\226\139\152\204\184" "nLl" +let _ = Hashtbl.replace utf82macro "\226\166\139" "lbrke" +let _ = Hashtbl.replace utf82macro "\226\165\158" "DownLeftTeeVector" +let _ = Hashtbl.replace utf82macro "\226\166\140" "rbrke" +let _ = Hashtbl.replace utf82macro "\226\165\159" "DownRightTeeVector" +let _ = Hashtbl.replace utf82macro "\226\164\179" "rarrc" +let _ = Hashtbl.replace utf82macro "\226\165\160" "LeftUpTeeVector" +let _ = Hashtbl.replace utf82macro "\226\166\141" "lbrkslu" +let _ = Hashtbl.replace utf82macro "\226\166\142" "rbrksld" +let _ = Hashtbl.replace utf82macro "\226\165\161" "LeftDownTeeVector" +let _ = Hashtbl.replace utf82macro "\226\165\162" "lHar" +let _ = Hashtbl.replace utf82macro "\226\166\143" "lbrksld" +let _ = Hashtbl.replace utf82macro "\226\164\181" "cudarrr" +let _ = Hashtbl.replace utf82macro "sinh" "sinh" +let _ = Hashtbl.replace utf82macro "\226\165\163" "uHar" +let _ = Hashtbl.replace utf82macro "\226\166\144" "rbrkslu" +let _ = Hashtbl.replace utf82macro "\226\164\182" "ldca" +let _ = Hashtbl.replace utf82macro "\226\165\164" "rHar" +let _ = Hashtbl.replace utf82macro "\226\164\183" "rdca" +let _ = Hashtbl.replace utf82macro "\226\166\145" "langd" +let _ = Hashtbl.replace utf82macro "\226\166\146" "rangd" +let _ = Hashtbl.replace utf82macro "\226\165\165" "dHar" +let _ = Hashtbl.replace utf82macro "\226\164\184" "cudarrl" +let _ = Hashtbl.replace utf82macro "\226\167\128" "olt" +let _ = Hashtbl.replace utf82macro "\226\136\137\204\184" "notinva" +let _ = Hashtbl.replace utf82macro "\226\165\166" "luruhar" +let _ = Hashtbl.replace utf82macro "\226\166\147" "lparlt" +let _ = Hashtbl.replace utf82macro "\226\164\185" "larrpl" +let _ = Hashtbl.replace utf82macro "\226\166\148" "rpargt" +let _ = Hashtbl.replace utf82macro "\226\167\129" "ogt" +let _ = Hashtbl.replace utf82macro "\226\165\167" "ldrdhar" +let _ = Hashtbl.replace utf82macro "\226\165\168" "ruluhar" +let _ = Hashtbl.replace utf82macro "\226\166\149" "gtlPar" +let _ = Hashtbl.replace utf82macro "\226\167\130" "cirscir" +let _ = Hashtbl.replace utf82macro "\226\165\169" "rdldhar" +let _ = Hashtbl.replace utf82macro "\226\166\150" "ltrPar" +let _ = Hashtbl.replace utf82macro "\226\164\188" "curarrm" +let _ = Hashtbl.replace utf82macro "\226\167\131" "cirE" +let _ = Hashtbl.replace utf82macro "\226\137\161\226\131\165" "bnequiv" +let _ = Hashtbl.replace utf82macro "\226\167\132" "solb" +let _ = Hashtbl.replace utf82macro "\226\165\170" "lharul" +let _ = Hashtbl.replace utf82macro "\226\164\189" "cularrp" +let _ = Hashtbl.replace utf82macro "\226\165\171" "llhard" +let _ = Hashtbl.replace utf82macro "\226\167\133" "bsolb" +let _ = Hashtbl.replace utf82macro "\226\165\172" "rharul" +let _ = Hashtbl.replace utf82macro "\226\166\154" "vzigzag" +let _ = Hashtbl.replace utf82macro "\226\165\173" "lrhard" +let _ = Hashtbl.replace utf82macro "\226\165\174" "UpEquilibrium" +let _ = Hashtbl.replace utf82macro "\226\165\175" "ReverseUpEquilibrium" +let _ = Hashtbl.replace utf82macro "\226\167\137" "boxbox" +let _ = Hashtbl.replace utf82macro "\226\165\176" "RoundImplies" +let _ = Hashtbl.replace utf82macro "\226\166\157" "angrtvbd" +let _ = Hashtbl.replace utf82macro "\226\165\177" "erarr" +let _ = Hashtbl.replace utf82macro "\226\165\178" "simrarr" +let _ = Hashtbl.replace utf82macro "\226\167\141" "trisb" +let _ = Hashtbl.replace utf82macro "\226\165\179" "larrsim" +let _ = Hashtbl.replace utf82macro "\226\167\142" "rtriltri" +let _ = Hashtbl.replace utf82macro "\226\165\180" "rarrsim" +let _ = Hashtbl.replace utf82macro "\226\165\181" "rarrap" +let _ = Hashtbl.replace utf82macro "\226\167\143" "LeftTriangleBar" +let _ = Hashtbl.replace utf82macro "\226\167\144" "RightTriangleBar" +let _ = Hashtbl.replace utf82macro "\226\165\182" "ltlarr" +let _ = Hashtbl.replace utf82macro "\226\166\164" "ange" +let _ = Hashtbl.replace utf82macro "\226\166\165" "range" +let _ = Hashtbl.replace utf82macro "\226\165\184" "gtrarr" +let _ = Hashtbl.replace utf82macro "\226\165\185" "subrarr" +let _ = Hashtbl.replace utf82macro "\226\166\166" "dwangle" +let _ = Hashtbl.replace utf82macro "\226\166\167" "uwangle" +let _ = Hashtbl.replace utf82macro "\226\165\187" "suplarr" +let _ = Hashtbl.replace utf82macro "\226\166\168" "angmsdaa" +let _ = Hashtbl.replace utf82macro "\226\165\188" "lfisht" +let _ = Hashtbl.replace utf82macro "\226\166\169" "angmsdab" +let _ = Hashtbl.replace utf82macro "\226\165\189" "rfisht" +let _ = Hashtbl.replace utf82macro "\226\166\170" "angmsdac" +let _ = Hashtbl.replace utf82macro "\226\165\190" "ufisht" +let _ = Hashtbl.replace utf82macro "\226\166\171" "angmsdad" +let _ = Hashtbl.replace utf82macro "\226\165\191" "dfisht" +let _ = Hashtbl.replace utf82macro "\226\166\172" "angmsdae" +let _ = Hashtbl.replace utf82macro "\226\167\154" "race" +let _ = Hashtbl.replace utf82macro "\226\166\173" "angmsdaf" +let _ = Hashtbl.replace utf82macro "\226\166\174" "angmsdag" +let _ = Hashtbl.replace utf82macro "\226\167\155" "acE" +let _ = Hashtbl.replace utf82macro "\226\167\156" "iinfin" +let _ = Hashtbl.replace utf82macro "\226\166\175" "angmsdah" +let _ = Hashtbl.replace utf82macro "\226\166\176" "bemptyv" +let _ = Hashtbl.replace utf82macro "\226\167\158" "nvinfin" +let _ = Hashtbl.replace utf82macro "\226\166\177" "demptyv" +let _ = Hashtbl.replace utf82macro "\226\168\140" "qint" +let _ = Hashtbl.replace utf82macro "\226\166\178" "cemptyv" +let _ = Hashtbl.replace utf82macro "\226\166\179" "raemptyv" +let _ = Hashtbl.replace utf82macro "\226\168\141" "fpartint" +let _ = Hashtbl.replace utf82macro "\226\166\180" "laemptyv" +let _ = Hashtbl.replace utf82macro "\226\166\181" "ohbar" +let _ = Hashtbl.replace utf82macro "\226\166\182" "omid" +let _ = Hashtbl.replace utf82macro "\226\167\163" "eparsl" +let _ = Hashtbl.replace utf82macro "\226\168\144" "cirfnint" +let _ = Hashtbl.replace utf82macro "\226\167\164" "smeparsl" +let _ = Hashtbl.replace utf82macro "\226\166\183" "opar" +let _ = Hashtbl.replace utf82macro "\226\168\145" "awint" +let _ = Hashtbl.replace utf82macro "\226\168\146" "rppolint" +let _ = Hashtbl.replace utf82macro "\226\167\165" "eqvparsl" +let _ = Hashtbl.replace utf82macro "\226\168\147" "scpolint" +let _ = Hashtbl.replace utf82macro "\226\166\185" "operp" +let _ = Hashtbl.replace utf82macro "\226\169\128" "capdot" +let _ = Hashtbl.replace utf82macro "\226\168\148" "npolint" +let _ = Hashtbl.replace utf82macro "\226\168\149" "pointint" +let _ = Hashtbl.replace utf82macro "\226\166\187" "olcross" +let _ = Hashtbl.replace utf82macro "\226\169\130" "ncup" +let _ = Hashtbl.replace utf82macro "\226\168\150" "quatint" +let _ = Hashtbl.replace utf82macro "\226\166\188" "odsold" +let _ = Hashtbl.replace utf82macro "\226\169\131" "ncap" +let _ = Hashtbl.replace utf82macro "\226\168\151" "intlarhk" +let _ = Hashtbl.replace utf82macro "\226\169\132" "capand" +let _ = Hashtbl.replace utf82macro "\226\166\190" "olcir" +let _ = Hashtbl.replace utf82macro "\226\169\133" "cupor" +let _ = Hashtbl.replace utf82macro "\226\167\171" "lozf" +let _ = Hashtbl.replace utf82macro "\226\166\191" "ofcir" +let _ = Hashtbl.replace utf82macro "\226\169\134" "cupcap" +let _ = Hashtbl.replace utf82macro "\226\169\135" "capcup" +let _ = Hashtbl.replace utf82macro "\226\169\136" "cupbrcap" +let _ = Hashtbl.replace utf82macro "\226\169\137" "capbrcup" +let _ = Hashtbl.replace utf82macro "\226\169\138" "cupcup" +let _ = Hashtbl.replace utf82macro "\226\169\139" "capcap" +let _ = Hashtbl.replace utf82macro "\226\169\140" "ccups" +let _ = Hashtbl.replace utf82macro "\226\169\141" "ccaps" +let _ = Hashtbl.replace utf82macro "\226\167\180" "RuleDelayed" +let _ = Hashtbl.replace utf82macro "\226\168\162" "pluscir" +let _ = Hashtbl.replace utf82macro "\226\168\163" "plusacir" +let _ = Hashtbl.replace utf82macro "\226\167\182" "dsol" +let _ = Hashtbl.replace utf82macro "\226\169\144" "ccupssm" +let _ = Hashtbl.replace utf82macro "\226\168\164" "simplus" +let _ = Hashtbl.replace utf82macro "\226\168\165" "plusdu" +let _ = Hashtbl.replace utf82macro "\226\168\166" "plussim" +let _ = Hashtbl.replace utf82macro "\226\170\128" "gesdot" +let _ = Hashtbl.replace utf82macro "\226\169\147" "And" +let _ = Hashtbl.replace utf82macro "\226\168\167" "plustwo" +let _ = Hashtbl.replace utf82macro "\226\169\148" "Or" +let _ = Hashtbl.replace utf82macro "\226\170\129" "lesdoto" +let _ = Hashtbl.replace utf82macro "\226\170\130" "gesdoto" +let _ = Hashtbl.replace utf82macro "\226\169\149" "andand" +let _ = Hashtbl.replace utf82macro "\226\169\150" "oror" +let _ = Hashtbl.replace utf82macro "\226\168\169" "mcomma" +let _ = Hashtbl.replace utf82macro "\226\170\131" "lesdotor" +let _ = Hashtbl.replace utf82macro "\226\169\151" "orslope" +let _ = Hashtbl.replace utf82macro "\226\168\170" "minusdu" +let _ = Hashtbl.replace utf82macro "\226\170\132" "gesdotol" +let _ = Hashtbl.replace utf82macro "\226\169\152" "andslope" +let _ = Hashtbl.replace utf82macro "\226\168\173" "loplus" +let _ = Hashtbl.replace utf82macro "\226\169\154" "andv" +let _ = Hashtbl.replace utf82macro "\226\168\174" "roplus" +let _ = Hashtbl.replace utf82macro "\226\169\155" "orv" +let _ = Hashtbl.replace utf82macro "\226\170\137" "lnapprox" +let _ = Hashtbl.replace utf82macro "\226\168\175" "Cross" +let _ = Hashtbl.replace utf82macro "\226\169\156" "andd" +let _ = Hashtbl.replace utf82macro "\226\168\176" "timesd" +let _ = Hashtbl.replace utf82macro "\226\169\157" "ord" +let _ = Hashtbl.replace utf82macro "\226\170\138" "gnapprox" +let _ = Hashtbl.replace utf82macro "\226\168\177" "timesbar" +let _ = Hashtbl.replace utf82macro "\226\169\159" "wedbar" +let _ = Hashtbl.replace utf82macro "\226\168\179" "smashp" +let _ = Hashtbl.replace utf82macro "\226\170\141" "lsime" +let _ = Hashtbl.replace utf82macro "j\239\184\128" "jmath" +let _ = Hashtbl.replace utf82macro "\226\168\180" "lotimes" +let _ = Hashtbl.replace utf82macro "\226\170\142" "gsime" +let _ = Hashtbl.replace utf82macro "\226\168\181" "rotimes" +let _ = Hashtbl.replace utf82macro "\226\170\143" "lsimg" +let _ = Hashtbl.replace utf82macro "\226\168\182" "otimesas" +let _ = Hashtbl.replace utf82macro "\226\170\144" "gsiml" +let _ = Hashtbl.replace utf82macro "\226\168\183" "Otimes" +let _ = Hashtbl.replace utf82macro "\226\170\145" "lgE" +let _ = Hashtbl.replace utf82macro "\226\168\184" "odiv" +let _ = Hashtbl.replace utf82macro "\226\170\146" "glE" +let _ = Hashtbl.replace utf82macro "\226\168\185" "triplus" +let _ = Hashtbl.replace utf82macro "\226\171\128" "supplus" +let _ = Hashtbl.replace utf82macro "\226\169\166" "sdote" +let _ = Hashtbl.replace utf82macro "\226\170\147" "lesges" +let _ = Hashtbl.replace utf82macro "\226\168\186" "triminus" +let _ = Hashtbl.replace utf82macro "\226\171\129" "submult" +let _ = Hashtbl.replace utf82macro "\226\170\148" "gesles" +let _ = Hashtbl.replace utf82macro "\226\168\187" "tritime" +let _ = Hashtbl.replace utf82macro "\226\171\130" "supmult" +let _ = Hashtbl.replace utf82macro "\226\171\131" "subedot" +let _ = Hashtbl.replace utf82macro "\226\168\188" "iprod" +let _ = Hashtbl.replace utf82macro "\226\171\132" "supedot" +let _ = Hashtbl.replace utf82macro "\226\169\170" "simdot" +let _ = Hashtbl.replace utf82macro "\226\170\151" "elsdot" +let _ = Hashtbl.replace utf82macro "\226\170\152" "egsdot" +let _ = Hashtbl.replace utf82macro "\226\170\153" "el" +let _ = Hashtbl.replace utf82macro "\226\168\191" "amalg" +let _ = Hashtbl.replace utf82macro "\226\171\135" "subsim" +let _ = Hashtbl.replace utf82macro "\226\170\154" "eg" +let _ = Hashtbl.replace utf82macro "\226\169\173" "congdot" +let _ = Hashtbl.replace utf82macro "\226\171\136" "supsim" +let _ = Hashtbl.replace utf82macro "\226\169\175" "apacir" +let _ = Hashtbl.replace utf82macro "\226\170\157" "siml" +let _ = Hashtbl.replace utf82macro "\226\170\158" "simg" +let _ = Hashtbl.replace utf82macro "\226\169\177" "eplus" +let _ = Hashtbl.replace utf82macro "\226\170\159" "simlE" +let _ = Hashtbl.replace utf82macro "\226\169\178" "pluse" +let _ = Hashtbl.replace utf82macro "\226\170\160" "simgE" +let _ = Hashtbl.replace utf82macro "\226\169\179" "Esim" +let _ = Hashtbl.replace utf82macro "\226\170\161" "LessLess" +let _ = Hashtbl.replace utf82macro "\226\169\180" "Colone" +let _ = Hashtbl.replace utf82macro "\226\170\162" "GreaterGreater" +let _ = Hashtbl.replace utf82macro "\226\169\181" "Equal" +let _ = Hashtbl.replace utf82macro "\226\171\143" "csub" +let _ = Hashtbl.replace utf82macro "\226\171\144" "csup" +let _ = Hashtbl.replace utf82macro "\226\170\164" "glj" +let _ = Hashtbl.replace utf82macro "\226\169\183" "eDDot" +let _ = Hashtbl.replace utf82macro "\226\171\145" "csube" +let _ = Hashtbl.replace utf82macro "\226\170\165" "gla" +let _ = Hashtbl.replace utf82macro "\226\169\184" "equivDD" +let _ = Hashtbl.replace utf82macro "\226\171\146" "csupe" +let _ = Hashtbl.replace utf82macro "\226\171\147" "subsup" +let _ = Hashtbl.replace utf82macro "\226\169\185" "ltcir" +let _ = Hashtbl.replace utf82macro "\226\170\166" "ltcc" +let _ = Hashtbl.replace utf82macro "\226\171\148" "supsub" +let _ = Hashtbl.replace utf82macro "\226\169\186" "gtcir" +let _ = Hashtbl.replace utf82macro "\226\170\167" "gtcc" +let _ = Hashtbl.replace utf82macro "\226\171\149" "subsub" +let _ = Hashtbl.replace utf82macro "\226\169\187" "ltquest" +let _ = Hashtbl.replace utf82macro "\226\170\168" "lescc" +let _ = Hashtbl.replace utf82macro "\226\171\150" "supsup" +let _ = Hashtbl.replace utf82macro "\226\169\188" "gtquest" +let _ = Hashtbl.replace utf82macro "\226\170\169" "gescc" +let _ = Hashtbl.replace utf82macro "\226\171\151" "suphsub" +let _ = Hashtbl.replace utf82macro "\226\170\170" "smt" +let _ = Hashtbl.replace utf82macro "\226\169\189" "LessSlantEqual" +let _ = Hashtbl.replace utf82macro "\226\171\152" "supdsub" +let _ = Hashtbl.replace utf82macro "\226\134\144\239\184\128" "slarr" +let _ = Hashtbl.replace utf82macro "\226\170\171" "lat" +let _ = Hashtbl.replace utf82macro "\226\169\190" "GreaterSlantEqual" +let _ = Hashtbl.replace utf82macro "\226\170\172" "smte" +let _ = Hashtbl.replace utf82macro "\226\169\191" "lesdot" +let _ = Hashtbl.replace utf82macro "\226\171\153" "forkv" +let _ = Hashtbl.replace utf82macro "\226\171\154" "topfork" +let _ = Hashtbl.replace utf82macro "\226\170\173" "late" +let _ = Hashtbl.replace utf82macro "\226\171\155" "mlcp" +let _ = Hashtbl.replace utf82macro "\226\170\174" "bumpE" +let _ = Hashtbl.replace utf82macro "\226\170\175" "preceq" +let _ = Hashtbl.replace utf82macro "\226\170\181" "prnE" +let _ = Hashtbl.replace utf82macro "\226\170\182" "succneqq" +let _ = Hashtbl.replace utf82macro "\226\171\164" "DoubleLeftTee" +let _ = Hashtbl.replace utf82macro "\226\171\166" "Vdashl" +let _ = Hashtbl.replace utf82macro "\226\171\167" "Barv" +let _ = Hashtbl.replace utf82macro "\226\171\168" "vBar" +let _ = Hashtbl.replace utf82macro "\226\170\187" "Pr" +let _ = Hashtbl.replace utf82macro "\226\171\169" "vBarv" +let _ = Hashtbl.replace utf82macro "\226\170\188" "Sc" +let _ = Hashtbl.replace utf82macro "\226\170\189" "subdot" +let _ = Hashtbl.replace utf82macro "\226\171\171" "Vbar" +let _ = Hashtbl.replace utf82macro "\226\170\190" "supdot" +let _ = Hashtbl.replace utf82macro "\226\170\191" "subplus" +let _ = Hashtbl.replace utf82macro "\226\171\172" "Not" +let _ = Hashtbl.replace utf82macro "\226\171\173" "bNot" +let _ = Hashtbl.replace utf82macro "\226\171\174" "rnmid" +let _ = Hashtbl.replace utf82macro "\226\171\175" "cirmid" +let _ = Hashtbl.replace utf82macro "\226\171\176" "midcir" +let _ = Hashtbl.replace utf82macro "\226\171\177" "topcir" +let _ = Hashtbl.replace utf82macro "\226\171\178" "nhpar" +let _ = Hashtbl.replace utf82macro "\226\171\179" "parsim" +let _ = Hashtbl.replace utf82macro "\226\128\137\239\184\128" "NegativeThinSpace" +let _ = Hashtbl.replace utf82macro "arctan" "arctan" +let _ = Hashtbl.replace utf82macro "\226\137\136\239\184\128" "thkap" +let _ = Hashtbl.replace utf82macro "lim" "lim" +let _ = Hashtbl.replace utf82macro "\226\136\169\239\184\128" "caps" +let _ = Hashtbl.replace utf82macro "\226\138\138\239\184\128" "vsubnE" +let _ = Hashtbl.replace utf82macro "\226\137\170\204\184\239\184\128" "NotLessLess" +let _ = Hashtbl.replace utf82macro "\226\138\144\204\184" "NotSquareSuperset" +let _ = Hashtbl.replace utf82macro "gcd" "gcd" +let _ = Hashtbl.replace utf82macro "\226\139\154\239\184\128" "lesg" +let _ = Hashtbl.replace utf82macro "\226\136\160\204\184" "nang" +let _ = Hashtbl.replace utf82macro "log" "log" +let _ = Hashtbl.replace utf82macro "arccos" "arccos" +let _ = Hashtbl.replace utf82macro "\226\137\130\204\184" "NotEqualTilde" +let _ = Hashtbl.replace utf82macro "\226\137\171\204\184\239\184\128" "NotGreaterGreater" +let _ = Hashtbl.replace utf82macro "\226\139\182\239\184\128" "notindot" +let _ = Hashtbl.replace utf82macro "\226\137\191\204\184" "NotSucceedsTilde" +let _ = Hashtbl.replace utf82macro "\226\139\153\204\184" "nGg" +let _ = Hashtbl.replace utf82macro "\239\149\152" "loang" +let _ = Hashtbl.replace utf82macro "\239\149\153" "roang" +let _ = Hashtbl.replace utf82macro "\239\150\155" "FilledVerySmallSquare" +let _ = Hashtbl.replace utf82macro "\239\150\156" "EmptyVerySmallSquare" +let _ = Hashtbl.replace utf82macro "arg" "arg" +let _ = Hashtbl.replace utf82macro "\239\150\162" "dzigrarr" +let _ = Hashtbl.replace utf82macro "\239\149\182" "xlarr" +let _ = Hashtbl.replace utf82macro "\239\149\183" "xrarr" +let _ = Hashtbl.replace utf82macro "\239\149\184" "xharr" +let _ = Hashtbl.replace utf82macro "\239\149\185" "xlArr" +let _ = Hashtbl.replace utf82macro "\239\149\186" "xrArr" +let _ = Hashtbl.replace utf82macro "\239\149\187" "xhArr" +let _ = Hashtbl.replace utf82macro "\239\149\189" "xmap" +let _ = Hashtbl.replace utf82macro "max" "min" +let _ = Hashtbl.replace utf82macro "\226\169\176\204\184" "napE" +let _ = Hashtbl.replace utf82macro "\\\226\138\130" "bsolhsub" +let _ = Hashtbl.replace utf82macro "\226\136\165\239\184\128\226\131\165" "nparsl" +let _ = Hashtbl.replace utf82macro "cosh" "cosh" +let _ = Hashtbl.replace utf82macro "coth" "coth" +let _ = Hashtbl.replace utf82macro "\226\136\188\239\184\128" "thksim" +let _ = Hashtbl.replace utf82macro "\226\137\169\239\184\128" "gvnE" +let _ = Hashtbl.replace utf82macro "\226\170\173\239\184\128" "lates" +let _ = Hashtbl.replace utf82macro "\226\132\143\239\184\128" "hbar" +let _ = Hashtbl.replace utf82macro "sec" "sec" +let _ = Hashtbl.replace utf82macro "\226\137\142\204\184" "NotHumpDownHump" +let _ = Hashtbl.replace utf82macro "mod" "bmod" +let _ = Hashtbl.replace utf82macro "\226\128\133\239\184\128" "NegativeThickSpace" +let _ = Hashtbl.replace utf82macro "sin" "sin" +let _ = Hashtbl.replace utf82macro "Pr" "Pr" +let _ = Hashtbl.replace utf82macro "\226\137\170\204\184" "nLt" +let _ = Hashtbl.replace utf82macro "\226\136\165\239\184\128" "spar" +let _ = Hashtbl.replace utf82macro "\239\172\128" "fflig" +let _ = Hashtbl.replace utf82macro "\239\172\129" "filig" +let _ = Hashtbl.replace utf82macro "\239\172\130" "fllig" +let _ = Hashtbl.replace utf82macro "\239\172\131" "ffilig" +let _ = Hashtbl.replace utf82macro "\239\172\132" "ffllig" +let _ = Hashtbl.replace utf82macro "\226\167\143\204\184" "NotLeftTriangleBar" +let _ = Hashtbl.replace utf82macro "\226\137\160\239\184\128" "nedot" +let _ = Hashtbl.replace utf82macro "\226\138\148\239\184\128" "sqcups" +let _ = Hashtbl.replace utf82macro "\226\140\131\239\184\128" "ShortUpArrow" +let _ = Hashtbl.replace utf82macro "\226\137\137\204\184" "nvap" +let _ = Hashtbl.replace utf82macro "\240\157\147\128" "kscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\130" "mscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\131" "nscr" +let _ = Hashtbl.replace utf82macro "hom" "hom" +let _ = Hashtbl.replace utf82macro "\240\157\147\133" "pscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\134" "qscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\135" "rscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\136" "sscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\137" "tscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\156" "Ascr" +let _ = Hashtbl.replace utf82macro "\240\157\147\138" "uscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\139" "vscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\158" "Cscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\140" "wscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\159" "Dscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\141" "xscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\142" "yscr" +let _ = Hashtbl.replace utf82macro "\240\157\147\143" "zscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\162" "Gscr" +let _ = Hashtbl.replace utf82macro "\226\137\176\226\131\165" "NotLessEqual" +let _ = Hashtbl.replace utf82macro "\240\157\146\165" "Jscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\166" "Kscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\169" "Nscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\170" "Oscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\132" "Afr" +let _ = Hashtbl.replace utf82macro "\240\157\146\171" "Pscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\133" "Bfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\172" "Qscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\135" "Dfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\174" "Sscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\136" "Efr" +let _ = Hashtbl.replace utf82macro "\240\157\146\175" "Tscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\137" "Ffr" +let _ = Hashtbl.replace utf82macro "\240\157\146\176" "Uscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\138" "Gfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\177" "Vscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\178" "Wscr" +let _ = Hashtbl.replace utf82macro "\240\157\146\179" "Xscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\141" "Jfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\180" "Yscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\142" "Kfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\181" "Zscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\143" "Lfr" +let _ = Hashtbl.replace utf82macro "\240\157\148\144" "Mfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\182" "ascr" +let _ = Hashtbl.replace utf82macro "\240\157\148\145" "Nfr" +let _ = Hashtbl.replace utf82macro "\240\157\146\183" "bscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\146" "Ofr" +let _ = Hashtbl.replace utf82macro "\240\157\146\184" "cscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\147" "Pfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\128" "Iopf" +let _ = Hashtbl.replace utf82macro "\240\157\146\185" "dscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\148" "Qfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\129" "Jopf" +let _ = Hashtbl.replace utf82macro "\240\157\149\130" "Kopf" +let _ = Hashtbl.replace utf82macro "\240\157\146\187" "fscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\150" "Sfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\131" "Lopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\151" "Tfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\132" "Mopf" +let _ = Hashtbl.replace utf82macro "\240\157\146\189" "hscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\152" "Ufr" +let _ = Hashtbl.replace utf82macro "\240\157\146\190" "iscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\153" "Vfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\134" "Oopf" +let _ = Hashtbl.replace utf82macro "\240\157\146\191" "jscr" +let _ = Hashtbl.replace utf82macro "\240\157\148\154" "Wfr" +let _ = Hashtbl.replace utf82macro "\240\157\148\155" "Xfr" +let _ = Hashtbl.replace utf82macro "\240\157\148\156" "Yfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\138" "Sopf" +let _ = Hashtbl.replace utf82macro "\240\157\149\139" "Topf" +let _ = Hashtbl.replace utf82macro "\240\157\148\158" "afr" +let _ = Hashtbl.replace utf82macro "\240\157\149\140" "Uopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\159" "bfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\141" "Vopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\160" "cfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\142" "Wopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\161" "dfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\143" "Xopf" +let _ = Hashtbl.replace utf82macro "\226\170\175\204\184" "npreceq" +let _ = Hashtbl.replace utf82macro "\240\157\148\162" "efr" +let _ = Hashtbl.replace utf82macro "\240\157\149\144" "Yopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\163" "ffr" +let _ = Hashtbl.replace utf82macro "\240\157\148\164" "gfr" +let _ = Hashtbl.replace utf82macro "\240\157\148\165" "hfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\146" "aopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\166" "ifr" +let _ = Hashtbl.replace utf82macro "\240\157\149\147" "bopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\167" "jfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\148" "copf" +let _ = Hashtbl.replace utf82macro "\240\157\148\168" "kfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\149" "dopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\169" "lfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\150" "eopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\170" "mfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\151" "fopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\171" "nfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\152" "gopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\172" "ofr" +let _ = Hashtbl.replace utf82macro "\240\157\149\153" "hopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\173" "pfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\154" "iopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\174" "qfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\155" "jopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\175" "rfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\156" "kopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\176" "sfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\157" "lopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\177" "tfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\158" "mopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\178" "ufr" +let _ = Hashtbl.replace utf82macro "\240\157\149\159" "nopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\179" "vfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\160" "oopf" +let _ = Hashtbl.replace utf82macro "tan" "tan" +let _ = Hashtbl.replace utf82macro "\240\157\148\180" "wfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\161" "popf" +let _ = Hashtbl.replace utf82macro "\240\157\148\181" "xfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\162" "qopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\182" "yfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\163" "ropf" +let _ = Hashtbl.replace utf82macro "\240\157\148\183" "zfr" +let _ = Hashtbl.replace utf82macro "\240\157\149\164" "sopf" +let _ = Hashtbl.replace utf82macro "\240\157\149\165" "topf" +let _ = Hashtbl.replace utf82macro "\240\157\148\184" "Aopf" +let _ = Hashtbl.replace utf82macro "\195\128" "Agrave" +let _ = Hashtbl.replace utf82macro "\240\157\149\166" "uopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\185" "Bopf" +let _ = Hashtbl.replace utf82macro "\195\129" "Aacute" +let _ = Hashtbl.replace utf82macro "\240\157\149\167" "vopf" +let _ = Hashtbl.replace utf82macro "\195\130" "Acirc" +let _ = Hashtbl.replace utf82macro "\240\157\149\168" "wopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\187" "Dopf" +let _ = Hashtbl.replace utf82macro "\195\131" "Atilde" +let _ = Hashtbl.replace utf82macro "\240\157\149\169" "xopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\188" "Eopf" +let _ = Hashtbl.replace utf82macro "\195\132" "Auml" +let _ = Hashtbl.replace utf82macro "\240\157\149\170" "yopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\189" "Fopf" +let _ = Hashtbl.replace utf82macro "\195\133" "Aring" +let _ = Hashtbl.replace utf82macro "\240\157\149\171" "zopf" +let _ = Hashtbl.replace utf82macro "\240\157\148\190" "Gopf" +let _ = Hashtbl.replace utf82macro "\195\134" "AElig" +let _ = Hashtbl.replace utf82macro "\195\135" "Ccedil" +let _ = Hashtbl.replace utf82macro "\195\136" "Egrave" +let _ = Hashtbl.replace utf82macro "\195\137" "Eacute" +let _ = Hashtbl.replace utf82macro "\195\138" "Ecirc" +let _ = Hashtbl.replace utf82macro "\195\139" "Euml" +let _ = Hashtbl.replace utf82macro "\195\140" "Igrave" +let _ = Hashtbl.replace utf82macro "\194\160" "NonBreakingSpace" +let _ = Hashtbl.replace utf82macro "\195\141" "Iacute" +let _ = Hashtbl.replace utf82macro "\194\161" "iexcl" +let _ = Hashtbl.replace utf82macro "\195\142" "Icirc" +let _ = Hashtbl.replace utf82macro "\195\143" "Iuml" +let _ = Hashtbl.replace utf82macro "\194\162" "cent" +let _ = Hashtbl.replace utf82macro "\194\163" "pound" +let _ = Hashtbl.replace utf82macro "\195\144" "ETH" +let _ = Hashtbl.replace utf82macro "\195\145" "Ntilde" +let _ = Hashtbl.replace utf82macro "\194\164" "curren" +let _ = Hashtbl.replace utf82macro "\194\165" "yen" +let _ = Hashtbl.replace utf82macro "\195\146" "Ograve" +let _ = Hashtbl.replace utf82macro "\195\147" "Oacute" +let _ = Hashtbl.replace utf82macro "\194\166" "brvbar" +let _ = Hashtbl.replace utf82macro "\196\128" "Amacr" +let _ = Hashtbl.replace utf82macro "\194\167" "sect" +let _ = Hashtbl.replace utf82macro "\195\148" "Ocirc" +let _ = Hashtbl.replace utf82macro "\196\129" "amacr" +let _ = Hashtbl.replace utf82macro "\195\149" "Otilde" +let _ = Hashtbl.replace utf82macro "\194\168" "uml" +let _ = Hashtbl.replace utf82macro "\196\130" "Abreve" +let _ = Hashtbl.replace utf82macro "\195\150" "Ouml" +let _ = Hashtbl.replace utf82macro "\194\169" "copy" +let _ = Hashtbl.replace utf82macro "\196\131" "abreve" +let _ = Hashtbl.replace utf82macro "\195\151" "times" +let _ = Hashtbl.replace utf82macro "\194\170" "ordf" +let _ = Hashtbl.replace utf82macro "\196\132" "Aogon" +let _ = Hashtbl.replace utf82macro "\195\152" "Oslash" +let _ = Hashtbl.replace utf82macro "\194\171" "laquo" +let _ = Hashtbl.replace utf82macro "\196\133" "aogon" +let _ = Hashtbl.replace utf82macro "\195\153" "Ugrave" +let _ = Hashtbl.replace utf82macro "\194\172" "lnot" +let _ = Hashtbl.replace utf82macro "\196\134" "Cacute" +let _ = Hashtbl.replace utf82macro "\195\154" "Uacute" +let _ = Hashtbl.replace utf82macro "\194\173" "shy" +let _ = Hashtbl.replace utf82macro "\196\135" "cacute" +let _ = Hashtbl.replace utf82macro "\195\155" "Ucirc" +let _ = Hashtbl.replace utf82macro "\194\174" "reg" +let _ = Hashtbl.replace utf82macro "\196\136" "Ccirc" +let _ = Hashtbl.replace utf82macro "\195\156" "Uuml" +let _ = Hashtbl.replace utf82macro "\194\175" "OverBar" +let _ = Hashtbl.replace utf82macro "\196\137" "ccirc" +let _ = Hashtbl.replace utf82macro "\195\157" "Yacute" +let _ = Hashtbl.replace utf82macro "\194\176" "deg" +let _ = Hashtbl.replace utf82macro "\196\138" "Cdot" +let _ = Hashtbl.replace utf82macro "\195\158" "THORN" +let _ = Hashtbl.replace utf82macro "\194\177" "pm" +let _ = Hashtbl.replace utf82macro "\196\139" "cdot" +let _ = Hashtbl.replace utf82macro "\195\159" "szlig" +let _ = Hashtbl.replace utf82macro "\194\178" "sup2" +let _ = Hashtbl.replace utf82macro "\196\140" "Ccaron" +let _ = Hashtbl.replace utf82macro "\194\179" "sup3" +let _ = Hashtbl.replace utf82macro "\196\141" "ccaron" +let _ = Hashtbl.replace utf82macro "\195\160" "agrave" +let _ = Hashtbl.replace utf82macro "\196\142" "Dcaron" +let _ = Hashtbl.replace utf82macro "\194\180" "DiacriticalAcute" +let _ = Hashtbl.replace utf82macro "\195\161" "aacute" +let _ = Hashtbl.replace utf82macro "\194\181" "micro" +let _ = Hashtbl.replace utf82macro "\196\143" "dcaron" +let _ = Hashtbl.replace utf82macro "\195\162" "acirc" +let _ = Hashtbl.replace utf82macro "\194\182" "para" +let _ = Hashtbl.replace utf82macro "\196\144" "Dstrok" +let _ = Hashtbl.replace utf82macro "\195\163" "atilde" +let _ = Hashtbl.replace utf82macro "\196\145" "dstrok" +let _ = Hashtbl.replace utf82macro "\194\183" "middot" +let _ = Hashtbl.replace utf82macro "\195\164" "auml" +let _ = Hashtbl.replace utf82macro "\196\146" "Emacr" +let _ = Hashtbl.replace utf82macro "\194\184" "Cedilla" +let _ = Hashtbl.replace utf82macro "\195\165" "aring" +let _ = Hashtbl.replace utf82macro "\194\185" "sup1" +let _ = Hashtbl.replace utf82macro "\197\128" "lmidot" +let _ = Hashtbl.replace utf82macro "\196\147" "emacr" +let _ = Hashtbl.replace utf82macro "\195\166" "aelig" +let _ = Hashtbl.replace utf82macro "\194\186" "ordm" +let _ = Hashtbl.replace utf82macro "\197\129" "Lstrok" +let _ = Hashtbl.replace utf82macro "\195\167" "ccedil" +let _ = Hashtbl.replace utf82macro "\194\187" "raquo" +let _ = Hashtbl.replace utf82macro "\197\130" "lstrok" +let _ = Hashtbl.replace utf82macro "\195\168" "egrave" +let _ = Hashtbl.replace utf82macro "\197\131" "Nacute" +let _ = Hashtbl.replace utf82macro "\194\188" "frac14" +let _ = Hashtbl.replace utf82macro "\196\150" "Edot" +let _ = Hashtbl.replace utf82macro "\195\169" "eacute" +let _ = Hashtbl.replace utf82macro "\197\132" "nacute" +let _ = Hashtbl.replace utf82macro "\194\189" "half" +let _ = Hashtbl.replace utf82macro "\196\151" "edot" +let _ = Hashtbl.replace utf82macro "\195\170" "ecirc" +let _ = Hashtbl.replace utf82macro "\197\133" "Ncedil" +let _ = Hashtbl.replace utf82macro "\194\190" "frac34" +let _ = Hashtbl.replace utf82macro "\195\171" "euml" +let _ = Hashtbl.replace utf82macro "\196\152" "Eogon" +let _ = Hashtbl.replace utf82macro "\197\134" "ncedil" +let _ = Hashtbl.replace utf82macro "\194\191" "iquest" +let _ = Hashtbl.replace utf82macro "\195\172" "igrave" +let _ = Hashtbl.replace utf82macro "\196\153" "eogon" +let _ = Hashtbl.replace utf82macro "limsup" "limsup" +let _ = Hashtbl.replace utf82macro "\197\135" "Ncaron" +let _ = Hashtbl.replace utf82macro "\195\173" "iacute" +let _ = Hashtbl.replace utf82macro "\196\154" "Ecaron" +let _ = Hashtbl.replace utf82macro "\197\136" "ncaron" +let _ = Hashtbl.replace utf82macro "\195\174" "icirc" +let _ = Hashtbl.replace utf82macro "\196\155" "ecaron" +let _ = Hashtbl.replace utf82macro "\197\137" "napos" +let _ = Hashtbl.replace utf82macro "\195\175" "iuml" +let _ = Hashtbl.replace utf82macro "\196\156" "Gcirc" +let _ = Hashtbl.replace utf82macro "\196\157" "gcirc" +let _ = Hashtbl.replace utf82macro "\195\176" "eth" +let _ = Hashtbl.replace utf82macro "\197\138" "ENG" +let _ = Hashtbl.replace utf82macro "\195\177" "ntilde" +let _ = Hashtbl.replace utf82macro "\196\158" "Gbreve" +let _ = Hashtbl.replace utf82macro "\197\139" "eng" +let _ = Hashtbl.replace utf82macro "\197\140" "Omacr" +let _ = Hashtbl.replace utf82macro "\195\178" "ograve" +let _ = Hashtbl.replace utf82macro "\196\159" "gbreve" +let _ = Hashtbl.replace utf82macro "\197\141" "omacr" +let _ = Hashtbl.replace utf82macro "\195\179" "oacute" +let _ = Hashtbl.replace utf82macro "\196\160" "Gdot" +let _ = Hashtbl.replace utf82macro "\195\180" "ocirc" +let _ = Hashtbl.replace utf82macro "\196\161" "gdot" +let _ = Hashtbl.replace utf82macro "\195\181" "otilde" +let _ = Hashtbl.replace utf82macro "\196\162" "Gcedil" +let _ = Hashtbl.replace utf82macro "\195\182" "ouml" +let _ = Hashtbl.replace utf82macro "\197\144" "Odblac" +let _ = Hashtbl.replace utf82macro "\197\145" "odblac" +let _ = Hashtbl.replace utf82macro "\196\164" "Hcirc" +let _ = Hashtbl.replace utf82macro "\195\183" "div" +let _ = Hashtbl.replace utf82macro "\195\184" "oslash" +let _ = Hashtbl.replace utf82macro "\197\146" "OElig" +let _ = Hashtbl.replace utf82macro "\196\165" "hcirc" +let _ = Hashtbl.replace utf82macro "\195\185" "ugrave" +let _ = Hashtbl.replace utf82macro "\197\147" "oelig" +let _ = Hashtbl.replace utf82macro "\196\166" "Hstrok" +let _ = Hashtbl.replace utf82macro "\195\186" "uacute" +let _ = Hashtbl.replace utf82macro "\197\148" "Racute" +let _ = Hashtbl.replace utf82macro "\196\167" "hstrok" +let _ = Hashtbl.replace utf82macro "\195\187" "ucirc" +let _ = Hashtbl.replace utf82macro "\197\149" "racute" +let _ = Hashtbl.replace utf82macro "\196\168" "Itilde" +let _ = Hashtbl.replace utf82macro "\195\188" "uuml" +let _ = Hashtbl.replace utf82macro "\197\150" "Rcedil" +let _ = Hashtbl.replace utf82macro "\196\169" "itilde" +let _ = Hashtbl.replace utf82macro "\195\189" "yacute" +let _ = Hashtbl.replace utf82macro "\197\151" "rcedil" +let _ = Hashtbl.replace utf82macro "\196\170" "Imacr" +let _ = Hashtbl.replace utf82macro "\195\190" "thorn" +let _ = Hashtbl.replace utf82macro "\197\152" "Rcaron" +let _ = Hashtbl.replace utf82macro "\196\171" "imacr" +let _ = Hashtbl.replace utf82macro "\195\191" "yuml" +let _ = Hashtbl.replace utf82macro "\197\153" "rcaron" +let _ = Hashtbl.replace utf82macro "\197\154" "Sacute" +let _ = Hashtbl.replace utf82macro "\197\155" "sacute" +let _ = Hashtbl.replace utf82macro "\196\174" "Iogon" +let _ = Hashtbl.replace utf82macro "\197\156" "Scirc" +let _ = Hashtbl.replace utf82macro "\196\175" "iogon" +let _ = Hashtbl.replace utf82macro "\197\157" "scirc" +let _ = Hashtbl.replace utf82macro "\196\176" "Idot" +let _ = Hashtbl.replace utf82macro "\197\158" "Scedil" +let _ = Hashtbl.replace utf82macro "\196\177" "imath" +let _ = Hashtbl.replace utf82macro "\197\159" "scedil" +let _ = Hashtbl.replace utf82macro "\196\178" "IJlig" +let _ = Hashtbl.replace utf82macro "\197\160" "Scaron" +let _ = Hashtbl.replace utf82macro "\196\179" "ijlig" +let _ = Hashtbl.replace utf82macro "\197\161" "scaron" +let _ = Hashtbl.replace utf82macro "\196\180" "Jcirc" +let _ = Hashtbl.replace utf82macro "\197\162" "Tcedil" +let _ = Hashtbl.replace utf82macro "\196\181" "jcirc" +let _ = Hashtbl.replace utf82macro "\197\163" "tcedil" +let _ = Hashtbl.replace utf82macro "\196\182" "Kcedil" +let _ = Hashtbl.replace utf82macro "\197\164" "Tcaron" +let _ = Hashtbl.replace utf82macro "\226\128\138\239\184\128" "NegativeVeryThinSpace" +let _ = Hashtbl.replace utf82macro "\196\183" "kcedil" +let _ = Hashtbl.replace utf82macro "\197\165" "tcaron" +let _ = Hashtbl.replace utf82macro "\196\184" "kgreen" +let _ = Hashtbl.replace utf82macro "\198\146" "fnof" +let _ = Hashtbl.replace utf82macro "\197\166" "Tstrok" +let _ = Hashtbl.replace utf82macro "\196\185" "Lacute" +let _ = Hashtbl.replace utf82macro "\197\167" "tstrok" +let _ = Hashtbl.replace utf82macro "\196\186" "lacute" +let _ = Hashtbl.replace utf82macro "\197\168" "Utilde" +let _ = Hashtbl.replace utf82macro "\196\187" "Lcedil" +let _ = Hashtbl.replace utf82macro "\197\169" "utilde" +let _ = Hashtbl.replace utf82macro "\226\137\143\204\184" "NotHumpEqual" +let _ = Hashtbl.replace utf82macro "\196\188" "lcedil" +let _ = Hashtbl.replace utf82macro "\197\170" "Umacr" +let _ = Hashtbl.replace utf82macro "\196\189" "Lcaron" +let _ = Hashtbl.replace utf82macro "\197\171" "umacr" +let _ = Hashtbl.replace utf82macro "\196\190" "lcaron" +let _ = Hashtbl.replace utf82macro "\197\172" "Ubreve" +let _ = Hashtbl.replace utf82macro "\196\191" "Lmidot" +let _ = Hashtbl.replace utf82macro "\197\173" "ubreve" +let _ = Hashtbl.replace utf82macro "\197\174" "Uring" +let _ = Hashtbl.replace utf82macro "\197\175" "uring" +let _ = Hashtbl.replace utf82macro "\197\176" "Udblac" +let _ = Hashtbl.replace utf82macro "\197\177" "udblac" +let _ = Hashtbl.replace utf82macro "\197\178" "Uogon" +let _ = Hashtbl.replace utf82macro "\197\179" "uogon" +let _ = Hashtbl.replace utf82macro "\197\180" "Wcirc" +let _ = Hashtbl.replace utf82macro "\197\181" "wcirc" +let _ = Hashtbl.replace utf82macro "\197\182" "Ycirc" +let _ = Hashtbl.replace utf82macro "\197\183" "ycirc" +let _ = Hashtbl.replace utf82macro "\197\184" "Yuml" +let _ = Hashtbl.replace utf82macro "\197\185" "Zacute" +let _ = Hashtbl.replace utf82macro "\197\186" "zacute" +let _ = Hashtbl.replace utf82macro "\197\187" "Zdot" +let _ = Hashtbl.replace utf82macro "\197\188" "zdot" +let _ = Hashtbl.replace utf82macro "\197\189" "Zcaron" +let _ = Hashtbl.replace utf82macro "\197\190" "zcaron" +let _ = Hashtbl.replace utf82macro "\226\136\163\239\184\128" "smid" +let _ = Hashtbl.replace utf82macro "\239\184\181" "OverParenthesis" +let _ = Hashtbl.replace utf82macro "\239\184\182" "UnderParenthesis" +let _ = Hashtbl.replace utf82macro "\239\184\183" "OverBrace" +let _ = Hashtbl.replace utf82macro "\239\184\184" "UnderBrace" +let _ = Hashtbl.replace utf82macro "\199\181" "gacute" +let _ = Hashtbl.replace utf82macro "cos" "cos" +let _ = Hashtbl.replace utf82macro "\226\136\170\239\184\128" "cups" +let _ = Hashtbl.replace utf82macro "cot" "cot" +let _ = Hashtbl.replace utf82macro "\201\155" "varepsilon" +let _ = Hashtbl.replace utf82macro "\226\138\139\239\184\128" "vsupnE" +let _ = Hashtbl.replace utf82macro "\203\135" "Hacek" diff --git a/helm/software/components/whelp/.depend b/helm/software/components/whelp/.depend new file mode 100644 index 000000000..39f37dfa9 --- /dev/null +++ b/helm/software/components/whelp/.depend @@ -0,0 +1,4 @@ +whelp.cmo: whelp.cmi +whelp.cmx: whelp.cmi +fwdQueries.cmo: fwdQueries.cmi +fwdQueries.cmx: fwdQueries.cmi diff --git a/helm/software/components/whelp/Makefile b/helm/software/components/whelp/Makefile new file mode 100644 index 000000000..6d8d3958f --- /dev/null +++ b/helm/software/components/whelp/Makefile @@ -0,0 +1,11 @@ +PACKAGE = whelp + +INTERFACE_FILES = \ + whelp.mli \ + fwdQueries.mli \ + $(NULL) + +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/whelp/fwdQueries.ml b/helm/software/components/whelp/fwdQueries.ml new file mode 100644 index 000000000..1f4e508fc --- /dev/null +++ b/helm/software/components/whelp/fwdQueries.ml @@ -0,0 +1,115 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +(* fwd_simpl ****************************************************************) + +let rec filter_map_n f n = function + | [] -> [] + | hd :: tl -> + match f n hd with + | None -> filter_map_n f (succ n) tl + | Some hd -> hd :: filter_map_n f (succ n) tl + +let get_uri t = + let aux = function + | Cic.Appl (hd :: tl) -> Some (CicUtil.uri_of_term hd, tl) + | hd -> Some (CicUtil.uri_of_term hd, []) + in + try aux t with + | Invalid_argument "uri_of_term" -> None + +let get_metadata t = + let f n t = + match get_uri t with + | None -> None + | Some (uri, _) -> Some (n, uri) + in + match get_uri t with + | None -> None + | Some (uri, args) -> Some (uri, filter_map_n f 1 args) + +let debug_metadata = function + | None -> () + | Some (outer, inners) -> + let f (n, uri) = Printf.eprintf "%s: %i %s\n" "fwd" n (UriManager.string_of_uri uri) in + Printf.eprintf "\n%s: %s\n" "fwd" (UriManager.string_of_uri outer); + List.iter f inners; prerr_newline () + +let fwd_simpl ~dbd t = + let map inners row = + match row.(0), row.(1), row.(2) with + | Some source, Some inner, Some index -> + source, + List.mem + (int_of_string index, (UriManager.uri_of_string inner)) inners + | _ -> "", false + in + let rec rank ranks (source, ok) = + match ranks, ok with + | [], false -> [source, 0] + | [], true -> [source, 1] + | (uri, i) :: tl, false when uri = source -> (uri, 0) :: tl + | (uri, 0) :: tl, true when uri = source -> (uri, 0) :: tl + | (uri, i) :: tl, true when uri = source -> (uri, succ i) :: tl + | hd :: tl, _ -> hd :: rank tl (source, ok) + in + let compare (_, x) (_, y) = compare x y in + let filter n (uri, rank) = + if rank > 0 then Some (UriManager.uri_of_string uri) else None + in + let metadata = get_metadata t in debug_metadata metadata; + match metadata with + | None -> [] + | Some (outer, inners) -> + let select = "source, h_inner, h_index" in + let from = "genLemma" in + let where = + Printf.sprintf "h_outer = \"%s\"" + (HMysql.escape (UriManager.string_of_uri outer)) in + let query = Printf.sprintf "SELECT %s FROM %s WHERE %s" select from where in + let result = HMysql.exec dbd query in + let lemmas = HMysql.map ~f:(map inners) result in + let ranked = List.fold_left rank [] lemmas in + let ordered = List.rev (List.fast_sort compare ranked) in + filter_map_n filter 0 ordered + +(* get_decomposables ********************************************************) + +let decomposables ~dbd = + let map row = match row.(0) with + | None -> None + | Some str -> + match CicUtil.term_of_uri (UriManager.uri_of_string str) with + | Cic.MutInd (uri, typeno, _) -> Some (uri, typeno) + | _ -> + raise (UriManager.IllFormedUri str) + in + let select, from = "source", "decomposables" in + let query = Printf.sprintf "SELECT %s FROM %s" select from in + let decomposables = HMysql.map ~f:map (HMysql.exec dbd query) in + filter_map_n (fun _ x -> x) 0 decomposables + diff --git a/helm/software/components/whelp/fwdQueries.mli b/helm/software/components/whelp/fwdQueries.mli new file mode 100644 index 000000000..7f580a541 --- /dev/null +++ b/helm/software/components/whelp/fwdQueries.mli @@ -0,0 +1,28 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val fwd_simpl: dbd:HMysql.dbd -> Cic.term -> UriManager.uri list +val decomposables: dbd:HMysql.dbd -> (UriManager.uri * int) list + diff --git a/helm/software/components/whelp/whelp.ml b/helm/software/components/whelp/whelp.ml new file mode 100644 index 000000000..5e63bcfc4 --- /dev/null +++ b/helm/software/components/whelp/whelp.ml @@ -0,0 +1,215 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let nonvar uri = not (UriManager.uri_is_var uri) + + (** maps a shell like pattern (which uses '*' and '?') to a sql pattern for + * the "like" operator (which uses '%' and '_'). Does not support escaping. *) +let sqlpat_of_shellglob = + let star_RE, qmark_RE, percent_RE, uscore_RE = + Pcre.regexp "\\*", Pcre.regexp "\\?", Pcre.regexp "%", Pcre.regexp "_" + in + fun shellglob -> + Pcre.replace ~rex:star_RE ~templ:"%" + (Pcre.replace ~rex:qmark_RE ~templ:"_" + (Pcre.replace ~rex:percent_RE ~templ:"\\%" + (Pcre.replace ~rex:uscore_RE ~templ:"\\_" + shellglob))) + +let locate ~(dbd:HMysql.dbd) ?(vars = false) pat = + let sql_pat = sqlpat_of_shellglob pat in + let query = + sprintf ("SELECT source FROM %s WHERE value LIKE \"%s\" UNION "^^ + "SELECT source FROM %s WHERE value LIKE \"%s\"") + (MetadataTypes.name_tbl ()) sql_pat + MetadataTypes.library_name_tbl sql_pat + in + let result = HMysql.exec dbd query in + List.filter nonvar + (HMysql.map result + (fun cols -> match cols.(0) with Some s -> UriManager.uri_of_string s | _ -> assert false)) + +let match_term ~(dbd:HMysql.dbd) ty = +(* debug_print (lazy (CicPp.ppterm ty)); *) + let metadata = MetadataExtractor.compute ~body:None ~ty in + let constants_no = + MetadataConstraints.UriManagerSet.cardinal (MetadataConstraints.constants_of ty) + in + let full_card, diff = + if CicUtil.is_meta_closed ty then + Some (MetadataConstraints.Eq constants_no), None + else + let diff_no = + let (hyp_constants, concl_constants) = + (* collect different constants in hypotheses and conclusions *) + List.fold_left + (fun ((hyp, concl) as acc) metadata -> + match (metadata: MetadataTypes.metadata) with + | `Sort _ | `Rel _ -> acc + | `Obj (uri, `InConclusion) | `Obj (uri, `MainConclusion _) + when not (List.mem uri concl) -> (hyp, uri :: concl) + | `Obj (uri, `InHypothesis) | `Obj (uri, `MainHypothesis _) + when not (List.mem uri hyp) -> (uri :: hyp, concl) + | `Obj _ -> acc) + ([], []) + metadata + in + List.length hyp_constants - List.length concl_constants + in + let (concl_metas, hyp_metas) = MetadataExtractor.compute_metas ty in + let diff = + if MetadataExtractor.IntSet.equal concl_metas hyp_metas then + Some (MetadataConstraints.Eq diff_no) + else if MetadataExtractor.IntSet.subset concl_metas hyp_metas then + Some (MetadataConstraints.Gt (diff_no - 1)) + else if MetadataExtractor.IntSet.subset hyp_metas concl_metas then + Some (MetadataConstraints.Lt (diff_no + 1)) + else + None + in + None, diff + in + let constraints = List.map MetadataTypes.constr_of_metadata metadata in + MetadataConstraints.at_least ~dbd ?full_card ?diff constraints + +let fill_with_dummy_constants t = + let rec aux i types = + function + Cic.Lambda (n,s,t) -> + let dummy_uri = + UriManager.uri_of_string ("cic:/dummy_"^(string_of_int i)^".con") in + (aux (i+1) (s::types) + (CicSubstitution.subst (Cic.Const(dummy_uri,[])) t)) + | t -> t,types + in + let t,types = aux 0 [] t in + t, List.rev types + +let instance ~dbd t = + let t',types = fill_with_dummy_constants t in + let metadata = MetadataExtractor.compute ~body:None ~ty:t' in +(* List.iter + (fun x -> + debug_print + (lazy (MetadataPp.pp_constr (MetadataTypes.constr_of_metadata x)))) + metadata; *) + let no_concl = MetadataDb.count_distinct `Conclusion metadata in + let no_hyp = MetadataDb.count_distinct `Hypothesis metadata in + let no_full = MetadataDb.count_distinct `Statement metadata in + let is_dummy = function + | `Obj(s, _) -> (String.sub (UriManager.string_of_uri s) 0 10) <> "cic:/dummy" + | _ -> true + in + let rec look_for_dummy_main = function + | [] -> None + | `Obj(s,`MainConclusion (Some (MetadataTypes.Eq d)))::_ + when (String.sub (UriManager.string_of_uri s) 0 10 = "cic:/dummy") -> + let s = UriManager.string_of_uri s in + let len = String.length s in + let dummy_index = int_of_string (String.sub s 11 (len-15)) in + let dummy_type = List.nth types dummy_index in + Some (d,dummy_type) + | _::l -> look_for_dummy_main l + in + match (look_for_dummy_main metadata) with + | None-> +(* debug_print (lazy "Caso None"); *) + (* no dummy in main position *) + let metadata = List.filter is_dummy metadata in + let constraints = List.map MetadataTypes.constr_of_metadata metadata in + let concl_card = Some (MetadataConstraints.Eq no_concl) in + let full_card = Some (MetadataConstraints.Eq no_full) in + let diff = Some (MetadataConstraints.Eq (no_hyp - no_concl)) in + MetadataConstraints.at_least ~dbd ?concl_card ?full_card ?diff + constraints + | Some (depth, dummy_type) -> +(* debug_print + (lazy (sprintf "Caso Some %d %s" depth (CicPp.ppterm dummy_type))); *) + (* a dummy in main position *) + let metadata_for_dummy_type = + MetadataExtractor.compute ~body:None ~ty:dummy_type in + (* Let us skip this for the moment + let main_of_dummy_type = + look_for_dummy_main metadata_for_dummy_type in *) + let metadata = List.filter is_dummy metadata in + let constraints = List.map MetadataTypes.constr_of_metadata metadata in + let metadata_for_dummy_type = + List.filter is_dummy metadata_for_dummy_type in + let metadata_for_dummy_type, depth' = + (* depth' = the depth of the A -> A -> Prop *) + List.fold_left (fun (acc,dep) c -> + match c with + | `Sort (s,`MainConclusion (Some (MetadataTypes.Eq i))) -> + (`Sort (s,`MainConclusion (Some (MetadataTypes.Ge i))))::acc, i + | `Obj (s,`MainConclusion (Some (MetadataTypes.Eq i))) -> + (`Obj (s,`MainConclusion (Some (MetadataTypes.Ge i))))::acc, i + | `Rel (`MainConclusion (Some (MetadataTypes.Eq i))) -> + (`Rel (`MainConclusion (Some (MetadataTypes.Ge i))))::acc, i + | _ -> (c::acc,dep)) ([],0) metadata_for_dummy_type + in + let constraints_for_dummy_type = + List.map MetadataTypes.constr_of_metadata metadata_for_dummy_type in + (* start with the dummy constant in main conlusion *) + let from = ["refObj as table0"] in + let where = + [sprintf "table0.h_position = \"%s\"" MetadataTypes.mainconcl_pos; + sprintf "table0.h_depth >= %d" depth] in + let (n,from,where) = + List.fold_left + (MetadataConstraints.add_constraint ~start:2) + (2,from,where) constraints in + let concl_card = Some (MetadataConstraints.Eq no_concl) in + let full_card = Some (MetadataConstraints.Eq no_full) in + let diff = Some (MetadataConstraints.Eq (no_hyp - no_concl)) in + let (n,from,where) = + MetadataConstraints.add_all_constr + (n,from,where) concl_card full_card diff in + (* join with the constraints over the type of the constant *) + let where = + (sprintf "table0.h_occurrence = table%d.source" n)::where in + let where = + sprintf "table0.h_depth - table%d.h_depth = %d" + n (depth - depth')::where + in + let (m,from,where) = + List.fold_left + (MetadataConstraints.add_constraint ~start:n) + (n,from,where) constraints_for_dummy_type in + MetadataConstraints.exec ~dbd (m,from,where) + +let elim ~dbd uri = + let constraints = + [`Rel [`MainConclusion None]; + `Sort (Cic.Prop,[`MainHypothesis (Some (MetadataTypes.Ge 1))]); + `Obj (uri,[`MainHypothesis (Some (MetadataTypes.Eq 0))]); + `Obj (uri,[`InHypothesis]); + ] + in + MetadataConstraints.at_least ~rating:`Hits ~dbd constraints + diff --git a/helm/software/components/whelp/whelp.mli b/helm/software/components/whelp/whelp.mli new file mode 100644 index 000000000..9ff03ea20 --- /dev/null +++ b/helm/software/components/whelp/whelp.mli @@ -0,0 +1,30 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val locate: dbd:HMysql.dbd -> ?vars:bool -> string -> UriManager.uri list +val elim: dbd:HMysql.dbd -> UriManager.uri -> UriManager.uri list +val instance: dbd:HMysql.dbd -> Cic.term -> UriManager.uri list +val match_term: dbd:HMysql.dbd -> Cic.term -> UriManager.uri list + diff --git a/helm/software/components/xml/.depend b/helm/software/components/xml/.depend new file mode 100644 index 000000000..5ef59bdc9 --- /dev/null +++ b/helm/software/components/xml/.depend @@ -0,0 +1,4 @@ +xml.cmo: xml.cmi +xml.cmx: xml.cmi +xmlPushParser.cmo: xmlPushParser.cmi +xmlPushParser.cmx: xmlPushParser.cmi diff --git a/helm/software/components/xml/Makefile b/helm/software/components/xml/Makefile new file mode 100644 index 000000000..7948435aa --- /dev/null +++ b/helm/software/components/xml/Makefile @@ -0,0 +1,12 @@ +PACKAGE = xml +PREDICATES = + +INTERFACE_FILES = \ + xml.mli \ + xmlPushParser.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/xml/test.ml b/helm/software/components/xml/test.ml new file mode 100644 index 000000000..84c042e28 --- /dev/null +++ b/helm/software/components/xml/test.ml @@ -0,0 +1,60 @@ +(* $Id$ *) + +(* Parsing test: + * - XmlPushParser version *) +open Printf +open XmlPushParser + +let print s = print_endline s; flush stdout + +let callbacks = + { default_callbacks with + start_element = + Some (fun tag attrs -> + let length = List.length attrs in + print (sprintf "opening %s [%s]" + tag (String.concat ";" (List.map fst attrs)))); + end_element = Some (fun tag -> print ("closing " ^ tag)); + character_data = Some (fun data -> print "character data ..."); + } + +let xml_parser = create_parser callbacks + +let is_gzip f = + try + let len = String.length f in + String.sub f (len - 3) 3 = ".gz" + with Invalid_argument _ -> false + +let _ = + let xml_source = + if is_gzip Sys.argv.(1) then + `Gzip_file Sys.argv.(1) + else + `File Sys.argv.(1) + in + parse xml_parser xml_source + +(* Parsing test: + * - Pure expat version (without XmlPushParser mediation). + * Originally written only to test if XmlPushParser mediation caused overhead. + * That was not the case. *) + +(*let _ =*) +(* let ic = open_in Sys.argv.(1) in*) +(* let expat_parser = Expat.parser_create ~encoding:None in*) +(* Expat.set_start_element_handler expat_parser*) +(* (fun tag attrs ->*) +(* let length = List.length attrs in*) +(* print (sprintf "opening %s [%d attribute%s]"*) +(* tag length (if length = 1 then "" else "s")));*) +(* Expat.set_end_element_handler expat_parser*) +(* (fun tag -> print ("closing " ^ tag));*) +(* Expat.set_character_data_handler expat_parser*) +(* (fun data -> print "character data ...");*) +(* try*) +(* while true do*) +(* Expat.parse expat_parser (input_line ic ^ "\n")*) +(* done*) +(* with End_of_file -> Expat.final expat_parser*) + diff --git a/helm/software/components/xml/xml.ml b/helm/software/components/xml/xml.ml new file mode 100644 index 000000000..f8cc41cbe --- /dev/null +++ b/helm/software/components/xml/xml.ml @@ -0,0 +1,177 @@ +(* 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 *) +(* *) +(* A tactic to print Coq objects in XML *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 18/10/2000 *) +(* *) +(* This module defines a pretty-printer and the stream of commands to the pp *) +(* *) +(******************************************************************************) + +(* $Id$ *) + + +(* the type token for XML cdata, empty elements and not-empty elements *) +(* Usage: *) +(* Str cdata *) +(* Empty (prefix, element_name, *) +(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen] *) +(* NEmpty (prefix, element_name, *) +(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen], *) +(* content *) +type token = + Str of string + | Empty of string option * string * (string option * string * string) list + | NEmpty of string option * string * (string option * string * string) list * + token Stream.t +;; + +(* currified versions of the constructors make the code more readable *) +let xml_empty ?prefix name attrs = + [< 'Empty(prefix,name,attrs) >] +let xml_nempty ?prefix name attrs content = + [< 'NEmpty(prefix,name,attrs,content) >] +let xml_cdata str = + [< 'Str str >] + +(** 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 pprefix = + function + None -> "" + | Some p -> p ^ ":" in + let rec pp_r m = + parser + | [< 'Str a ; s >] -> + print_spaces m ; + f (a ^ "\n") ; + pp_r m s + | [< 'Empty(p,n,l) ; s >] -> + print_spaces m ; + f ("<" ^ (pprefix p) ^ n) ; + List.iter (fun (p,n,v) -> f (" " ^ (pprefix p) ^ n ^ "=\"" ^ v ^ "\"")) l; + f "/>\n" ; + pp_r m s + | [< 'NEmpty(p,n,l,c) ; s >] -> + print_spaces m ; + f ("<" ^ (pprefix p) ^ n) ; + List.iter (fun (p,n,v) -> f (" " ^ (pprefix p) ^ n ^ "=\"" ^ v ^ "\"")) l; + f ">\n" ; + pp_r (m+1) c ; + print_spaces m ; + f ("\n") ; + pp_r m s + | [< >] -> () + and print_spaces m = + 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 +;; + +let pp_to_gzipchan strm oc = + pp_gen (fun s -> Gzip.output oc s 0 (String.length s)) strm +;; + +(** 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 ?(gzip=false) strm fn = + if gzip then + match fn with + | Some filename -> + let outchan = Gzip.open_out filename in + (try + pp_to_gzipchan strm outchan; + with e -> + Gzip.close_out outchan; + raise e); + Gzip.close_out outchan + | None -> failwith "Can't sent gzipped output to stdout" + else + match fn with + | Some filename -> + let outchan = open_out filename in + (try + pp_to_outchan strm outchan; + with e -> + close_out outchan; + raise e); + close_out outchan + | None -> pp_to_outchan strm stdout +;; + +let pp = + let profiler = HExtlib.profile "Xml.pp" in + fun ?gzip strm fn -> + profiler.HExtlib.profile (pp ?gzip strm) fn +;; + +let add_xml_declaration stream = + let box_prefix = "b" in + [< + xml_cdata "\n" ; + xml_cdata "\n"; + xml_nempty ~prefix:box_prefix "box" + [ Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ; + Some "xmlns","b","http://helm.cs.unibo.it/2003/BoxML" ; + Some "xmlns","helm","http://www.cs.unibo.it/helm" ; + Some "xmlns","xlink","http://www.w3.org/1999/xlink" + ] stream + >] + + (* 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 s = + let rec aux n pos = + if n = 0 + then String.sub s pos (String.length s - pos) + else aux (n - 1) (String.index_from s pos '\n' + 1) + in + try + aux 4 0 + with Not_found -> s + diff --git a/helm/software/components/xml/xml.mli b/helm/software/components/xml/xml.mli new file mode 100644 index 000000000..4feca7503 --- /dev/null +++ b/helm/software/components/xml/xml.mli @@ -0,0 +1,75 @@ +(* 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 *) +(* *) +(* A tactic to print Coq objects in XML *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 18/10/2000 *) +(* *) +(* This module defines a pretty-printer and the stream of commands to the pp *) +(* *) +(******************************************************************************) + +(* Tokens for XML cdata, empty elements and not-empty elements *) +(* Usage: *) +(* Str cdata *) +(* Empty (prefix, element_name, *) +(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen] *) +(* NEmpty (prefix, element_name, *) +(* [prefix1, attrname1, value1 ; ... ; prefixn, attrnamen, valuen], *) +(* content *) +type token = + Str of string + | Empty of string option * string * (string option * string * string) list + | NEmpty of string option * string * (string option * string * string) list * + token Stream.t +;; + +(* currified versions of the token constructors make the code more readable *) +val xml_empty : + ?prefix:string -> string -> (string option * string * string) list -> + token Stream.t +val xml_nempty : + ?prefix:string -> string -> (string option * string * string) list -> + token Stream.t -> token Stream.t +val xml_cdata : string -> token Stream.t + +(* The pretty printer for streams of token *) +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename +* @param gzip if set to true files are gzipped. Defaults to false *) +val pp : ?gzip: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 + +val add_xml_declaration: token Stream.t -> token Stream.t + +val strip_xml_headings: string -> string + diff --git a/helm/software/components/xml/xmlPushParser.ml b/helm/software/components/xml/xmlPushParser.ml new file mode 100644 index 000000000..4f57e1242 --- /dev/null +++ b/helm/software/components/xml/xmlPushParser.ml @@ -0,0 +1,118 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let gzip_bufsize = 10240 + +type callbacks = { + start_element: (string -> (string * string) list -> unit) option; + end_element: (string -> unit) option; + character_data: (string -> unit) option; + processing_instruction: (string -> string -> unit) option; + comment: (string -> unit) option; +} + +let default_callbacks = { + start_element = None; + end_element = None; + character_data = None; + processing_instruction = None; + comment = None; +} + +type xml_source = + [ `Channel of in_channel + | `File of string + | `Gzip_channel of Gzip.in_channel + | `Gzip_file of string + | `String of string + ] + +type position = int * int + +type xml_parser = Expat.expat_parser + +exception Parse_error of string + +let create_parser callbacks = + let expat_parser = Expat.parser_create ~encoding:None in + (match callbacks.start_element with + | Some f -> Expat.set_start_element_handler expat_parser f + | _ -> ()); + (match callbacks.end_element with + | Some f -> Expat.set_end_element_handler expat_parser f + | _ -> ()); + (match callbacks.character_data with + | Some f -> Expat.set_character_data_handler expat_parser f + | _ -> ()); + (match callbacks.processing_instruction with + | Some f -> Expat.set_processing_instruction_handler expat_parser f + | _ -> ()); + (match callbacks.comment with + | Some f -> Expat.set_comment_handler expat_parser f + | _ -> ()); + expat_parser + +let final = Expat.final + +let get_position expat_parser = + (Expat.get_current_line_number expat_parser, + Expat.get_current_column_number expat_parser) + +let parse expat_parser = + let parse_fun = Expat.parse expat_parser in + let rec aux = function + | `Channel ic -> + (try + while true do parse_fun (input_line ic ^ "\n") done + with End_of_file -> final expat_parser) + | `File fname -> + let ic = open_in fname in + aux (`Channel ic); + close_in ic + | `Gzip_channel ic -> + let buf = String.create gzip_bufsize in + (try + while true do + let bytes = Gzip.input ic buf 0 gzip_bufsize in + if bytes = 0 then raise End_of_file; + parse_fun (String.sub buf 0 bytes) + done + with End_of_file -> final expat_parser) + | `Gzip_file fname -> + let ic = Gzip.open_in fname in + aux (`Gzip_channel ic); + Gzip.close_in ic + | `String s -> parse_fun s + in + aux + +let parse expat_parser xml_source = + try + parse expat_parser xml_source + with Expat.Expat_error xml_error -> + raise (Parse_error (Expat.xml_error_to_string xml_error)) + diff --git a/helm/software/components/xml/xmlPushParser.mli b/helm/software/components/xml/xmlPushParser.mli new file mode 100644 index 000000000..c13481c91 --- /dev/null +++ b/helm/software/components/xml/xmlPushParser.mli @@ -0,0 +1,78 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** {2 XLM push parser generic interface} + * Do not depend on CIC *) + + (** callbacks needed to instantiate a parser *) +type callbacks = { + start_element: + (string -> (string * string) list -> unit) option; (* tag, attr list *) + end_element: (string -> unit) option; (* tag *) + character_data: (string -> unit) option; (* data *) + processing_instruction: + (string -> string -> unit) option; (* target, value *) + comment: (string -> unit) option; (* value *) +} + + (** do nothing callbacks (all set to None) *) +val default_callbacks: callbacks + + (** source from which parse an XML file *) +type xml_source = + [ `Channel of in_channel + | `File of string + | `Gzip_channel of Gzip.in_channel + | `Gzip_file of string + | `String of string + ] + + (** source position in a XML source. + * A position is a pair *) +type position = int * int + +type xml_parser + + (** raised when a parse error occurs, argument is an error message. + * This exception carries no position information, but it should be get using + * get_position below *) +exception Parse_error of string + + (** Create a push parser which invokes the given callbacks *) +val create_parser: callbacks -> xml_parser + + (** Parse XML data from a given source with a given parser + * @raise Parse_error *) +val parse: xml_parser -> xml_source -> unit + + (** Inform the parser that parsing is completed, needed only when source is + * `String, for other sources it is automatically invoked when the end of file + * is reached + * @raise Parse_error *) +val final: xml_parser -> unit + + (** @return current pair *) +val get_position: xml_parser -> position + diff --git a/helm/software/components/xmldiff/.depend b/helm/software/components/xmldiff/.depend new file mode 100644 index 000000000..e2832de33 --- /dev/null +++ b/helm/software/components/xmldiff/.depend @@ -0,0 +1,2 @@ +xmlDiff.cmo: xmlDiff.cmi +xmlDiff.cmx: xmlDiff.cmi diff --git a/helm/software/components/xmldiff/Makefile b/helm/software/components/xmldiff/Makefile new file mode 100644 index 000000000..afffaeefb --- /dev/null +++ b/helm/software/components/xmldiff/Makefile @@ -0,0 +1,10 @@ +PACKAGE = xmldiff +PREDICATES = + +INTERFACE_FILES = xmlDiff.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../../Makefile.defs +include ../Makefile.common diff --git a/helm/software/components/xmldiff/xmlDiff.ml b/helm/software/components/xmldiff/xmlDiff.ml new file mode 100644 index 000000000..6f68438e9 --- /dev/null +++ b/helm/software/components/xmldiff/xmlDiff.ml @@ -0,0 +1,345 @@ +(* 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/. + *) + +(* $Id$ *) + +let mathmlns = "http://www.w3.org/1998/Math/MathML";; +let xmldiffns = "http://helm.cs.unibo.it/XmlDiff";; +let helmns = "http://www.cs.unibo.it/helm";; + +let ds_selection = Gdome.domString "selection";; +let ds_2 = Gdome.domString "2";; +let ds_mathmlns = Gdome.domString mathmlns;; +let ds_m_style = Gdome.domString "m:mstyle";; +let ds_mathbackground = Gdome.domString "mathbackground";; +let ds_xmldiffns = Gdome.domString xmldiffns;; +let ds_xmldiff_type = Gdome.domString "xmldiff:type";; +let ds_fake = Gdome.domString "fake";; +let ds_helmns = Gdome.domString helmns;; +let ds_xref = Gdome.domString "xref";; +let ds_type = Gdome.domString "type";; +let ds_yellow = Gdome.domString "yellow";; +let ds_green = Gdome.domString "#00ff00";; +let ds_maction = Gdome.domString "maction";; +let ds_mtr = Gdome.domString "mtr";; +let ds_mtd = Gdome.domString "mtd";; + +type highlighted_nodes = Gdome.node list;; + +let rec make_visible (n: Gdome.node) = + match n#get_parentNode with + None -> () + | Some p -> + match p#get_namespaceURI, p#get_localName with + Some nu, Some ln when + nu#equals ds_mathmlns && ln#equals ds_maction -> + (new Gdome.element_of_node p)#setAttribute + ~name:ds_selection + ~value:ds_2 ; + make_visible p + | _,_ -> make_visible p +;; + +let highlight_node_total_time = ref 0.0;; + +let highlight_node ?(color=ds_yellow) (doc: Gdome.document) (n: Gdome.node) = + let highlight (n: Gdome.node) = + let highlighter = + doc#createElementNS + ~namespaceURI:(Some ds_mathmlns) + ~qualifiedName:ds_m_style + in + highlighter#setAttribute ~name:ds_mathbackground ~value:color ; + highlighter#setAttributeNS + ~namespaceURI:(Some ds_xmldiffns) + ~qualifiedName:ds_xmldiff_type + ~value:ds_fake ; + let parent = + match n#get_parentNode with + None -> assert false + | Some p -> p + in + ignore + (parent#replaceChild ~oldChild:n ~newChild:(highlighter :> Gdome.node)) ; + ignore (highlighter#appendChild n) ; + (highlighter :> Gdome.node) + in + let rec find_mstylable_node n = + match n#get_namespaceURI, n#get_localName with + Some nu, Some ln when + nu#equals ds_mathmlns && + (not (ln#equals ds_mtr)) && (not (ln#equals ds_mtd)) -> n + | Some nu, Some ln when + nu#equals ds_mathmlns && + ln#equals ds_mtr || ln#equals ds_mtd -> + let true_child = + match n#get_firstChild with + None -> assert false + | Some n -> n + in + find_mstylable_node true_child + | _,_ -> + match n#get_parentNode with + None -> assert false + | Some p -> find_mstylable_node p + in + let highlighter = highlight (find_mstylable_node n) in + make_visible highlighter ; + highlighter +;; + +let iter_children ~f (n:Gdome.node) = + let rec aux = + function + None -> () + | Some n -> + let sibling = n#get_nextSibling in + (f n) ; + aux sibling + in + aux n#get_firstChild +;; + +let highlight_nodes ~xrefs (doc:Gdome.document) = + let highlighted = ref [] in + let rec aux (n:Gdome.element) = + let attributeNS = + (n#getAttributeNS ~namespaceURI:ds_helmns + ~localName:ds_xref)#to_string in + if List.mem attributeNS xrefs then + highlighted := + (highlight_node ~color:ds_green doc (n :> Gdome.node)):: + !highlighted ; + iter_children (n :> Gdome.node) + ~f:(function n -> + if n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE then + aux (new Gdome.element_of_node n)) + in + aux doc#get_documentElement ; + !highlighted +;; + +let dim_nodes = + List.iter + (function (n : Gdome.node) -> + assert + (n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE && + ((new Gdome.element_of_node n)#getAttributeNS + ~namespaceURI:ds_xmldiffns + ~localName:ds_type)#equals ds_fake) ; + let true_child = + match n#get_firstChild with + None -> assert false + | Some n -> n in + let p = + match n#get_parentNode with + None -> assert false + | Some n -> n + in + ignore (p#replaceChild ~oldChild:n ~newChild:true_child) + ) +;; + +let update_dom ~(from : Gdome.document) (d : Gdome.document) = + let rec aux (p: Gdome.node) (f: Gdome.node) (t: Gdome.node) = + let replace t1 = + if + t1 = GdomeNodeTypeT.ELEMENT_NODE && + ((new Gdome.element_of_node f)#getAttributeNS + ~namespaceURI:ds_xmldiffns + ~localName:ds_type)#equals ds_fake + then + let true_child = + match f#get_firstChild with + None -> assert false + | Some n -> n + in + begin + ignore (p#replaceChild ~oldChild:f ~newChild:true_child) ; + aux p true_child t + end + else + let t' = from#importNode t true in + ignore (p#replaceChild ~newChild:t' ~oldChild:f) ; + (* ignore (highlight_node from t') *) + in + match + f#get_nodeType,t#get_nodeType + with + GdomeNodeTypeT.TEXT_NODE,GdomeNodeTypeT.TEXT_NODE -> + (match f#get_nodeValue, t#get_nodeValue with + Some v, Some v' when v#equals v' -> () + | Some _, (Some _ as v') -> f#set_nodeValue v' + | _,_ -> assert false) + | GdomeNodeTypeT.ELEMENT_NODE as t1,GdomeNodeTypeT.ELEMENT_NODE -> + (match + f#get_namespaceURI,t#get_namespaceURI,f#get_localName,t#get_localName + with + Some nu, Some nu', Some ln, Some ln' when + ln#equals ln' && nu#equals nu' -> + begin + match f#get_attributes, t#get_attributes with + Some fattrs, Some tattrs -> + let flen = fattrs#get_length in + let tlen = tattrs#get_length in + let processed = ref [] in + for i = 0 to flen -1 do + match fattrs#item i with + None -> () (* CSC: sigh, togliere un nodo rompe fa decrescere la lunghezza ==> passare a un while *) + | Some attr -> + match attr#get_namespaceURI with + None -> + (* Back to DOM Level 1 ;-( *) + begin + let name = attr#get_nodeName in + match tattrs#getNamedItem ~name with + None -> + ignore (fattrs#removeNamedItem ~name) + | Some attr' -> + processed := + (None,Some name)::!processed ; + match attr#get_nodeValue, attr'#get_nodeValue with + Some v1, Some v2 when + v1#equals v2 + || (name#equals ds_selection && + nu#equals ds_mathmlns && + ln#equals ds_maction) + -> + () + | Some v1, Some v2 -> + let attr'' = from#importNode attr' true in + ignore (fattrs#setNamedItem attr'') + | _,_ -> assert false + end + | Some namespaceURI -> + let localName = + match attr#get_localName with + Some v -> v + | None -> assert false + in + match + tattrs#getNamedItemNS ~namespaceURI ~localName + with + None -> + ignore + (fattrs#removeNamedItemNS + ~namespaceURI ~localName) + | Some attr' -> + processed := + (Some namespaceURI,Some localName)::!processed ; + match attr#get_nodeValue, attr'#get_nodeValue with + Some v1, Some v2 when + v1#equals v2 -> + () + | Some _, Some _ -> + let attr'' = from#importNode attr' true in + ignore (fattrs#setNamedItem attr'') + | _,_ -> assert false + done ; + for i = 0 to tlen -1 do + match tattrs#item i with + None -> assert false + | Some attr -> + let namespaceURI,localName = + match attr#get_namespaceURI with + None -> + None,attr#get_nodeName + | Some namespaceURI as v -> + v, match attr#get_localName with + None -> assert false + | Some v -> v + in + if + not + (List.exists + (function + None,Some localName' -> + (match namespaceURI with + None -> + localName#equals localName' + | Some _ -> false) + | Some namespaceURI', Some localName' -> + (match namespaceURI with + None -> false + | Some namespaceURI -> + localName#equals localName' && + namespaceURI#equals namespaceURI' + ) + | _,_ -> assert false + ) !processed) + then + let attr' = from#importNode attr false in + ignore (fattrs#setNamedItem attr') + done + | _,_ -> assert false + end ; + let rec dumb_diff = + function + [],[] -> () + | he1::tl1,he2::tl2 -> + aux f he1 he2 ; + dumb_diff (tl1,tl2) + | [],tl2 -> + List.iter + (function n -> + let n' = from#importNode n true in + ignore (f#appendChild n') ; + (* ignore (highlight_node from n') *) + () + ) tl2 + | tl1,[] -> + List.iter (function n -> ignore (f#removeChild n)) tl1 + in + let node_list_of_nodeList n = + let rec aux = + function + None -> [] + | Some n when + n#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE + or n#get_nodeType = GdomeNodeTypeT.TEXT_NODE -> + n::(aux n#get_nextSibling) + | Some n -> + aux n#get_nextSibling + in + aux n#get_firstChild + in + dumb_diff + (node_list_of_nodeList f, node_list_of_nodeList t) + | _,_,_,_ -> replace t1 + ) + | t1,t2 when + (t1 = GdomeNodeTypeT.ELEMENT_NODE || t1 = GdomeNodeTypeT.TEXT_NODE) && + (t2 = GdomeNodeTypeT.ELEMENT_NODE || t2 = GdomeNodeTypeT.TEXT_NODE) -> + replace t1 + | _,_ -> assert false + in + try + aux (d :> Gdome.node) + (from#get_documentElement :> Gdome.node) + (d#get_documentElement :> Gdome.node) + with + (GdomeInit.DOMException (e,msg) as ex) -> raise ex + | e -> raise e +;; diff --git a/helm/software/components/xmldiff/xmlDiff.mli b/helm/software/components/xmldiff/xmlDiff.mli new file mode 100644 index 000000000..cf084af94 --- /dev/null +++ b/helm/software/components/xmldiff/xmlDiff.mli @@ -0,0 +1,30 @@ +(* 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 update_dom: from: Gdome.document -> Gdome.document -> unit + +type highlighted_nodes +val highlight_nodes: xrefs:(string list) -> Gdome.document -> highlighted_nodes +val dim_nodes: highlighted_nodes -> unit diff --git a/helm/software/matita/.depend b/helm/software/matita/.depend new file mode 100644 index 000000000..06c32e01d --- /dev/null +++ b/helm/software/matita/.depend @@ -0,0 +1,59 @@ +applyTransformation.cmo: applyTransformation.cmi +applyTransformation.cmx: applyTransformation.cmi +buildTimeConf.cmo: buildTimeConf.cmi +buildTimeConf.cmx: buildTimeConf.cmi +dump_moo.cmo: buildTimeConf.cmi +dump_moo.cmx: buildTimeConf.cmx +matitaclean.cmo: matitaInit.cmi matitaclean.cmi +matitaclean.cmx: matitaInit.cmx matitaclean.cmi +matitacLib.cmo: matitaInit.cmi matitaExcPp.cmi matitaEngine.cmi \ + buildTimeConf.cmi matitacLib.cmi +matitacLib.cmx: matitaInit.cmx matitaExcPp.cmx matitaEngine.cmx \ + buildTimeConf.cmx matitacLib.cmi +matitac.cmo: matitamake.cmo matitadep.cmi matitaclean.cmi matitacLib.cmi +matitac.cmx: matitamake.cmx matitadep.cmx matitaclean.cmx matitacLib.cmx +matitadep.cmo: matitaInit.cmi matitadep.cmi +matitadep.cmx: matitaInit.cmx matitadep.cmi +matitaEngine.cmo: matitaEngine.cmi +matitaEngine.cmx: matitaEngine.cmi +matitaExcPp.cmo: matitaExcPp.cmi +matitaExcPp.cmx: matitaExcPp.cmi +matitaGeneratedGui.cmo: matitaGeneratedGui.cmi +matitaGeneratedGui.cmx: matitaGeneratedGui.cmi +matitaGtkMisc.cmo: matitaTypes.cmi matitaGeneratedGui.cmi matitaGtkMisc.cmi +matitaGtkMisc.cmx: matitaTypes.cmx matitaGeneratedGui.cmx matitaGtkMisc.cmi +matitaGui.cmo: matitamakeLib.cmi matitaTypes.cmi matitaScript.cmi \ + matitaMisc.cmi matitaMathView.cmi matitaGtkMisc.cmi \ + matitaGeneratedGui.cmi matitaExcPp.cmi buildTimeConf.cmi matitaGui.cmi +matitaGui.cmx: matitamakeLib.cmx matitaTypes.cmx matitaScript.cmx \ + matitaMisc.cmx matitaMathView.cmx matitaGtkMisc.cmx \ + matitaGeneratedGui.cmx matitaExcPp.cmx buildTimeConf.cmx matitaGui.cmi +matitaInit.cmo: matitamakeLib.cmi buildTimeConf.cmi matitaInit.cmi +matitaInit.cmx: matitamakeLib.cmx buildTimeConf.cmx matitaInit.cmi +matitamakeLib.cmo: buildTimeConf.cmi matitamakeLib.cmi +matitamakeLib.cmx: buildTimeConf.cmx matitamakeLib.cmi +matitamake.cmo: matitamakeLib.cmi matitaInit.cmi +matitamake.cmx: matitamakeLib.cmx matitaInit.cmx +matitaMathView.cmo: matitaTypes.cmi matitaScript.cmi matitaMisc.cmi \ + matitaGuiTypes.cmi matitaGtkMisc.cmi matitaExcPp.cmi buildTimeConf.cmi \ + applyTransformation.cmi matitaMathView.cmi +matitaMathView.cmx: matitaTypes.cmx matitaScript.cmx matitaMisc.cmx \ + matitaGuiTypes.cmi matitaGtkMisc.cmx matitaExcPp.cmx buildTimeConf.cmx \ + applyTransformation.cmx matitaMathView.cmi +matitaMisc.cmo: buildTimeConf.cmi matitaMisc.cmi +matitaMisc.cmx: buildTimeConf.cmx matitaMisc.cmi +matita.cmo: matitaTypes.cmi matitaScript.cmi matitaMathView.cmi \ + matitaInit.cmi matitaGui.cmi matitaGtkMisc.cmi buildTimeConf.cmi +matita.cmx: matitaTypes.cmx matitaScript.cmx matitaMathView.cmx \ + matitaInit.cmx matitaGui.cmx matitaGtkMisc.cmx buildTimeConf.cmx +matitaScript.cmo: matitamakeLib.cmi matitaTypes.cmi matitaMisc.cmi \ + matitaEngine.cmi buildTimeConf.cmi matitaScript.cmi +matitaScript.cmx: matitamakeLib.cmx matitaTypes.cmx matitaMisc.cmx \ + matitaEngine.cmx buildTimeConf.cmx matitaScript.cmi +matitaTypes.cmo: matitaTypes.cmi +matitaTypes.cmx: matitaTypes.cmi +matitaGtkMisc.cmi: matitaGeneratedGui.cmi +matitaGui.cmi: matitaGuiTypes.cmi +matitaGuiTypes.cmi: matitaTypes.cmi matitaGeneratedGui.cmi +matitaMathView.cmi: matitaTypes.cmi matitaGuiTypes.cmi +matitaScript.cmi: matitaTypes.cmi diff --git a/helm/software/matita/.ocamlinit b/helm/software/matita/.ocamlinit new file mode 100644 index 000000000..1585f71b2 --- /dev/null +++ b/helm/software/matita/.ocamlinit @@ -0,0 +1,44 @@ +(* directories *) +#directory "../ocaml/cic" +#directory "../ocaml/cic_notation" +#directory "../ocaml/cic_omdoc" +#directory "../ocaml/cic_proof_checking" +#directory "../ocaml/cic_textual_parser2" +#directory "../ocaml/cic_transformations" +#directory "../ocaml/cic_unification" +#directory "../ocaml/getter" +#directory "../ocaml/hbugs" +#directory "../ocaml/mathql" +#directory "../ocaml/mathql_generator" +#directory "../ocaml/mathql_interpreter" +#directory "../ocaml/metadata" +#directory "../ocaml/paramodulation" +#directory "../ocaml/registry" +#directory "../ocaml/tactics" +#directory "../ocaml/thread" +#directory "../ocaml/urimanager" +#directory "../ocaml/xml" +#directory "../ocaml/xmldiff" + +(* custom printers *) +let fppuri ppf uri = + let s = UriManager.string_of_uri uri in + Format.pp_print_string ppf s +;; + +#install_printer CicMetaSubst.fppsubst;; +#install_printer CicMetaSubst.fppterm;; +#install_printer CicMetaSubst.fppmetasenv;; +#install_printer fppuri;; + +(* utility functions *) +let go = MatitacLib.interactive_loop;; + +(* let's go! *) +let _ = + at_exit (fun () -> MatitacLib.clean_exit None); + if Array.length Sys.argv > 1 then + MatitacLib.main `TOPLEVEL + else + MatitacLib.go () +;; diff --git a/helm/software/matita/AUTHORS b/helm/software/matita/AUTHORS new file mode 100644 index 000000000..a2da427a5 --- /dev/null +++ b/helm/software/matita/AUTHORS @@ -0,0 +1,5 @@ +Andrea Asperti +Luca Padovani +Enrico Tassi +Claudio Sacerdoti Coen +Stefano Zacchiroli diff --git a/helm/software/matita/LICENSE b/helm/software/matita/LICENSE new file mode 100644 index 000000000..7665cd2ce --- /dev/null +++ b/helm/software/matita/LICENSE @@ -0,0 +1,23 @@ +Copyright (C) 2000-2005, HELM Team. + +Matita 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/ diff --git a/helm/software/matita/Makefile b/helm/software/matita/Makefile new file mode 100644 index 000000000..75d878780 --- /dev/null +++ b/helm/software/matita/Makefile @@ -0,0 +1,338 @@ +export SHELL=/bin/bash + +include ../Makefile.defs + +NULL = +H=@ + +OCAML_FLAGS = -pp $(CAMLP4O) +PKGS = -package "$(MATITA_REQUIRES)" +CPKGS = -package "$(MATITA_CREQUIRES)" +OCAML_THREADS_FLAGS = -thread +OCAML_DEBUG_FLAGS = -g +OCAMLC_FLAGS = $(OCAML_FLAGS) $(OCAML_THREADS_FLAGS) +OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLC_FLAGS) $(OCAML_DEBUG_FLAGS) +OCAMLOPT = $(OCAMLFIND) opt $(OCAMLC_FLAGS) +OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAML_FLAGS) + +MATITA_FLAGS = -noprofile +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +# objects for matita (GTK GUI) +CMOS = \ + buildTimeConf.cmo \ + matitaTypes.cmo \ + matitaMisc.cmo \ + matitamakeLib.cmo \ + matitaInit.cmo \ + matitaExcPp.cmo \ + matitaEngine.cmo \ + matitacLib.cmo \ + matitaScript.cmo \ + matitaGeneratedGui.cmo \ + matitaGtkMisc.cmo \ + applyTransformation.cmo \ + matitaMathView.cmo \ + matitaGui.cmo \ + $(NULL) +# objects for matitac (batch compiler) +CCMOS = \ + buildTimeConf.cmo \ + matitaTypes.cmo \ + matitaMisc.cmo \ + matitamakeLib.cmo \ + matitaInit.cmo \ + matitaExcPp.cmo \ + matitaEngine.cmo \ + matitacLib.cmo \ + $(NULL) +MAINCMOS = \ + matitadep.cmo \ + matitaclean.cmo \ + matitamake.cmo \ + $(NULL) +PROGRAMS_BYTE = matita matitac cicbrowser matitadep matitaclean matitamake dump_moo +PROGRAMS = $(PROGRAMS_BYTE) matitatop +PROGRAMS_OPT = $(patsubst %,%.opt,$(PROGRAMS_BYTE)) + +.PHONY: all +all: $(PROGRAMS) +# all: matita.conf.xml $(PROGRAMS) coq.moo + +# matita.conf.xml: matita.conf.xml.sample +# @if diff matita.conf.xml.sample matita.conf.xml 1>/dev/null 2>/dev/null; then\ +# touch matita.conf.xml;\ +# else\ +# echo;\ +# echo "matita.conf.xml.sample is newer than matita.conf.xml";\ +# echo;\ +# echo "PLEASE update your configuration file!";\ +# echo "(copying matita.conf.xml.sample should work)";\ +# echo;\ +# false;\ +# fi + +# coq.moo: library/legacy/coq.ma matitac +# ./matitac $(MATITA_FLAGS) $< +# coq.moo.opt: library/legacy/coq.ma matitac.opt +# ./matitac.opt $(MATITA_FLAGS) $< + +ifeq ($(HAVE_OCAMLOPT),yes) + +CMXS = $(patsubst %.cmo,%.cmx,$(CMOS)) +CCMXS = $(patsubst %.cmo,%.cmx,$(CCMOS)) +MAINCMXS = $(patsubst %.cmo,%.cmx,$(MAINCMOS)) +LIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_REQUIRES)) +LIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_REQUIRES)) +CLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_CREQUIRES)) +CLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_CREQUIRES)) +.PHONY: opt +opt: $(PROGRAMS_OPT) coq.moo.opt +.PHONY: upx +upx: $(PROGRAMS_UPX) coq.moo.opt + +else + +opt: + @echo "Native code compilation is disabled" + +endif + +matita: matita.ml $(LIB_DEPS) $(CMOS) + @echo "OCAMLC $<" + $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ $(CMOS) matita.ml +matita.opt: matita.ml $(LIBX_DEPS) $(CMXS) + @echo "OCAMLOPT $<" + $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml + +dump_moo: dump_moo.ml buildTimeConf.cmo + @echo "OCAMLC $<" + $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ buildTimeConf.cmo $< +dump_moo.opt: dump_moo.ml buildTimeConf.cmx + @echo "OCAMLOPT $<" + $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ buildTimeConf.cmx $< + +matitac: matitac.ml $(CLIB_DEPS) $(CCMOS) $(MAINCMOS) + @echo "OCAMLC $<" + $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ $(CCMOS) $(MAINCMOS) matitac.ml +matitac.opt: matitac.ml $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) + @echo "OCAMLOPT $<" + $(H)$(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml + +matitatop: matitatop.ml $(CLIB_DEPS) $(CCMOS) + @echo "OCAMLC $<" + $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ toplevellib.cma $(CCMOS) $< + +matitadep: matitac + @test -f $@ || ln -s $< $@ +matitadep.opt: matitac.opt + @test -f $@ || ln -s $< $@ + +matitaclean: matitac + @test -f $@ || ln -s $< $@ +matitaclean.opt: matitac.opt + @test -f $@ || ln -s $< $@ + +matitamake: matitac + @test -f $@ || ln -s $< $@ +matitamake.opt: matitac.opt + @test -f $@ || ln -s $< $@ + +cicbrowser: matita + @test -f $@ || ln -s $< $@ +cicbrowser.opt: matita.opt + @test -f $@ || ln -s $< $@ + +matitaGeneratedGui.ml matitaGeneratedGui.mli: matita.glade + $(LABLGLADECC) -embed $< > matitaGeneratedGui.ml + $(OCAMLC) $(PKGS) -i matitaGeneratedGui.ml > matitaGeneratedGui.mli + +.PHONY: clean +clean: + rm -rf *.cma *.cmo *.cmi *.cmx *.cmxa *.a *.o \ + $(PROGRAMS) \ + $(PROGRAMS_OPT) \ + $(PROGRAMS_STATIC) \ + $(PROGRAMS_UPX) \ + $(NULL) + +TEST_DIRS = \ + library \ + tests \ + tests/bad_tests \ + contribs/LAMBDA-TYPES \ + contribs/PREDICATIVE-TOPOLOGY \ + $(NULL) + +.PHONY: tests tests.opt cleantests cleantests.opt +tests: $(foreach d,$(TEST_DIRS),$(d)-test) +tests.opt: $(foreach d,$(TEST_DIRS),$(d)-test-opt) +cleantests: $(foreach d,$(TEST_DIRS),$(d)-cleantests) +cleantests.opt: $(foreach d,$(TEST_DIRS),$(d)-cleantests-opt) + +%-test: matitac matitadep matitaclean coq.moo + -cd $* && make -k clean all +%-test-opt: matitac.opt matitadep.opt matitaclean.opt coq.moo.opt + -cd $* && make -k clean.opt opt +%-cleantests: matitaclean + -cd $* && make clean +%-cleantests-opt: matitaclean.opt + -cd $* && make clean.opt + +# {{{ Distribution stuff + +ifeq ($(wildcard matitac.opt),matitac.opt) +BEST=opt +else +BEST=all +endif + +stdlib: + MATITA_RT_BASE_DIR=`pwd` \ + MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" \ + ./matitamake -init build_stdlib + +# MATITA_RT_BASE_DIR=`pwd` \ + $(MAKE) MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" -C library/ $(BEST) + +DEST = @RT_BASE_DIR@ +INSTALL_STUFF = \ + icons/ \ + matita.gtkrc \ + matita.lang \ + matita.ma.templ \ + core_notation.moo \ + matita.conf.xml \ + closed.xml \ + gtkmathview.matita.conf.xml \ + template_makefile.in \ + library/ \ + $(PROGRAMS_BYTE) \ + $(NULL) +ifeq ($(HAVE_OCAMLOPT),yes) +INSTALL_STUFF += $(PROGRAMS_OPT) +endif + +install: + install -d $(DEST) + cp -a .matita/ + cp -a $(INSTALL_STUFF) $(DEST) +uninstall: + +STATIC_LINK = dist/static_link/static_link +# for matita +STATIC_LIBS = \ + t1 t1x \ + gtkmathview_gmetadom mathview mathview_backend_gtk mathview_frontend_gmetadom \ + gtksourceview-1.0 \ + gdome gmetadom_gdome_cpp_smart \ + stdc++ \ + mysqlclient \ + expat \ + $(NULL) +STATIC_EXTRA_LIBS = -cclib -lt1x -cclib -lstdc++ +# for matitac & co +STATIC_CLIBS = \ + gdome \ + mysqlclient \ + $(NULL) +STATIC_EXTRA_CLIBS = +PROGRAMS_STATIC = $(patsubst %,%.static,$(PROGRAMS_OPT)) +PROGRAMS_UPX = $(patsubst %,%.upx,$(PROGRAMS_STATIC)) + +ifeq ($(HAVE_OCAMLOPT),yes) +static: $(STATIC_LINK) $(PROGRAMS_STATIC) coq.moo.opt +else +upx: + @echo "Native code compilation is disabled" +static: + @echo "Native code compilation is disabled" +endif + +$(STATIC_LINK): + $(MAKE) -C dist/ $(STATIC_LINK) + +matita.opt.static: $(STATIC_LINK) $(LIBX_DEPS) $(CMXS) matita.ml + $(STATIC_LINK) $(STATIC_LIBS) -- \ + $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml \ + $(STATIC_EXTRA_LIBS) + strip $@ +dump_moo.opt.static: $(STATIC_LINK) buildTimeConf.cmx dump_moo.ml + $(STATIC_LINK) $(STATIC_CLIBS) -- \ + $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $^ \ + $(STATIC_EXTRA_CLIBS) + strip $@ +matitac.opt.static: $(STATIC_LINK) $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) matitac.ml + $(STATIC_LINK) $(STATIC_CLIBS) -- \ + $(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml \ + $(STATIC_EXTRA_CLIBS) + strip $@ +matitadep.opt.static: matitac.opt.static + @test -f $@ || ln -s $< $@ +matitaclean.opt.static: matitac.opt.static + @test -f $@ || ln -s $< $@ +matitamake.opt.static: matitac.opt.static + @test -f $@ || ln -s $< $@ +cicbrowser.opt.static: matita.opt.static + @test -f $@ || ln -s $< $@ +cicbrowser.opt.static.upx: matita.opt.static.upx + @test -f $@ || ln -s $< $@ + +.PHONY: distclean +distclean: clean + $(MAKE) -C dist/ clean + rm -f matitaGeneratedGui.ml matitaGeneratedGui.mli + rm -f buildTimeConf.ml + rm -f matita.glade.bak matita.gladep.bak + rm -f matita.conf.xml.sample + +%.upx: % + cp $< $@ + strip $@ + upx $@ + +# }}} End of distribution stuff + +tags: TAGS +.PHONY: TAGS +TAGS: + cd ..; otags -vi -r ocaml/ matita/ + +#.depend: matitaGeneratedGui.ml matitaGeneratedGui.mli *.ml *.mli + +.PHONY: depend +depend: + $(OCAMLDEP) *.ml *.mli > .depend + +include .depend + +%.cmi: %.mli + @echo "OCAMLC $<" + $(H)$(OCAMLC) $(PKGS) -c $< +%.cmo %.cmi: %.ml + @echo "OCAMLC $<" + $(H)$(OCAMLC) $(PKGS) -c $< +%.cmx: %.ml + @echo "OCAMLOPT $<" + $(H)$(OCAMLOPT) $(PKGS) -c $< +%.annot: %.ml + @echo "OCAMLC -dtypes $<" + $(H)$(OCAMLC) -dtypes $(PKGS) -c $< + +$(CMOS): $(LIB_DEPS) +$(CMOS:%.cmo=%.cmx): $(LIBX_DEPS) + +ifeq ($(MAKECMDGOALS),all) + $(CMOS:%.cmo=%.cmi): $(LIB_DEPS) +endif +ifeq ($(MAKECMDGOALS),) + $(CMOS:%.cmo=%.cmi): $(LIB_DEPS) +endif +ifeq ($(MAKECMDGOALS),opt) + $(CMOS:%.cmo=%.cmi): $(LIBX_DEPS) +endif + +# vim: set foldmethod=marker: diff --git a/helm/software/matita/applyTransformation.ml b/helm/software/matita/applyTransformation.ml new file mode 100644 index 000000000..83e5f3c18 --- /dev/null +++ b/helm/software/matita/applyTransformation.ml @@ -0,0 +1,72 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 21/11/2003 *) +(* *) +(* *) +(***************************************************************************) + +(* $Id$ *) + +let mpres_document pres_box = + Xml.add_xml_declaration (CicNotationPres.print_box pres_box) + +let mml_of_cic_sequent metasenv sequent = + let unsh_sequent,(asequent,ids_to_terms, + ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses) + = + Cic2acic.asequent_of_sequent metasenv sequent + in + let content_sequent = Acic2content.map_sequent asequent in + let pres_sequent = + (Sequent2pres.sequent2pres ~ids_to_inner_sorts content_sequent) + in + let xmlpres = mpres_document pres_sequent in + (Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres, + unsh_sequent, + (asequent, + (ids_to_terms,ids_to_father_ids,ids_to_hypotheses,ids_to_inner_sorts))) + +let mml_of_cic_object obj = + let (annobj, 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 content = + Acic2content.annobj2content ~ids_to_inner_sorts ~ids_to_inner_types annobj + in + let pres = Content2pres.content2pres ~ids_to_inner_sorts content in + let xmlpres = mpres_document pres in + let mathml = Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres in + (mathml,(annobj, + (ids_to_terms, ids_to_father_ids, ids_to_conjectures, ids_to_hypotheses, + ids_to_inner_sorts,ids_to_inner_types))) + diff --git a/helm/software/matita/applyTransformation.mli b/helm/software/matita/applyTransformation.mli new file mode 100644 index 000000000..8e023aea6 --- /dev/null +++ b/helm/software/matita/applyTransformation.mli @@ -0,0 +1,57 @@ +(* 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 *) +(* *) +(* Andrea Asperti *) +(* 21/11/2003 *) +(* *) +(* *) +(***************************************************************************) + +val mml_of_cic_sequent: + Cic.metasenv -> (* metasenv *) + Cic.conjecture -> (* sequent *) + Gdome.document * (* Math ML *) + Cic.conjecture * (* unshared sequent *) + (Cic.annconjecture * (* annsequent *) + ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) + (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) + (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) + (Cic.id, Cic2acic.sort_kind) Hashtbl.t)) (* ids_to_inner_sorts *) + +val mml_of_cic_object: + Cic.obj -> (* object *) + Gdome.document * (* Math ML *) + (Cic.annobj * (* annobj *) + ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) + (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) + (Cic.id, Cic.conjecture) Hashtbl.t * (* id -> conjecture *) + (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) + (Cic.id, Cic2acic.sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) + (Cic.id, Cic2acic.anntypes) Hashtbl.t)) (* ids_to_inner_types *) + diff --git a/helm/software/matita/buildTimeConf.ml.in b/helm/software/matita/buildTimeConf.ml.in new file mode 100644 index 000000000..8ea2c7b86 --- /dev/null +++ b/helm/software/matita/buildTimeConf.ml.in @@ -0,0 +1,55 @@ +(* Copyright (C) 2004, 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://helm.cs.unibo.it/ + *) + +let debug = @DEBUG@;; +let version = "@MATITA_VERSION@";; +let undo_history_size = 10;; +let console_history_size = 100;; +let browser_history_size = 100;; +let base_uri = "cic:/matita";; +let phrase_sep = ".";; +let blank_uri = "about:blank";; +let current_proof_uri = "about:current_proof";; +let default_font_size = 10;; +let script_font = "Monospace";; + + (** may be overridden with MATITA_RT_BASE_DIR environment variable, useful for + * binary distribution installed in user home directories *) +let runtime_base_dir = + try + Sys.getenv "MATITA_RT_BASE_DIR" + with Not_found -> "@RT_BASE_DIR@";; + +let images_dir = runtime_base_dir ^ "/icons" +let gtkrc_file = runtime_base_dir ^ "/matita.gtkrc" +let lang_file = runtime_base_dir ^ "/matita.lang" +let script_template = runtime_base_dir ^ "/matita.ma.templ" +let core_notation_script = runtime_base_dir ^ "/core_notation.moo" +let matita_conf = runtime_base_dir ^ "/matita.conf.xml" +let closed_xml = runtime_base_dir ^ "/closed.xml" +let gtkmathview_conf = runtime_base_dir ^ "/gtkmathview.matita.conf.xml" +let matitamake_makefile_template = runtime_base_dir ^ "/template_makefile.in" +let stdlib_dir = runtime_base_dir ^ "/library" + diff --git a/helm/software/matita/buildTimeConf.mli b/helm/software/matita/buildTimeConf.mli new file mode 100644 index 000000000..09a927fc6 --- /dev/null +++ b/helm/software/matita/buildTimeConf.mli @@ -0,0 +1,50 @@ +(* Copyright (C) 2006, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +val base_uri : string +val blank_uri : string +val browser_history_size : int +val closed_xml : string +val console_history_size : int +val core_notation_script : string +val current_proof_uri : string +val debug : bool +val default_font_size : int +val gtkmathview_conf : string +val gtkrc_file : string +val images_dir : string +val lang_file : string +val matita_conf : string +val matitamake_makefile_template : string +val phrase_sep : string +val runtime_base_dir : string +val script_font : string +val script_template : string +val stdlib_dir : string +val undo_history_size : int +val version : string + diff --git a/helm/software/matita/closed.xml b/helm/software/matita/closed.xml new file mode 100644 index 000000000..d3125efb7 --- /dev/null +++ b/helm/software/matita/closed.xml @@ -0,0 +1,17 @@ + + + + + + + + + + + + This goal has already been closed. + Use the "skip" command to throw it away. + + + + diff --git a/helm/software/matita/contribs/LAMBDA-TYPES/Makefile b/helm/software/matita/contribs/LAMBDA-TYPES/Makefile new file mode 100644 index 000000000..5b2b2fa40 --- /dev/null +++ b/helm/software/matita/contribs/LAMBDA-TYPES/Makefile @@ -0,0 +1,57 @@ +SRC=$(shell find . -name "*.ma" -a -type f) + +MATITA_FLAGS = -I ../.. +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +MATITAC=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac $(MATITA_FLAGS)" "../../matitaclean $(MATITA_FLAGS)" /dev/null OK +MATITACOPT=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac.opt $(MATITA_FLAGS)" "../../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK +VERBOSEMATITAC=../../matitac $(MATITA_FLAGS) +VERBOSEMATITACOPT=../../matitac.opt $(MATITA_FLAGS) + +MATITACLEAN=../../matitaclean $(MATITA_FLAGS) +MATITACLEANOPT=../../matitaclean.opt $(MATITA_FLAGS) + +MATITADEP=../../matitadep $(MATITA_FLAGS) +MATITADEPOPT=../../matitadep.opt $(MATITA_FLAGS) + +DEPEND_NAME=.depend + +H=@ + +all: $(SRC:%.ma=%.mo) + +opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all + +verbose: + $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all + +%.opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) + +clean_: + $(H)rm -f __*not_for_matita + +clean: clean_ + $(H)$(MATITACLEAN) $(SRC) + +cleanall: clean_ + $(H)rm -f $(SRC:%.ma=%.moo) + $(H)$(MATITACLEAN) all + +depend: + $(H)rm -f $(DEPEND_NAME) + $(H)$(MAKE) $(DEPEND_NAME) +.PHONY: depend + +%.moo: + $(H)$(MATITAC) $< + +$(DEPEND_NAME): $(SRC) + $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ + +#include $(DEPEND_NAME) +include .depend diff --git a/helm/software/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma b/helm/software/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma new file mode 100644 index 000000000..572618808 --- /dev/null +++ b/helm/software/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma @@ -0,0 +1,22 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/LAMBDA-TYPES/lref_map_defs". + +include "terms_defs.ma". + +inductive tlref_map (A: Set) (N: Set) (map: nat \to nat): nat \to (T A N) \to (T A N) \to Prop \def + | tlref_map_sort: \forall i. \forall k. \forall y. (tlref_map A N map i (TSort A N y k) (TSort A N y k)) + | tlref_map_lref_lt: \forall j. \forall i. \forall y. j < i \to (tlref_map A N map i (TLRef A N y j) (TLRef A N y j)) + | tlref_map_lref_ge: \forall j. \forall i. \forall y. i \le j \to (tlref_map A N map i (TLRef A N y j) (TLRef A N y (map j))). diff --git a/helm/software/matita/contribs/LAMBDA-TYPES/terms_defs.ma b/helm/software/matita/contribs/LAMBDA-TYPES/terms_defs.ma new file mode 100644 index 000000000..cf7848abe --- /dev/null +++ b/helm/software/matita/contribs/LAMBDA-TYPES/terms_defs.ma @@ -0,0 +1,47 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/LAMBDA-TYPES/terms_defs". + +include "legacy/coq.ma". + +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +alias id "plus" = "cic:/Coq/Init/Peano/plus.con". +alias id "lt" = "cic:/Coq/Init/Peano/lt.con". +alias id "le" = "cic:/Coq/Init/Peano/le.ind#xpointer(1/1)". + +inductive B : Set \def + | Void: B + | Abbr: B + | Abst: B. + +inductive F : Set \def + | Appl: F + | Cast: F. + +inductive W : Set \def + | Bind: B \to W + | Flat: F \to W. + +inductive T (A:Set) (N:Set) : Set \def + | TSort: A \to nat \to (T A N) + | TLRef: A \to nat \to (T A N) + | TWag : A \to W \to (T A N) \to (T A N) \to (T A N) + | TGRef: A \to N \to (T A N). + +record X (A:Set) (N:Set) : Type \def { + get_gref: N \to B \to (T A N) \to Prop +}. diff --git a/helm/software/matita/contribs/LAMBDA-TYPES/tlt_defs.ma b/helm/software/matita/contribs/LAMBDA-TYPES/tlt_defs.ma new file mode 100644 index 000000000..390c067cc --- /dev/null +++ b/helm/software/matita/contribs/LAMBDA-TYPES/tlt_defs.ma @@ -0,0 +1,53 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/LAMBDA-TYPES/tlt_defs". + +include "terms_defs.ma". + +definition wadd: (nat \to nat) \to nat \to (nat \to nat) \def + \lambda map,w,n. + match n with [ + O \Rightarrow w + | (S m) \Rightarrow (map m) + ]. + +let rec weight_map (A:Set) (N:Set) (map:nat \to nat) (t:T A N) on t : nat \def + match t with [ + (TSort y k) \Rightarrow O + | (TLRef y i) \Rightarrow (map i) + | (TWag y z w u) \Rightarrow + match z with [ + (Bind b) \Rightarrow + match b with [ + Abbr \Rightarrow + (S ((weight_map A N map w) + (weight_map A N (wadd map (S (weight_map A N map w))) u))) + | Abst \Rightarrow + (S ((weight_map A N map w) + (weight_map A N (wadd map O) u))) + | Void \Rightarrow + (S ((weight_map A N map w) + (weight_map A N (wadd map O) u))) + ] + | (Flat a) \Rightarrow + (S ((weight_map A N map w) + (weight_map A N map u))) + ] + | (TGRef y n) \Rightarrow O + ]. + +definition weight: \forall A,N. T A N \to nat \def + \lambda A,N. + (weight_map A N (\lambda _.O)). + +definition tlt: \forall A,N. T A N \to T A N \to Prop \def + \lambda A,N,t1,t2. + weight A N t1 < weight A N t2. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile new file mode 100644 index 000000000..489b2c135 --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile @@ -0,0 +1,57 @@ +SRC=$(shell find . -name "*.ma" -a -type f) + +MATITA_FLAGS = +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +MATITAC=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac $(MATITA_FLAGS)" "../../matitaclean $(MATITA_FLAGS)" /dev/null OK +MATITACOPT=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac.opt $(MATITA_FLAGS)" "../../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK +VERBOSEMATITAC=../../matitac $(MATITA_FLAGS) +VERBOSEMATITACOPT=../../matitac.opt $(MATITA_FLAGS) + +MATITACLEAN=../../matitaclean $(MATITA_FLAGS) +MATITACLEANOPT=../../matitaclean.opt $(MATITA_FLAGS) + +MATITADEP=../../matitadep $(MATITA_FLAGS) +MATITADEPOPT=../../matitadep.opt $(MATITA_FLAGS) + +DEPEND_NAME=.depend + +H=@ + +all: $(SRC:%.ma=%.mo) + +opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all + +verbose: + $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all + +%.opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) + +clean_: + $(H)rm -f __*not_for_matita + +clean: clean_ + $(H)$(MATITACLEAN) $(SRC) + +cleanall: clean_ + $(H)rm -f $(SRC:%.ma=%.moo) + $(H)$(MATITACLEAN) all + +depend: + $(H)rm -f $(DEPEND_NAME) + $(H)$(MAKE) $(DEPEND_NAME) +.PHONY: depend + +%.moo: + $(H)$(MATITAC) $< + +$(DEPEND_NAME): $(SRC) + $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ + +#include $(DEPEND_NAME) +include .depend diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma new file mode 100644 index 000000000..17a53f64f --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma @@ -0,0 +1,51 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +(* Project started Wed Oct 12, 2005 ***************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/class_defs". + +include "../../library/logic/connectives.ma". + +(* ACZEL CATEGORIES: + - We use typoids with a compatible membership relation + - The category is intended to be the domain of the membership relation + - The membership relation is necessary because we need to regard the + domain of a propositional function (ie a predicative subset) as a + quantification domain and therefore as a category, but there is no + type in CIC representing the domain of a propositional function + - We set up a single equality predicate, parametric on the category, + defined as the reflexive, symmetic, transitive and compatible closure + of the cle1 predicate given inside the category. Then we prove the + properties of the equality that usually are axiomatized inside the + category structure. This makes categories easier to use +*) + +definition true_f \def \lambda (X:Type). \lambda (_:X). True. + +definition false_f \def \lambda (X:Type). \lambda (_:X). False. + +record Class: Type \def { + class:> Type; + cin: class \to Prop; + cle1: class \to class \to Prop +}. + +inductive cle (C:Class) (c1:C): C \to Prop \def + | cle_refl: cin ? c1 \to cle ? c1 c1 + | ceq_sing: \forall c2,c3. + cle ? c1 c2 \to cin ? c3 \to cle1 ? c2 c3 \to cle ? c1 c3. + +inductive ceq (C:Class) (c1:C) (c2:C): Prop \def + | ceq_intro: cle ? c1 c2 \to cle ? c2 c1 \to ceq ? c1 c2. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma new file mode 100644 index 000000000..cfcb57293 --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma @@ -0,0 +1,38 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/class_eq". + +include "class_le.ma". + +theorem ceq_cl: \forall C,c1,c2. ceq ? c1 c2 \to cin C c1 \land cin C c2. +intros; elim H; clear H. +lapply cle_cl to H1 using H; clear H1; decompose H; +lapply cle_cl to H2 using H; clear H2; decompose H. +auto. +qed. + +theorem ceq_refl: \forall C,c. cin C c \to ceq ? c c. +intros; apply ceq_intro; auto. +qed. + +theorem ceq_trans: \forall C,c2,c1,c3. + ceq C c2 c3 \to ceq ? c1 c2 \to ceq ? c1 c3. +intros; elim H; elim H1; clear H; clear H1. +apply ceq_intro; apply cle_trans; [|auto|auto||auto|auto]. +qed. + +theorem ceq_sym: \forall C,c1,c2. ceq C c1 c2 \to ceq C c2 c1. +intros; elim H; clear H.; auto. +qed. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma new file mode 100644 index 000000000..a688ec63b --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma @@ -0,0 +1,28 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/class_le". + +include "class_defs.ma". + +theorem cle_cl: \forall C,c1,c2. cle ? c1 c2 \to cin C c1 \land cin C c2. +intros; elim H; clear H; clear c2; + [| decompose H2 ]; auto. +qed. + +theorem cle_trans: \forall C,c1,c2. cle C c1 c2 \to + \forall c3. cle ? c3 c1 \to cle ? c3 c2. +intros 4; elim H; clear H; clear c2; + [| apply ceq_sing; [||| apply H4 ]]; auto. +qed. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma new file mode 100644 index 000000000..c840fbdaf --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma @@ -0,0 +1,61 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/coa_defs". + +include "iff.ma". +include "domain_data.ma". + +(* COMPLETE OVERLAP ALGEBRAS +*) + +record COA: Type \def { + coa:> Class; (* carrier *) + le: coa \to coa \to Prop; (* inclusion *) + ov: coa \to coa \to Prop; (* overlap *) + sup: \forall (D:Domain). (D \to coa) \to coa; (* supremum *) + inf: \forall (D:Domain). (D \to coa) \to coa; (* infimum *) + le_refl: \forall p. le p p; + le_trans: \forall p,r. le p r \to \forall q. le r q \to le p q; + le_antysym: \forall q,p. le q p \to le p q \to ceq ? p q; + ov_sym: \forall q,p. ov q p \to ov p q; + sup_le: \forall D,ps,q. le (sup D ps) q \liff \iforall d. le (ps d) q; + inf_le: \forall D,p,qs. le p (inf D qs) \liff \iforall d. le p (qs d); + sup_ov: \forall D,ps,q. ov (sup D ps) q \liff \iexists d. ov (ps d) q; + density: \forall p,q. (\forall r. ov p r \to ov q r) \to le p q +}. + +definition zero: \forall (P:COA). P \def + \lambda (P:COA). inf P ? (dvoid_ixfam P). + +definition one: \forall (P:COA). P \def + \lambda (P:COA). sup P ? (dvoid_ixfam P). + +definition binf: \forall (P:COA). P \to P \to P \def + \lambda (P:COA). \lambda p0,p1. + inf P ? (dbool_ixfam P p0 p1). + +definition bsup: \forall (P:COA). P \to P \to P \def + \lambda (P:COA). \lambda p0,p1. + sup P ? (dbool_ixfam P p0 p1). + +(* + inf_ov: forall p q, ov p q -> ov p (inf QDBool (bool_family _ p q)) + properness: ov zero zero -> False; + distributivity: forall I p q, id _ (inf QDBool (bool_family _ (sup I p) q)) (sup I (fun i => (inf QDBool (bool_family _ (p i) q)))); +*) + +inductive pippo : Prop \def + | Pippo: let x \def zero in zero = x \to pippo. + \ No newline at end of file diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma new file mode 100644 index 000000000..6c004073e --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma @@ -0,0 +1,29 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/coa_props". + +include "coa_defs.ma". + +inductive True:Prop \def T:True. + +theorem zero_le: + \forall (P:COA). \forall (p:P). (le ? (zero P) p) \to True. + intros. + exact T. +qed. + + + + diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma new file mode 100644 index 000000000..ed0afab4f --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma @@ -0,0 +1,40 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/domain_data". + +include "../../library/datatypes/constructors.ma". +include "../../library/datatypes/bool.ma". +include "domain_defs.ma". + +(* QUANTIFICATION DOMAINS + - Here we define some useful domains based on data types +*) + +definition DBool : Domain \def + mk_Domain (mk_Class bool (true_f ?) (eq ?)). + +definition dbool_ixfam : \forall (C:Class). C \to C \to (DBool \to C) \def + \lambda C,c0,c1,b. + match b in bool with + [ false \Rightarrow c0 + | true \Rightarrow c1 + ]. + +definition DVoid : Domain \def + mk_Domain (mk_Class void (true_f ?) (eq ?)). + +definition dvoid_ixfam : \forall (C:Class). (DVoid \to C) \def + \lambda C,v. + match v in void with []. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma new file mode 100644 index 000000000..68cbd01fa --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma @@ -0,0 +1,58 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/domain_defs". + +include "class_defs.ma". + +(* QUANTIFICATION DOMAINS + - These are the categories on which we allow quantification + - We set up single quantifiers, parametric on the domain, so they + already have the properties that usually are axiomatized inside the + domain structure. This makes domains easier to use +*) + +record Domain: Type \def { + qd:> Class +}. + +(* internal universal quantification *) +inductive dall (D:Domain) (P:D \to Prop) : Prop \def + | dall_intro: (\forall d:D. cin D d \to P d) \to dall D P. + +(* internal existential quantification *) +inductive dex (D:Domain) (P:D \to Prop) : Prop \def + | dex_intro: \forall d:D. cin D d \land P d \to dex D P. + +(* notations **************************************************************) + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "internal for all" 'iforall \eta.x = + (cic:/matita/PREDICATIVE-TOPOLOGY/domain_defs/dall.ind#xpointer(1/1) _ x). + +notation > "hvbox(\iforall ident i opt (: ty) break . p)" + right associative with precedence 20 +for @{ 'iforall ${default + @{\lambda ${ident i} : $ty. $p)} + @{\lambda ${ident i} . $p}}}. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "internal exists" 'dexists \eta.x = + (cic:/matita/PREDICATIVE-TOPOLOGY/domain_defs/dex.ind#xpointer(1/1) _ x). + +notation > "hvbox(\iexists ident i opt (: ty) break . p)" + right associative with precedence 20 +for @{ 'dexists ${default + @{\lambda ${ident i} : $ty. $p)} + @{\lambda ${ident i} . $p}}}. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma new file mode 100644 index 000000000..9a9491923 --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma @@ -0,0 +1,31 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/logic/iff". + +include "../../library/logic/connectives.ma". + +definition Iff : Prop \to Prop \to Prop \def + \lambda A,B. (A \to B) \land (B \to A). + + (*CSC: the URI must disappear: there is a bug now *) +interpretation "logical iff" 'iff x y = (cic:/matita/logic/iff/Iff.con x y). + +notation > "hvbox(a break \liff b)" + left associative with precedence 25 +for @{ 'iff $a $b }. + +notation < "hvbox(a break \leftrightarrow b)" + left associative with precedence 25 +for @{ 'iff $a $b }. diff --git a/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma new file mode 100644 index 000000000..5d872040a --- /dev/null +++ b/helm/software/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma @@ -0,0 +1,66 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/PREDICATIVE-TOPOLOGY/subset_defs". + +include "domain_defs.ma". + +(* SUBSETS + - We use predicative subsets coded as propositional functions + according to G.Sambin and S.Valentini "Toolbox" +*) + +definition Subset \def \lambda (D:Domain). D \to Prop. + +(* subset membership (epsilon) *) +definition sin : \forall D. Subset D \to D \to Prop \def + \lambda (D:Domain). \lambda U,d. cin D d \and U d. + +(* subset top (full subset) *) +definition stop \def \lambda (D:Domain). true_f D. + +(* subset bottom (empty subset) *) +definition sbot \def \lambda (D:Domain). false_f D. + +(* subset and (binary intersection) *) +definition sand: \forall D. Subset D \to Subset D \to Subset D \def + \lambda D,U1,U2,d. U1 d \land U2 d. + +(* subset or (binary union) *) +definition sor: \forall D. Subset D \to Subset D \to Subset D \def + \lambda D,U1,U2,d. U1 d \lor U2 d. + +(* subset less or equal (inclusion) *) +definition sle: \forall D. Subset D \to Subset D \to Prop \def + \lambda D,U1,U2. \iforall d. U1 d \to U2 d. + +(* subset overlap *) +definition sover: \forall D. Subset D \to Subset D \to Prop \def + \lambda D,U1,U2. \iexists d. U1 d \land U2 d. + +(* coercions **************************************************************) + +(* +(* the class of the subsets of a domain (not an implicit coercion) *) +definition class_of_subsets_of \def + \lambda D. mk_Class (Subset D) (true_f ?) (sle ?). +*) + +(* the domain built upon a subset (not an implicit coercion) *) +definition domain_of_subset: \forall D. Subset D \to Domain \def + \lambda (D:Domain). \lambda U. + mk_Domain (mk_Class D (sin D U) (cle1 D)). + +(* the full subset of a domain *) +coercion stop. diff --git a/helm/software/matita/core_notation.moo b/helm/software/matita/core_notation.moo new file mode 100644 index 000000000..c30e5142c --- /dev/null +++ b/helm/software/matita/core_notation.moo @@ -0,0 +1,115 @@ +notation "hvbox(a break \to b)" + right associative with precedence 20 +for @{ \forall $_:$a.$b }. + +notation < "hvbox(a break \to b)" + right associative with precedence 20 +for @{ \Pi $_:$a.$b }. + +notation "hvbox(a break = b)" + non associative with precedence 45 +for @{ 'eq $a $b }. + +notation "hvbox(a break \leq b)" + non associative with precedence 45 +for @{ 'leq $a $b }. + +notation "hvbox(a break \geq b)" + non associative with precedence 45 +for @{ 'geq $a $b }. + +notation "hvbox(a break \lt b)" + non associative with precedence 45 +for @{ 'lt $a $b }. + +notation "hvbox(a break \gt b)" + non associative with precedence 45 +for @{ 'gt $a $b }. + +notation "hvbox(a break \neq b)" + non associative with precedence 45 +for @{ 'neq $a $b }. + +notation "hvbox(a break \nleq b)" + non associative with precedence 45 +for @{ 'nleq $a $b }. + +notation "hvbox(a break \ngeq b)" + non associative with precedence 45 +for @{ 'ngeq $a $b }. + +notation "hvbox(a break \nless b)" + non associative with precedence 45 +for @{ 'nless $a $b }. + +notation "hvbox(a break \ngtr b)" + non associative with precedence 45 +for @{ 'ngtr $a $b }. + +notation "hvbox(a break \divides b)" + non associative with precedence 45 +for @{ 'divides $a $b }. + +notation "hvbox(a break \ndivides b)" + non associative with precedence 45 +for @{ 'ndivides $a $b }. + +notation "hvbox(a break + b)" + left associative with precedence 50 +for @{ 'plus $a $b }. + +notation "hvbox(a break - b)" + left associative with precedence 50 +for @{ 'minus $a $b }. + +notation "hvbox(a break * b)" + left associative with precedence 55 +for @{ 'times $a $b }. + +notation "hvbox(a break \mod b)" + left associative with precedence 55 +for @{ 'module $a $b }. + +notation "\frac a b" + non associative with precedence 90 +for @{ 'divide $a $b }. + +notation "a \over b" + left associative with precedence 55 +for @{ 'divide $a $b }. + +notation "hvbox(a break / b)" + left associative with precedence 55 +for @{ 'divide $a $b }. + +notation > "- a" + right associative with precedence 60 +for @{ 'uminus $a }. + +notation < "- a" + right associative with precedence 75 +for @{ 'uminus $a }. + +notation "a !" + non associative with precedence 80 +for @{ 'fact $a }. + +notation "(a \sup b)" + right associative with precedence 65 +for @{ 'exp $a $b}. + +notation "\sqrt a" + non associative with precedence 60 +for @{ 'sqrt $a }. + +notation "hvbox(a break \lor b)" + left associative with precedence 30 +for @{ 'or $a $b }. + +notation "hvbox(a break \land b)" + left associative with precedence 35 +for @{ 'and $a $b }. + +notation "hvbox(\lnot a)" + left associative with precedence 40 +for @{ 'not $a }. diff --git a/helm/software/matita/dictionary-matita.xml b/helm/software/matita/dictionary-matita.xml new file mode 100644 index 000000000..35903486b --- /dev/null +++ b/helm/software/matita/dictionary-matita.xml @@ -0,0 +1,15 @@ + + + + + + + + + + + + + + + diff --git a/helm/software/matita/dist/Makefile b/helm/software/matita/dist/Makefile new file mode 100644 index 000000000..669137bf2 --- /dev/null +++ b/helm/software/matita/dist/Makefile @@ -0,0 +1,17 @@ +MYSQL_FLAGS = --extended_insert --lock-tables=off --no-create-info +DB = -u helm -h mowgli.cs.unibo.it matita +TABLE_CREATOR = ../../ocaml/metadata/table_creator/table_creator +TABLES := $(shell $(TABLE_CREATOR) list all) +all: static_link +clean: static_link_clean +.PHONY: static_link +static_link: + $(MAKE) -C static_link/ +static_link_clean: + $(MAKE) -C static_link/ clean +dist: matita_stdlib.sql.gz +.PHONY: matita_stdlib.sql +matita_stdlib.sql: + mysqldump $(MYSQL_FLAGS) $(DB) $(TABLES) > $@ +%.gz: % + gzip -c $< > $@ diff --git a/helm/software/matita/dist/fill_db.sh b/helm/software/matita/dist/fill_db.sh new file mode 100755 index 000000000..1ae28d336 --- /dev/null +++ b/helm/software/matita/dist/fill_db.sh @@ -0,0 +1,53 @@ +#!/bin/bash +set -e + +MYSQL="mysql" +DBHOST="localhost" +DBNAME="matita" +DBUSER="helm" +DBPASS="" + +TABLE_CREATOR="../../ocaml/metadata/table_creator/table_creator" + +SQL="matita_db.sql" +STDLIB_DATA="matita_stdlib.sql.gz" + +grant_sql="GRANT ALL PRIVILEGES ON $DBNAME.* TO $DBUSER@$DBHOST" +create_sql="CREATE DATABASE $DBNAME" +drop_sql="DROP DATABASE $DBNAME" + +function appendsql() +{ + echo "$1" >> $SQL +} + +echo "Step 0." +echo " Dropping old databases, if any." +echo " You can ignore errors output by this step" +echo "$drop_sql" | $MYSQL -f +echo "Step 1." +echo " Creating database and users." +echo "# SQL statements to create Matita DB and users" > $SQL +appendsql "$create_sql;" +if [ -z "$DBPASS" ]; then + appendsql "$grant_sql;" +else + appendsql "$grant_sql IDENTIFIED BY '$DBPASS';" +fi +$MYSQL < $SQL +echo "Step 2." +echo " Creating database structure." +echo "# SQL statements to create Matita DB structure" > $SQL +creator_args="table fill index" +for arg in $creator_args; do + appendsql "`$TABLE_CREATOR $arg all`" +done +$MYSQL $DBNAME < $SQL +echo "Step 3." +echo " Filling database with standard library metadata." +if [ -f "$STDLIB_DATA" ]; then + gunzip -c "$STDLIB_DATA" | $MYSQL $DBNAME +else + echo " Standard library metadata file $STDLIB_DATA not found, skipping this step." +fi + diff --git a/helm/software/matita/dist/static_link/Makefile b/helm/software/matita/dist/static_link/Makefile new file mode 100644 index 000000000..5a02bb3b7 --- /dev/null +++ b/helm/software/matita/dist/static_link/Makefile @@ -0,0 +1,5 @@ +all: static_link +static_link: static_link.ml + ocamlfind ocamlc -package unix,str -linkpkg -o $@ $< +clean: + rm -f static_link.cm* static_link diff --git a/helm/software/matita/dist/static_link/static_link.ml b/helm/software/matita/dist/static_link/static_link.ml new file mode 100644 index 000000000..8b1d57668 --- /dev/null +++ b/helm/software/matita/dist/static_link/static_link.ml @@ -0,0 +1,162 @@ + +open Printf + +exception Found of string list + +let ocamlobjinfo = "ocamlobjinfo" +let noautolink = "-noautolink" +let dummy_opt_cmd = "dummy_ocamlopt" +let opt_cmd = "ocamlopt" +let libdirs = [ "/lib"; "/usr/lib"; "/usr/lib/gcc/i486-linux-gnu/4.0.2" ] +let exceptions = [ "threads.cma", [ "-lthreads", "-lthreadsnat" ] ] + +let blanks_RE = Str.regexp "[ \t\r\n]+" +let cmxa_RE = Str.regexp "\\.cmxa$" +let extra_cfiles_RE = Str.regexp "^.*Extra +C +object +files:\\(.*\\)$" +let extra_copts_RE = Str.regexp "^.*Extra +C +options:\\(.*\\)$" +let lib_RE = Str.regexp "^lib" +let l_RE = Str.regexp "^-l" +let opt_line_RE = Str.regexp (sprintf "^\\+ +%s +\\(.*\\)$" dummy_opt_cmd) +let trailing_cmxa_RE = Str.regexp ".*\\.cmxa$" + +let message s = prerr_endline ("STATIC_LINK: " ^ s) +let warning s = message ("WARNING: " ^ s) + +let handle_exceptions ~cma cflag = + try + let cma_exns = List.assoc (Filename.basename cma) exceptions in + let cflag' = List.assoc cflag cma_exns in + message (sprintf "using %s exception %s -> %s" cma cflag cflag'); + cflag' + with Not_found -> cflag + +let parse_cmdline () = + let mine, rest = ref [], ref [] in + let is_mine = ref true in + Array.iter + (function + | "--" -> is_mine := false + | s when !is_mine -> + if Str.string_match lib_RE s 0 then + warning (sprintf + ("libraries to be statically linked must be specified " + ^^ "without heading \"lib\", \"%s\" argument may be wrong") s); + mine := s :: !mine + | s -> rest := s :: !rest) + Sys.argv; + if !rest = [] then begin + prerr_endline "Usage: static_link [ CLIB .. ] -- COMMAND [ ARG .. ]"; + prerr_endline ("Example: static_link pcre expat --" + ^ " ocamlfind opt -package pcre,expat -linkpkg -o foo foo.ml"); + exit 0 + end; + List.tl (List.rev !mine), List.rev !rest + +let extract_opt_flags cmd = + let ic = Unix.open_process_in cmd in + (try + while true do + let l = input_line ic in + if Str.string_match opt_line_RE l 0 then begin + message ("got ocamlopt line: " ^ l); + raise (Found (Str.split blanks_RE (Str.matched_group 1 l))); + end + done; + [] (* dummy value *) + with + | End_of_file -> failwith "compiler command not found" + | Found flags -> + close_in ic; + flags) + +let cma_of_cmxa = Str.replace_first cmxa_RE ".cma" + +let find_clib libname = + let rec aux = + function + | [] -> raise Not_found + | libdir :: tl -> + let fname = sprintf "%s/lib%s.a" libdir libname in + if Sys.file_exists fname then fname else aux tl + in + aux libdirs + +let a_of_cflag cflag = (* "-lfoo" -> "/usr/lib/libfoo.a" *) + let libname = Str.replace_first l_RE "" cflag in + find_clib libname + +let cflags_of_cma fname = + let ic = Unix.open_process_in (sprintf "%s %s" ocamlobjinfo fname) in + let extra_copts = ref "" in + let extra_cfiles = ref "" in + (try + while true do + match input_line ic with + | s when Str.string_match extra_copts_RE s 0 -> + extra_copts := Str.matched_group 1 s + | s when Str.string_match extra_cfiles_RE s 0 -> + extra_cfiles := Str.matched_group 1 s + | _ -> () + done + with End_of_file -> ()); + close_in ic; + let extra_cfiles = List.rev (Str.split blanks_RE !extra_cfiles) in + let extra_copts = Str.split blanks_RE !extra_copts in + extra_copts @ extra_cfiles + +let staticize static_libs flags = + let static_flags = List.map ((^) "-l") static_libs in + let aux ~add_cclib ~cma cflag = + let cflag = + if List.mem cflag static_flags + then + (try + let a = a_of_cflag cflag in + message (sprintf "using static %s instead of shared %s" a cflag); + a + with Not_found -> warning ("can't find lib for " ^ cflag); cflag) + else (handle_exceptions ~cma cflag) + in + if add_cclib then [ "-cclib"; cflag ] else [ cflag ] + in + List.fold_right + (fun flag acc -> + let cma = cma_of_cmxa flag in + if Str.string_match trailing_cmxa_RE flag 0 then begin + message ("processing native archive: " ^ flag); + let cflags = cflags_of_cma cma in + let cflags' = + List.fold_right + (fun cflag acc -> (aux ~add_cclib:true ~cma cflag) @ acc) + cflags [] + in + flag :: (cflags' @ acc) + end else + (aux ~add_cclib:false ~cma flag) @ acc) + flags [] + +let quote_if_needed s = + try + ignore (Str.search_forward blanks_RE s 0); + "\"" ^ s ^ "\"" + with Not_found -> s + +let main () = + let static_libs, args = parse_cmdline () in + printf "C libraries to be linked-in: %s\n" (String.concat " " static_libs); + flush stdout; + let verbose_cmd = + sprintf "OCAMLFIND_COMMANDS='ocamlopt=%s' %s -verbose 2>&1" dummy_opt_cmd + (String.concat " " (List.map quote_if_needed args)) + in + let orig_opt_flags = extract_opt_flags verbose_cmd in + message ("original ocamlopt flags: " ^ String.concat " " orig_opt_flags); + let opt_flags = staticize static_libs orig_opt_flags in + message ("new ocamlopt flags: " ^ String.concat " " opt_flags); + let flags = noautolink :: opt_flags in + let cmd = String.concat " " (opt_cmd :: flags) in + message ("executing command: " ^ cmd); + exit (Sys.command cmd) + +let _ = main () + diff --git a/helm/software/matita/dump_moo.ml b/helm/software/matita/dump_moo.ml new file mode 100644 index 000000000..05c21d40d --- /dev/null +++ b/helm/software/matita/dump_moo.ml @@ -0,0 +1,58 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let arg_spec = + let std_arg_spec = [] in + let debug_arg_spec = [] in + std_arg_spec @ debug_arg_spec + +let usage = + sprintf "MatitaC v%s\nUsage: dump_moo [option ...] file.moo\nOptions:" + BuildTimeConf.version + +let _ = + let moos = ref [] in + let add_moo fname = moos := fname :: !moos in + Arg.parse arg_spec add_moo usage; + if !moos = [] then begin print_endline usage; exit 1 end; + List.iter + (fun fname -> + if not (Sys.file_exists fname) then + HLog.error (sprintf "Can't find moo '%s', skipping it." fname) + else begin + printf "%s:\n" fname; flush stdout; + let commands = GrafiteMarshal.load_moo ~fname in + List.iter + (fun cmd -> + printf " %s\n%!" + (GrafiteAstPp.pp_command ~obj_pp:(fun _ -> assert false) cmd)) + commands; + end) + (List.rev !moos) + diff --git a/helm/software/matita/gtkmathview.matita.conf.xml.in b/helm/software/matita/gtkmathview.matita.conf.xml.in new file mode 100644 index 000000000..704ca13ef --- /dev/null +++ b/helm/software/matita/gtkmathview.matita.conf.xml.in @@ -0,0 +1,17 @@ + + +
    + @RT_BASE_DIR@/dictionary-matita.xml +
    + +     diff --git a/helm/software/matita/icons/matita-bulb-high.png b/helm/software/matita/icons/matita-bulb-high.png new file mode 100644 index 000000000..03b6e7f86 Binary files /dev/null and b/helm/software/matita/icons/matita-bulb-high.png differ diff --git a/helm/software/matita/icons/matita-bulb-low.png b/helm/software/matita/icons/matita-bulb-low.png new file mode 100644 index 000000000..f97302e48 Binary files /dev/null and b/helm/software/matita/icons/matita-bulb-low.png differ diff --git a/helm/software/matita/icons/matita-bulb-medium.png b/helm/software/matita/icons/matita-bulb-medium.png new file mode 100644 index 000000000..d3d449f93 Binary files /dev/null and b/helm/software/matita/icons/matita-bulb-medium.png differ diff --git a/helm/software/matita/icons/matita-folder.png b/helm/software/matita/icons/matita-folder.png new file mode 100644 index 000000000..ec0cc0839 Binary files /dev/null and b/helm/software/matita/icons/matita-folder.png differ diff --git a/helm/software/matita/icons/matita-object.png b/helm/software/matita/icons/matita-object.png new file mode 100644 index 000000000..fe89a30e8 Binary files /dev/null and b/helm/software/matita/icons/matita-object.png differ diff --git a/helm/software/matita/icons/matita-theory.png b/helm/software/matita/icons/matita-theory.png new file mode 100644 index 000000000..389152ef3 Binary files /dev/null and b/helm/software/matita/icons/matita-theory.png differ diff --git a/helm/software/matita/icons/matita.png b/helm/software/matita/icons/matita.png new file mode 100644 index 000000000..342bcb44c Binary files /dev/null and b/helm/software/matita/icons/matita.png differ diff --git a/helm/software/matita/icons/matita_medium.png b/helm/software/matita/icons/matita_medium.png new file mode 100644 index 000000000..335688af2 Binary files /dev/null and b/helm/software/matita/icons/matita_medium.png differ diff --git a/helm/software/matita/icons/matita_small.png b/helm/software/matita/icons/matita_small.png new file mode 100644 index 000000000..cfb017b0f Binary files /dev/null and b/helm/software/matita/icons/matita_small.png differ diff --git a/helm/software/matita/icons/matita_very_small.png b/helm/software/matita/icons/matita_very_small.png new file mode 100644 index 000000000..5a6807126 Binary files /dev/null and b/helm/software/matita/icons/matita_very_small.png differ diff --git a/helm/software/matita/icons/meegg.png b/helm/software/matita/icons/meegg.png new file mode 100644 index 000000000..4c2be73fb Binary files /dev/null and b/helm/software/matita/icons/meegg.png differ diff --git a/helm/software/matita/icons/whelp.png b/helm/software/matita/icons/whelp.png new file mode 100644 index 000000000..f67ea8b55 Binary files /dev/null and b/helm/software/matita/icons/whelp.png differ diff --git a/helm/software/matita/icons/whelp.svg b/helm/software/matita/icons/whelp.svg new file mode 100644 index 000000000..c1da66f6d --- /dev/null +++ b/helm/software/matita/icons/whelp.svg @@ -0,0 +1,221 @@ + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + h + + e + + l + + p + + W + + + diff --git a/helm/software/matita/library/Makefile b/helm/software/matita/library/Makefile new file mode 100644 index 000000000..fd278eb40 --- /dev/null +++ b/helm/software/matita/library/Makefile @@ -0,0 +1,57 @@ +SRC=$(shell find . -name "*.ma" -a -type f) + +MATITA_FLAGS = +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +MATITAC=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac $(MATITA_FLAGS)" "../matitaclean $(MATITA_FLAGS)" /dev/null OK +MATITACOPT=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac.opt $(MATITA_FLAGS)" "../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK +VERBOSEMATITAC=../matitac $(MATITA_FLAGS) +VERBOSEMATITACOPT=../matitac.opt $(MATITA_FLAGS) + +MATITACLEAN=../matitaclean $(MATITA_FLAGS) +MATITACLEANOPT=../matitaclean.opt $(MATITA_FLAGS) + +MATITADEP=../matitadep $(MATITA_FLAGS) +MATITADEPOPT=../matitadep.opt $(MATITA_FLAGS) + +DEPEND_NAME=.depend + +H=@ + +all: $(SRC:%.ma=%.mo) + +opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all + +verbose: + $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all + +%.opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) + +clean_: + $(H)rm -f __*not_for_matita + +clean: clean_ + $(H)$(MATITACLEAN) $(SRC) + +cleanall: + $(H)rm -f $(SRC:%.ma=%.moo) + $(H)$(MATITACLEAN) all + +depend: + $(H)rm -f $(DEPEND_NAME) + $(H)$(MAKE) $(DEPEND_NAME) +.PHONY: depend + +%.moo: + $(H)$(MATITAC) $< + +$(DEPEND_NAME): $(SRC) + $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ + +#include $(DEPEND_NAME) +include .depend diff --git a/helm/software/matita/library/Q/q.ma b/helm/software/matita/library/Q/q.ma new file mode 100644 index 000000000..340154979 --- /dev/null +++ b/helm/software/matita/library/Q/q.ma @@ -0,0 +1,320 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/Q/q". + +include "Z/compare.ma". +include "Z/plus.ma". + +(* a fraction is a list of Z-coefficients for primes, in natural +order. The last coefficient must eventually be different from 0 *) + +inductive fraction : Set \def + pp : nat \to fraction +| nn: nat \to fraction +| cons : Z \to fraction \to fraction. + +inductive ratio : Set \def + one : ratio + | frac : fraction \to ratio. + +(* a rational number is either O or a ratio with a sign *) +inductive Q : Set \def + OQ : Q + | Qpos : ratio \to Q + | Qneg : ratio \to Q. + +(* double elimination principles *) +theorem fraction_elim2: +\forall R:fraction \to fraction \to Prop. +(\forall n:nat.\forall g:fraction.R (pp n) g) \to +(\forall n:nat.\forall g:fraction.R (nn n) g) \to +(\forall x:Z.\forall f:fraction.\forall m:nat.R (cons x f) (pp m)) \to +(\forall x:Z.\forall f:fraction.\forall m:nat.R (cons x f) (nn m)) \to +(\forall x,y:Z.\forall f,g:fraction.R f g \to R (cons x f) (cons y g)) \to +\forall f,g:fraction. R f g. +intros 7.elim f. + apply H. + apply H1. + elim g. + apply H2. + apply H3. + apply H4.apply H5. +qed. + +(* boolean equality *) +let rec eqfb f g \def +match f with +[ (pp n) \Rightarrow + match g with + [ (pp m) \Rightarrow eqb n m + | (nn m) \Rightarrow false + | (cons y g1) \Rightarrow false] +| (nn n) \Rightarrow + match g with + [ (pp m) \Rightarrow false + | (nn m) \Rightarrow eqb n m + | (cons y g1) \Rightarrow false] +| (cons x f1) \Rightarrow + match g with + [ (pp m) \Rightarrow false + | (nn m) \Rightarrow false + | (cons y g1) \Rightarrow andb (eqZb x y) (eqfb f1 g1)]]. + +(* discrimination *) +definition aux \def + \lambda f. match f with + [ (pp n) \Rightarrow n + | (nn n) \Rightarrow n + | (cons x f) \Rightarrow O]. + +definition fhd \def +\lambda f. match f with + [ (pp n) \Rightarrow (pos n) + | (nn n) \Rightarrow (neg n) + | (cons x f) \Rightarrow x]. + +definition ftl \def +\lambda f. match f with + [ (pp n) \Rightarrow (pp n) + | (nn n) \Rightarrow (nn n) + | (cons x f) \Rightarrow f]. + +theorem injective_pp : injective nat fraction pp. +unfold injective.intros. +change with ((aux (pp x)) = (aux (pp y))). +apply eq_f.assumption. +qed. + +theorem injective_nn : injective nat fraction nn. +unfold injective.intros. +change with ((aux (nn x)) = (aux (nn y))). +apply eq_f.assumption. +qed. + +theorem eq_cons_to_eq1: \forall f,g:fraction.\forall x,y:Z. +(cons x f) = (cons y g) \to x = y. +intros. +change with ((fhd (cons x f)) = (fhd (cons y g))). +apply eq_f.assumption. +qed. + +theorem eq_cons_to_eq2: \forall x,y:Z.\forall f,g:fraction. +(cons x f) = (cons y g) \to f = g. +intros. +change with ((ftl (cons x f)) = (ftl (cons y g))). +apply eq_f.assumption. +qed. + +theorem not_eq_pp_nn: \forall n,m:nat. pp n \neq nn m. +intros.unfold Not. intro. +change with match (pp n) with +[ (pp n) \Rightarrow False +| (nn n) \Rightarrow True +| (cons x f) \Rightarrow True]. +rewrite > H. +simplify.exact I. +qed. + +theorem not_eq_pp_cons: +\forall n:nat.\forall x:Z. \forall f:fraction. +pp n \neq cons x f. +intros.unfold Not. intro. +change with match (pp n) with +[ (pp n) \Rightarrow False +| (nn n) \Rightarrow True +| (cons x f) \Rightarrow True]. +rewrite > H. +simplify.exact I. +qed. + +theorem not_eq_nn_cons: +\forall n:nat.\forall x:Z. \forall f:fraction. +nn n \neq cons x f. +intros.unfold Not. intro. +change with match (nn n) with +[ (pp n) \Rightarrow True +| (nn n) \Rightarrow False +| (cons x f) \Rightarrow True]. +rewrite > H. +simplify.exact I. +qed. + +theorem decidable_eq_fraction: \forall f,g:fraction. +decidable (f = g). +intros.unfold decidable. +apply (fraction_elim2 (\lambda f,g. f=g \lor (f=g \to False))). + intros.elim g1. + elim ((decidable_eq_nat n n1) : n=n1 \lor (n=n1 \to False)). + left.apply eq_f. assumption. + right.intro.apply H.apply injective_pp.assumption. + right.apply not_eq_pp_nn. + right.apply not_eq_pp_cons. + intros. elim g1. + right.intro.apply (not_eq_pp_nn n1 n).apply sym_eq. assumption. + elim ((decidable_eq_nat n n1) : n=n1 \lor (n=n1 \to False)). + left. apply eq_f. assumption. + right.intro.apply H.apply injective_nn.assumption. + right.apply not_eq_nn_cons. + intros.right.intro.apply (not_eq_pp_cons m x f1).apply sym_eq.assumption. + intros.right.intro.apply (not_eq_nn_cons m x f1).apply sym_eq.assumption. + intros.elim H. + elim ((decidable_eq_Z x y) : x=y \lor (x=y \to False)). + left.apply eq_f2.assumption. + assumption. + right.intro.apply H2.apply (eq_cons_to_eq1 f1 g1).assumption. + right.intro.apply H1.apply (eq_cons_to_eq2 x y f1 g1).assumption. +qed. + +theorem eqfb_to_Prop: \forall f,g:fraction. +match (eqfb f g) with +[true \Rightarrow f=g +|false \Rightarrow f \neq g]. +intros.apply (fraction_elim2 +(\lambda f,g.match (eqfb f g) with +[true \Rightarrow f=g +|false \Rightarrow f \neq g])). + intros.elim g1. + simplify.apply eqb_elim. + intro.simplify.apply eq_f.assumption. + intro.simplify.unfold Not.intro.apply H.apply injective_pp.assumption. + simplify.apply not_eq_pp_nn. + simplify.apply not_eq_pp_cons. + intros.elim g1. + simplify.unfold Not.intro.apply (not_eq_pp_nn n1 n).apply sym_eq. assumption. + simplify.apply eqb_elim.intro.simplify.apply eq_f.assumption. + intro.simplify.unfold Not.intro.apply H.apply injective_nn.assumption. + simplify.apply not_eq_nn_cons. + intros.simplify.unfold Not.intro.apply (not_eq_pp_cons m x f1).apply sym_eq. assumption. + intros.simplify.unfold Not.intro.apply (not_eq_nn_cons m x f1).apply sym_eq. assumption. + intros. + change in match (eqfb (cons x f1) (cons y g1)) + with (andb (eqZb x y) (eqfb f1 g1)). + apply eqZb_elim. + intro.generalize in match H.elim (eqfb f1 g1). + simplify.apply eq_f2.assumption. + apply H2. + simplify.unfold Not.intro.apply H2.apply (eq_cons_to_eq2 x y).assumption. + intro.simplify.unfold Not.intro.apply H1.apply (eq_cons_to_eq1 f1 g1).assumption. +qed. + +let rec finv f \def + match f with + [ (pp n) \Rightarrow (nn n) + | (nn n) \Rightarrow (pp n) + | (cons x g) \Rightarrow (cons (Zopp x) (finv g))]. + +definition Z_to_ratio :Z \to ratio \def +\lambda x:Z. match x with +[ OZ \Rightarrow one +| (pos n) \Rightarrow frac (pp n) +| (neg n) \Rightarrow frac (nn n)]. + +let rec ftimes f g \def + match f with + [ (pp n) \Rightarrow + match g with + [(pp m) \Rightarrow Z_to_ratio (pos n + pos m) + | (nn m) \Rightarrow Z_to_ratio (pos n + neg m) + | (cons y g1) \Rightarrow frac (cons (pos n + y) g1)] + | (nn n) \Rightarrow + match g with + [(pp m) \Rightarrow Z_to_ratio (neg n + pos m) + | (nn m) \Rightarrow Z_to_ratio (neg n + neg m) + | (cons y g1) \Rightarrow frac (cons (neg n + y) g1)] + | (cons x f1) \Rightarrow + match g with + [ (pp m) \Rightarrow frac (cons (x + pos m) f1) + | (nn m) \Rightarrow frac (cons (x + neg m) f1) + | (cons y g1) \Rightarrow + match ftimes f1 g1 with + [ one \Rightarrow Z_to_ratio (x + y) + | (frac h) \Rightarrow frac (cons (x + y) h)]]]. + +theorem symmetric2_ftimes: symmetric2 fraction ratio ftimes. +unfold symmetric2. intros.apply (fraction_elim2 (\lambda f,g.ftimes f g = ftimes g f)). + intros.elim g. + change with (Z_to_ratio (pos n + pos n1) = Z_to_ratio (pos n1 + pos n)). + apply eq_f.apply sym_Zplus. + change with (Z_to_ratio (pos n + neg n1) = Z_to_ratio (neg n1 + pos n)). + apply eq_f.apply sym_Zplus. + change with (frac (cons (pos n + z) f) = frac (cons (z + pos n) f)). + rewrite < sym_Zplus.reflexivity. + intros.elim g. + change with (Z_to_ratio (neg n + pos n1) = Z_to_ratio (pos n1 + neg n)). + apply eq_f.apply sym_Zplus. + change with (Z_to_ratio (neg n + neg n1) = Z_to_ratio (neg n1 + neg n)). + apply eq_f.apply sym_Zplus. + change with (frac (cons (neg n + z) f) = frac (cons (z + neg n) f)). + rewrite < sym_Zplus.reflexivity. + intros.change with (frac (cons (x1 + pos m) f) = frac (cons (pos m + x1) f)). + rewrite < sym_Zplus.reflexivity. + intros.change with (frac (cons (x1 + neg m) f) = frac (cons (neg m + x1) f)). + rewrite < sym_Zplus.reflexivity. + intros. + change with + (match ftimes f g with + [ one \Rightarrow Z_to_ratio (x1 + y1) + | (frac h) \Rightarrow frac (cons (x1 + y1) h)] = + match ftimes g f with + [ one \Rightarrow Z_to_ratio (y1 + x1) + | (frac h) \Rightarrow frac (cons (y1 + x1) h)]). + rewrite < H.rewrite < sym_Zplus.reflexivity. +qed. + +theorem ftimes_finv : \forall f:fraction. ftimes f (finv f) = one. +intro.elim f. + change with (Z_to_ratio (pos n + - (pos n)) = one). + rewrite > Zplus_Zopp.reflexivity. + change with (Z_to_ratio (neg n + - (neg n)) = one). + rewrite > Zplus_Zopp.reflexivity. +(* again: we would need something to help finding the right change *) + change with + (match ftimes f1 (finv f1) with + [ one \Rightarrow Z_to_ratio (z + - z) + | (frac h) \Rightarrow frac (cons (z + - z) h)] = one). + rewrite > H.rewrite > Zplus_Zopp.reflexivity. +qed. + +definition rtimes : ratio \to ratio \to ratio \def +\lambda r,s:ratio. + match r with + [one \Rightarrow s + | (frac f) \Rightarrow + match s with + [one \Rightarrow frac f + | (frac g) \Rightarrow ftimes f g]]. + +theorem symmetric_rtimes : symmetric ratio rtimes. +change with (\forall r,s:ratio. rtimes r s = rtimes s r). +intros. +elim r. elim s. +reflexivity. +reflexivity. +elim s. +reflexivity. +simplify.apply symmetric2_ftimes. +qed. + +definition rinv : ratio \to ratio \def +\lambda r:ratio. + match r with + [one \Rightarrow one + | (frac f) \Rightarrow frac (finv f)]. + +theorem rtimes_rinv: \forall r:ratio. rtimes r (rinv r) = one. +intro.elim r. +reflexivity. +simplify.apply ftimes_finv. +qed. diff --git a/helm/software/matita/library/Z/compare.ma b/helm/software/matita/library/Z/compare.ma new file mode 100644 index 000000000..4a5025975 --- /dev/null +++ b/helm/software/matita/library/Z/compare.ma @@ -0,0 +1,143 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/Z/compare". + +include "Z/orders.ma". +include "nat/compare.ma". + +(* boolean equality *) +definition eqZb : Z \to Z \to bool \def +\lambda x,y:Z. + match x with + [ OZ \Rightarrow + match y with + [ OZ \Rightarrow true + | (pos q) \Rightarrow false + | (neg q) \Rightarrow false] + | (pos p) \Rightarrow + match y with + [ OZ \Rightarrow false + | (pos q) \Rightarrow eqb p q + | (neg q) \Rightarrow false] + | (neg p) \Rightarrow + match y with + [ OZ \Rightarrow false + | (pos q) \Rightarrow false + | (neg q) \Rightarrow eqb p q]]. + +theorem eqZb_to_Prop: +\forall x,y:Z. +match eqZb x y with +[ true \Rightarrow x=y +| false \Rightarrow x \neq y]. +intros. +elim x. + elim y. + simplify.reflexivity. + simplify.apply not_eq_OZ_pos. + simplify.apply not_eq_OZ_neg. + elim y. + simplify.unfold Not.intro.apply (not_eq_OZ_pos n).apply sym_eq.assumption. + simplify.apply eqb_elim. + intro.simplify.apply eq_f.assumption. + intro.simplify.unfold Not.intro.apply H.apply inj_pos.assumption. + simplify.apply not_eq_pos_neg. + elim y. + simplify.unfold Not.intro.apply (not_eq_OZ_neg n).apply sym_eq.assumption. + simplify.unfold Not.intro.apply (not_eq_pos_neg n1 n).apply sym_eq.assumption. + simplify.apply eqb_elim. + intro.simplify.apply eq_f.assumption. + intro.simplify.unfold Not.intro.apply H.apply inj_neg.assumption. +qed. + +theorem eqZb_elim: \forall x,y:Z.\forall P:bool \to Prop. +(x=y \to (P true)) \to (x \neq y \to (P false)) \to P (eqZb x y). +intros. +cut +(match (eqZb x y) with +[ true \Rightarrow x=y +| false \Rightarrow x \neq y] \to P (eqZb x y)). +apply Hcut. +apply eqZb_to_Prop. +elim (eqZb). +apply (H H2). +apply (H1 H2). +qed. + +definition Z_compare : Z \to Z \to compare \def +\lambda x,y:Z. + match x with + [ OZ \Rightarrow + match y with + [ OZ \Rightarrow EQ + | (pos m) \Rightarrow LT + | (neg m) \Rightarrow GT ] + | (pos n) \Rightarrow + match y with + [ OZ \Rightarrow GT + | (pos m) \Rightarrow (nat_compare n m) + | (neg m) \Rightarrow GT] + | (neg n) \Rightarrow + match y with + [ OZ \Rightarrow LT + | (pos m) \Rightarrow LT + | (neg m) \Rightarrow nat_compare m n ]]. + +theorem Z_compare_to_Prop : +\forall x,y:Z. match (Z_compare x y) with +[ LT \Rightarrow x < y +| EQ \Rightarrow x=y +| GT \Rightarrow y < x]. +intros. +elim x. + elim y. + simplify.apply refl_eq. + simplify.exact I. + simplify.exact I. + elim y. + simplify.exact I. + simplify. + cut (match (nat_compare n n1) with + [ LT \Rightarrow n Zplus_z_OZ.reflexivity. +elim y.simplify.reflexivity. +simplify. +rewrite < plus_n_Sm. rewrite < plus_n_Sm.rewrite < sym_plus.reflexivity. +simplify. +rewrite > nat_compare_n_m_m_n. +simplify.elim nat_compare.simplify.reflexivity. +simplify. reflexivity. +simplify. reflexivity. +elim y.simplify.reflexivity. +simplify.rewrite > nat_compare_n_m_m_n. +simplify.elim nat_compare.simplify.reflexivity. +simplify. reflexivity. +simplify. reflexivity. +simplify.rewrite < plus_n_Sm. rewrite < plus_n_Sm.rewrite < sym_plus.reflexivity. +qed. + +theorem Zpred_Zplus_neg_O : \forall z:Z. Zpred z = (neg O)+z. +intros.elim z. + simplify.reflexivity. + elim n. + simplify.reflexivity. + simplify.reflexivity. + simplify.reflexivity. +qed. + +theorem Zsucc_Zplus_pos_O : \forall z:Z. Zsucc z = (pos O)+z. +intros.elim z. + simplify.reflexivity. + simplify.reflexivity. + elim n. + simplify.reflexivity. + simplify.reflexivity. +qed. + +theorem Zplus_pos_pos: +\forall n,m. (pos n)+(pos m) = (Zsucc (pos n))+(Zpred (pos m)). +intros. +elim n.elim m. +simplify.reflexivity. +simplify.reflexivity. +elim m. +simplify.rewrite < plus_n_Sm. +rewrite < plus_n_O.reflexivity. +simplify.rewrite < plus_n_Sm. +rewrite < plus_n_Sm.reflexivity. +qed. + +theorem Zplus_pos_neg: +\forall n,m. (pos n)+(neg m) = (Zsucc (pos n))+(Zpred (neg m)). +intros.reflexivity. +qed. + +theorem Zplus_neg_pos : +\forall n,m. (neg n)+(pos m) = (Zsucc (neg n))+(Zpred (pos m)). +intros. +elim n.elim m. +simplify.reflexivity. +simplify.reflexivity. +elim m. +simplify.reflexivity. +simplify.reflexivity. +qed. + +theorem Zplus_neg_neg: +\forall n,m. (neg n)+(neg m) = (Zsucc (neg n))+(Zpred (neg m)). +intros. +elim n.elim m. +simplify.reflexivity. +simplify.reflexivity. +elim m. +simplify.rewrite > plus_n_Sm.reflexivity. +simplify.rewrite > plus_n_Sm.reflexivity. +qed. + +theorem Zplus_Zsucc_Zpred: +\forall x,y. x+y = (Zsucc x)+(Zpred y). +intros.elim x. + elim y. + simplify.reflexivity. + rewrite < Zsucc_Zplus_pos_O.rewrite > Zsucc_Zpred.reflexivity. + simplify.reflexivity. + elim y. + simplify.reflexivity. + apply Zplus_pos_pos. + apply Zplus_pos_neg. + elim y. + rewrite < sym_Zplus.rewrite < (sym_Zplus (Zpred OZ)). + rewrite < Zpred_Zplus_neg_O.rewrite > Zpred_Zsucc.simplify.reflexivity. + apply Zplus_neg_pos. + rewrite < Zplus_neg_neg.reflexivity. +qed. + +theorem Zplus_Zsucc_pos_pos : +\forall n,m. (Zsucc (pos n))+(pos m) = Zsucc ((pos n)+(pos m)). +intros.reflexivity. +qed. + +theorem Zplus_Zsucc_pos_neg: +\forall n,m. (Zsucc (pos n))+(neg m) = (Zsucc ((pos n)+(neg m))). +intros. +apply (nat_elim2 +(\lambda n,m. (Zsucc (pos n))+(neg m) = (Zsucc ((pos n)+(neg m))))).intro. +intros.elim n1. +simplify. reflexivity. +elim n2.simplify. reflexivity. +simplify. reflexivity. +intros. elim n1. +simplify. reflexivity. +simplify.reflexivity. +intros. +rewrite < (Zplus_pos_neg ? m1). +elim H.reflexivity. +qed. + +theorem Zplus_Zsucc_neg_neg : +\forall n,m. Zsucc (neg n) + neg m = Zsucc (neg n + neg m). +intros. +apply (nat_elim2 +(\lambda n,m. Zsucc (neg n) + neg m = Zsucc (neg n + neg m))).intro. +intros.elim n1. +simplify. reflexivity. +elim n2.simplify. reflexivity. +simplify. reflexivity. +intros. elim n1. +simplify. reflexivity. +simplify.reflexivity. +intros. +rewrite < (Zplus_neg_neg ? m1). +reflexivity. +qed. + +theorem Zplus_Zsucc_neg_pos: +\forall n,m. Zsucc (neg n)+(pos m) = Zsucc ((neg n)+(pos m)). +intros. +apply (nat_elim2 +(\lambda n,m. Zsucc (neg n) + (pos m) = Zsucc (neg n + pos m))). +intros.elim n1. +simplify. reflexivity. +elim n2.simplify. reflexivity. +simplify. reflexivity. +intros. elim n1. +simplify. reflexivity. +simplify.reflexivity. +intros. +rewrite < H. +rewrite < (Zplus_neg_pos ? (S m1)). +reflexivity. +qed. + +theorem Zplus_Zsucc : \forall x,y:Z. (Zsucc x)+y = Zsucc (x+y). +intros.elim x. + elim y. + simplify. reflexivity. + simplify.reflexivity. + rewrite < Zsucc_Zplus_pos_O.reflexivity. + elim y. + rewrite < (sym_Zplus OZ).reflexivity. + apply Zplus_Zsucc_pos_pos. + apply Zplus_Zsucc_pos_neg. + elim y. + rewrite < sym_Zplus.rewrite < (sym_Zplus OZ).simplify.reflexivity. + apply Zplus_Zsucc_neg_pos. + apply Zplus_Zsucc_neg_neg. +qed. + +theorem Zplus_Zpred: \forall x,y:Z. (Zpred x)+y = Zpred (x+y). +intros. +cut (Zpred (x+y) = Zpred ((Zsucc (Zpred x))+y)). +rewrite > Hcut. +rewrite > Zplus_Zsucc. +rewrite > Zpred_Zsucc. +reflexivity. +rewrite > Zsucc_Zpred. +reflexivity. +qed. + + +theorem associative_Zplus: associative Z Zplus. +change with (\forall x,y,z:Z. (x + y) + z = x + (y + z)). +(* simplify. *) +intros.elim x. + simplify.reflexivity. + elim n. + rewrite < Zsucc_Zplus_pos_O.rewrite < Zsucc_Zplus_pos_O. + rewrite > Zplus_Zsucc.reflexivity. + rewrite > (Zplus_Zsucc (pos n1)).rewrite > (Zplus_Zsucc (pos n1)). + rewrite > (Zplus_Zsucc ((pos n1)+y)).apply eq_f.assumption. + elim n. + rewrite < (Zpred_Zplus_neg_O (y+z)).rewrite < (Zpred_Zplus_neg_O y). + rewrite < Zplus_Zpred.reflexivity. + rewrite > (Zplus_Zpred (neg n1)).rewrite > (Zplus_Zpred (neg n1)). + rewrite > (Zplus_Zpred ((neg n1)+y)).apply eq_f.assumption. +qed. + +variant assoc_Zplus : \forall x,y,z:Z. (x+y)+z = x+(y+z) +\def associative_Zplus. + +(* Zopp *) +definition Zopp : Z \to Z \def +\lambda x:Z. match x with +[ OZ \Rightarrow OZ +| (pos n) \Rightarrow (neg n) +| (neg n) \Rightarrow (pos n) ]. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "integer unary minus" 'uminus x = (cic:/matita/Z/plus/Zopp.con x). + +theorem Zopp_Zplus: \forall x,y:Z. -(x+y) = -x + -y. +intros. +elim x.elim y. +simplify. reflexivity. +simplify. reflexivity. +simplify. reflexivity. +elim y. +simplify. reflexivity. +simplify. reflexivity. +simplify. apply nat_compare_elim. +intro.simplify.reflexivity. +intro.simplify.reflexivity. +intro.simplify.reflexivity. +elim y. +simplify. reflexivity. +simplify. apply nat_compare_elim. +intro.simplify.reflexivity. +intro.simplify.reflexivity. +intro.simplify.reflexivity. +simplify.reflexivity. +qed. + +theorem Zopp_Zopp: \forall x:Z. --x = x. +intro. elim x. +reflexivity.reflexivity.reflexivity. +qed. + +theorem Zplus_Zopp: \forall x:Z. x+ -x = OZ. +intro.elim x. +apply refl_eq. +simplify. +rewrite > nat_compare_n_n. +simplify.apply refl_eq. +simplify. +rewrite > nat_compare_n_n. +simplify.apply refl_eq. +qed. + diff --git a/helm/software/matita/library/Z/times.ma b/helm/software/matita/library/Z/times.ma new file mode 100644 index 000000000..e5e1cdb45 --- /dev/null +++ b/helm/software/matita/library/Z/times.ma @@ -0,0 +1,235 @@ +(**************************************************************************) +(* __ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/Z/times". + +include "nat/lt_arith.ma". +include "Z/plus.ma". + +definition Ztimes :Z \to Z \to Z \def +\lambda x,y. + match x with + [ OZ \Rightarrow OZ + | (pos m) \Rightarrow + match y with + [ OZ \Rightarrow OZ + | (pos n) \Rightarrow (pos (pred ((S m) * (S n)))) + | (neg n) \Rightarrow (neg (pred ((S m) * (S n))))] + | (neg m) \Rightarrow + match y with + [ OZ \Rightarrow OZ + | (pos n) \Rightarrow (neg (pred ((S m) * (S n)))) + | (neg n) \Rightarrow (pos (pred ((S m) * (S n))))]]. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "integer times" 'times x y = (cic:/matita/Z/times/Ztimes.con x y). + +theorem Ztimes_z_OZ: \forall z:Z. z*OZ = OZ. +intro.elim z. +simplify.reflexivity. +simplify.reflexivity. +simplify.reflexivity. +qed. + +theorem Ztimes_neg_Zopp: \forall n:nat.\forall x:Z. +neg n * x = - (pos n * x). +intros.elim x. +simplify.reflexivity. +simplify.reflexivity. +simplify.reflexivity. +qed. +theorem symmetric_Ztimes : symmetric Z Ztimes. +change with (\forall x,y:Z. x*y = y*x). +intros.elim x.rewrite > Ztimes_z_OZ.reflexivity. +elim y.simplify.reflexivity. +change with (pos (pred ((S n) * (S n1))) = pos (pred ((S n1) * (S n)))). +rewrite < sym_times.reflexivity. +change with (neg (pred ((S n) * (S n1))) = neg (pred ((S n1) * (S n)))). +rewrite < sym_times.reflexivity. +elim y.simplify.reflexivity. +change with (neg (pred ((S n) * (S n1))) = neg (pred ((S n1) * (S n)))). +rewrite < sym_times.reflexivity. +change with (pos (pred ((S n) * (S n1))) = pos (pred ((S n1) * (S n)))). +rewrite < sym_times.reflexivity. +qed. + +variant sym_Ztimes : \forall x,y:Z. x*y = y*x +\def symmetric_Ztimes. + +theorem associative_Ztimes: associative Z Ztimes. +change with (\forall x,y,z:Z. (x*y)*z = x*(y*z)). +intros.elim x. + simplify.reflexivity. + elim y. + simplify.reflexivity. + elim z. + simplify.reflexivity. + change with + (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + pos (pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + change with + (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + neg (pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + elim z. + simplify.reflexivity. + change with + (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + neg (pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + change with + (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + pos(pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + elim y. + simplify.reflexivity. + elim z. + simplify.reflexivity. + change with + (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + neg (pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + change with + (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + pos (pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + elim z. + simplify.reflexivity. + change with + (pos (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + pos (pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. + change with + (neg (pred ((S (pred ((S n) * (S n1)))) * (S n2))) = + neg(pred ((S n) * (S (pred ((S n1) * (S n2))))))). + rewrite < S_pred.rewrite < S_pred.rewrite < assoc_times.reflexivity. + apply lt_O_times_S_S.apply lt_O_times_S_S. +qed. + +variant assoc_Ztimes : \forall x,y,z:Z. +(x * y) * z = x * (y * z) \def +associative_Ztimes. + +lemma times_minus1: \forall n,p,q:nat. lt q p \to +(S n) * (S (pred ((S p) - (S q)))) = +pred ((S n) * (S p)) - pred ((S n) * (S q)). +intros. +rewrite < S_pred. +rewrite > minus_pred_pred. +rewrite < distr_times_minus. +reflexivity. +(* we now close all positivity conditions *) +apply lt_O_times_S_S. +apply lt_O_times_S_S. +simplify.unfold lt. +apply le_SO_minus. exact H. +qed. + +lemma Ztimes_Zplus_pos_neg_pos: \forall n,p,q:nat. +(pos n)*((neg p)+(pos q)) = (pos n)*(neg p)+ (pos n)*(pos q). +intros. +simplify. +change in match (p + n * (S p)) with (pred ((S n) * (S p))). +change in match (q + n * (S q)) with (pred ((S n) * (S q))). +rewrite < nat_compare_pred_pred. +rewrite < nat_compare_times_l. +rewrite < nat_compare_S_S. +apply (nat_compare_elim p q). +intro. +(* uff *) +change with (pos (pred ((S n) * (S (pred ((S q) - (S p)))))) = + pos (pred ((pred ((S n) * (S q))) - (pred ((S n) * (S p)))))). +rewrite < (times_minus1 n q p H).reflexivity. +intro.rewrite < H.simplify.reflexivity. +intro. +change with (neg (pred ((S n) * (S (pred ((S p) - (S q)))))) = + neg (pred ((pred ((S n) * (S p))) - (pred ((S n) * (S q)))))). +rewrite < (times_minus1 n p q H).reflexivity. +(* two more positivity conditions from nat_compare_pred_pred *) +apply lt_O_times_S_S. +apply lt_O_times_S_S. +qed. + +lemma Ztimes_Zplus_pos_pos_neg: \forall n,p,q:nat. +(pos n)*((pos p)+(neg q)) = (pos n)*(pos p)+ (pos n)*(neg q). +intros. +rewrite < sym_Zplus. +rewrite > Ztimes_Zplus_pos_neg_pos. +apply sym_Zplus. +qed. + +lemma distributive2_Ztimes_pos_Zplus: +distributive2 nat Z (\lambda n,z. (pos n) * z) Zplus. +change with (\forall n,y,z. +(pos n) * (y + z) = (pos n) * y + (pos n) * z). +intros.elim y. + reflexivity. + elim z. + reflexivity. + change with + (pos (pred ((S n) * ((S n1) + (S n2)))) = + pos (pred ((S n) * (S n1) + (S n) * (S n2)))). + rewrite < distr_times_plus.reflexivity. + apply Ztimes_Zplus_pos_pos_neg. + elim z. + reflexivity. + apply Ztimes_Zplus_pos_neg_pos. + change with + (neg (pred ((S n) * ((S n1) + (S n2)))) = + neg (pred ((S n) * (S n1) + (S n) * (S n2)))). + rewrite < distr_times_plus.reflexivity. +qed. + +variant distr_Ztimes_Zplus_pos: \forall n,y,z. +(pos n) * (y + z) = ((pos n) * y + (pos n) * z) \def +distributive2_Ztimes_pos_Zplus. + +lemma distributive2_Ztimes_neg_Zplus : +distributive2 nat Z (\lambda n,z. (neg n) * z) Zplus. +change with (\forall n,y,z. +(neg n) * (y + z) = (neg n) * y + (neg n) * z). +intros. +rewrite > Ztimes_neg_Zopp. +rewrite > distr_Ztimes_Zplus_pos. +rewrite > Zopp_Zplus. +rewrite < Ztimes_neg_Zopp. rewrite < Ztimes_neg_Zopp. +reflexivity. +qed. + +variant distr_Ztimes_Zplus_neg: \forall n,y,z. +(neg n) * (y + z) = (neg n) * y + (neg n) * z \def +distributive2_Ztimes_neg_Zplus. + +theorem distributive_Ztimes_Zplus: distributive Z Ztimes Zplus. +change with (\forall x,y,z:Z. x * (y + z) = x*y + x*z). +intros.elim x. +(* case x = OZ *) +simplify.reflexivity. +(* case x = pos n *) +apply distr_Ztimes_Zplus_pos. +(* case x = neg n *) +apply distr_Ztimes_Zplus_neg. +qed. + +variant distr_Ztimes_Zplus: \forall x,y,z. +x * (y + z) = x*y + x*z \def +distributive_Ztimes_Zplus. diff --git a/helm/software/matita/library/Z/z.ma b/helm/software/matita/library/Z/z.ma new file mode 100644 index 000000000..ea50a2cd9 --- /dev/null +++ b/helm/software/matita/library/Z/z.ma @@ -0,0 +1,173 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/Z/z". + +include "datatypes/bool.ma". +include "nat/nat.ma". + +inductive Z : Set \def + OZ : Z +| pos : nat \to Z +| neg : nat \to Z. + +definition Z_of_nat \def +\lambda n. match n with +[ O \Rightarrow OZ +| (S n)\Rightarrow pos n]. + +coercion cic:/matita/Z/z/Z_of_nat.con. + +definition neg_Z_of_nat \def +\lambda n. match n with +[ O \Rightarrow OZ +| (S n)\Rightarrow neg n]. + +definition abs \def +\lambda z. + match z with +[ OZ \Rightarrow O +| (pos n) \Rightarrow n +| (neg n) \Rightarrow n]. + +definition OZ_test \def +\lambda z. +match z with +[ OZ \Rightarrow true +| (pos n) \Rightarrow false +| (neg n) \Rightarrow false]. + +theorem OZ_test_to_Prop :\forall z:Z. +match OZ_test z with +[true \Rightarrow z=OZ +|false \Rightarrow z \neq OZ]. +intros.elim z. +simplify.reflexivity. +simplify. unfold Not. intros (H). +discriminate H. +simplify. unfold Not. intros (H). +discriminate H. +qed. + +(* discrimination *) +theorem injective_pos: injective nat Z pos. +unfold injective. +intros. +change with (abs (pos x) = abs (pos y)). +apply eq_f.assumption. +qed. + +variant inj_pos : \forall n,m:nat. pos n = pos m \to n = m +\def injective_pos. + +theorem injective_neg: injective nat Z neg. +unfold injective. +intros. +change with (abs (neg x) = abs (neg y)). +apply eq_f.assumption. +qed. + +variant inj_neg : \forall n,m:nat. neg n = neg m \to n = m +\def injective_neg. + +theorem not_eq_OZ_pos: \forall n:nat. OZ \neq pos n. +unfold Not.intros (n H). +discriminate H. +qed. + +theorem not_eq_OZ_neg :\forall n:nat. OZ \neq neg n. +unfold Not.intros (n H). +discriminate H. +qed. + +theorem not_eq_pos_neg :\forall n,m:nat. pos n \neq neg m. +unfold Not.intros (n m H). +discriminate H. +qed. + +theorem decidable_eq_Z : \forall x,y:Z. decidable (x=y). +intros.unfold decidable. +elim x. +(* goal: x=OZ *) + elim y. + (* goal: x=OZ y=OZ *) + left.reflexivity. + (* goal: x=OZ 2=2 *) + right.apply not_eq_OZ_pos. + (* goal: x=OZ 2=3 *) + right.apply not_eq_OZ_neg. +(* goal: x=pos *) + elim y. + (* goal: x=pos y=OZ *) + right.unfold Not.intro. + apply (not_eq_OZ_pos n). symmetry. assumption. + (* goal: x=pos y=pos *) + elim (decidable_eq_nat n n1:((n=n1) \lor ((n=n1) \to False))). + left.apply eq_f.assumption. + right.unfold Not.intros (H_inj).apply H. injection H_inj. assumption. + (* goal: x=pos y=neg *) + right.unfold Not.intro.apply (not_eq_pos_neg n n1). assumption. +(* goal: x=neg *) + elim y. + (* goal: x=neg y=OZ *) + right.unfold Not.intro. + apply (not_eq_OZ_neg n). symmetry. assumption. + (* goal: x=neg y=pos *) + right. unfold Not.intro. apply (not_eq_pos_neg n1 n). symmetry. assumption. + (* goal: x=neg y=neg *) + elim (decidable_eq_nat n n1:((n=n1) \lor ((n=n1) \to False))). + left.apply eq_f.assumption. + right.unfold Not.intro.apply H.apply injective_neg.assumption. +qed. + +(* end discrimination *) + +definition Zsucc \def +\lambda z. match z with +[ OZ \Rightarrow pos O +| (pos n) \Rightarrow pos (S n) +| (neg n) \Rightarrow + match n with + [ O \Rightarrow OZ + | (S p) \Rightarrow neg p]]. + +definition Zpred \def +\lambda z. match z with +[ OZ \Rightarrow neg O +| (pos n) \Rightarrow + match n with + [ O \Rightarrow OZ + | (S p) \Rightarrow pos p] +| (neg n) \Rightarrow neg (S n)]. + +theorem Zpred_Zsucc: \forall z:Z. Zpred (Zsucc z) = z. +intros. +elim z. + reflexivity. + reflexivity. + elim n. + reflexivity. + reflexivity. +qed. + +theorem Zsucc_Zpred: \forall z:Z. Zsucc (Zpred z) = z. +intros. +elim z. + reflexivity. + elim n. + reflexivity. + reflexivity. + reflexivity. +qed. + diff --git a/helm/software/matita/library/algebra/groups.ma b/helm/software/matita/library/algebra/groups.ma new file mode 100644 index 000000000..04a00c6f7 --- /dev/null +++ b/helm/software/matita/library/algebra/groups.ma @@ -0,0 +1,610 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/algebra/groups/". + +include "algebra/monoids.ma". +include "nat/le_arith.ma". +include "datatypes/bool.ma". +include "nat/compare.ma". + +record PreGroup : Type ≝ + { premonoid:> PreMonoid; + opp: premonoid -> premonoid + }. + +record isGroup (G:PreGroup) : Prop ≝ + { is_monoid: isMonoid G; + opp_is_left_inverse: is_left_inverse (mk_Monoid ? is_monoid) (opp G); + opp_is_right_inverse: is_right_inverse (mk_Monoid ? is_monoid) (opp G) + }. + +record Group : Type ≝ + { pregroup:> PreGroup; + group_properties:> isGroup pregroup + }. + +(*notation < "G" +for @{ 'monoid $G }. + +interpretation "Monoid coercion" 'monoid G = + (cic:/matita/algebra/groups/monoid.con G).*) + +notation < "G" +for @{ 'type_of_group $G }. + +interpretation "Type_of_group coercion" 'type_of_group G = + (cic:/matita/algebra/groups/Type_of_Group.con G). + +notation < "G" +for @{ 'magma_of_group $G }. + +interpretation "magma_of_group coercion" 'magma_of_group G = + (cic:/matita/algebra/groups/Magma_of_Group.con G). + +notation "hvbox(x \sup (-1))" with precedence 89 +for @{ 'gopp $x }. + +interpretation "Group inverse" 'gopp x = + (cic:/matita/algebra/groups/opp.con _ x). + +definition left_cancellable ≝ + λT:Type. λop: T -> T -> T. + ∀x. injective ? ? (op x). + +definition right_cancellable ≝ + λT:Type. λop: T -> T -> T. + ∀x. injective ? ? (λz.op z x). + +theorem eq_op_x_y_op_x_z_to_eq: + ∀G:Group. left_cancellable G (op G). +intros; +unfold left_cancellable; +unfold injective; +intros (x y z); +rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G))); +rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G)) z); +rewrite < (opp_is_left_inverse ? (group_properties G) x); +rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); +rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); +apply eq_f; +assumption. +qed. + + +theorem eq_op_x_y_op_z_y_to_eq: + ∀G:Group. right_cancellable G (op G). +intros; +unfold right_cancellable; +unfold injective; +simplify;fold simplify (op G); +intros (x y z); +rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G))); +rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G)) z); +rewrite < (opp_is_right_inverse ? (group_properties G) x); +rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); +rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G)))); +rewrite > H; +reflexivity. +qed. + + +record finite_enumerable (T:Type) : Type ≝ + { order: nat; + repr: nat → T; + index_of: T → nat; + index_of_sur: ∀x.index_of x ≤ order; + index_of_repr: ∀n. n≤order → index_of (repr n) = n; + repr_index_of: ∀x. repr (index_of x) = x + }. + +notation "hvbox(C \sub i)" with precedence 89 +for @{ 'repr $C $i }. + +(* CSC: multiple interpretations in the same file are not considered in the + right order +interpretation "Finite_enumerable representation" 'repr C i = + (cic:/matita/algebra/groups/repr.con C _ i).*) + +notation < "hvbox(|C|)" with precedence 89 +for @{ 'card $C }. + +interpretation "Finite_enumerable order" 'card C = + (cic:/matita/algebra/groups/order.con C _). + +record finite_enumerable_SemiGroup : Type ≝ + { semigroup:> SemiGroup; + is_finite_enumerable:> finite_enumerable semigroup + }. + +notation < "S" +for @{ 'semigroup_of_finite_enumerable_semigroup $S }. + +interpretation "Semigroup_of_finite_enumerable_semigroup" + 'semigroup_of_finite_enumerable_semigroup S += + (cic:/matita/algebra/groups/semigroup.con S). + +notation < "S" +for @{ 'magma_of_finite_enumerable_semigroup $S }. + +interpretation "Magma_of_finite_enumerable_semigroup" + 'magma_of_finite_enumerable_semigroup S += + (cic:/matita/algebra/groups/Magma_of_finite_enumerable_SemiGroup.con S). + +notation < "S" +for @{ 'type_of_finite_enumerable_semigroup $S }. + +interpretation "Type_of_finite_enumerable_semigroup" + 'type_of_finite_enumerable_semigroup S += + (cic:/matita/algebra/groups/Type_of_finite_enumerable_SemiGroup.con S). + +interpretation "Finite_enumerable representation" 'repr S i = + (cic:/matita/algebra/groups/repr.con S + (cic:/matita/algebra/groups/is_finite_enumerable.con S) i). + +notation "hvbox(ι e)" with precedence 60 +for @{ 'index_of_finite_enumerable_semigroup $e }. + +interpretation "Index_of_finite_enumerable representation" + 'index_of_finite_enumerable_semigroup e += + (cic:/matita/algebra/groups/index_of.con _ + (cic:/matita/algebra/groups/is_finite_enumerable.con _) e). + + +(* several definitions/theorems to be moved somewhere else *) + +definition ltb ≝ λn,m. leb n m ∧ notb (eqb n m). + +theorem not_eq_to_le_to_lt: ∀n,m. n≠m → n≤m → n (S_pred m); + [ apply le_S_S; + assumption + | assumption + ] +]. +qed. + +theorem le_to_le_pred: + ∀n,m. n ≤ m → pred n ≤ pred m. +intros 2; +elim n; +[ simplify; + apply le_O_n +| simplify; + generalize in match H1; + clear H1; + elim m; + [ elim (not_le_Sn_O ? H1) + | simplify; + apply le_S_S_to_le; + assumption + ] +]. +qed. + +theorem lt_n_m_to_not_lt_m_Sn: ∀n,m. n < m → m ≮ S n. +intros; +unfold Not; +intro; +unfold lt in H; +unfold lt in H1; +generalize in match (le_S_S ? ? H); +intro; +generalize in match (transitive_le ? ? ? H2 H1); +intro; +apply (not_le_Sn_n ? H3). +qed. + +theorem lt_S_S: ∀n,m. n < m → S n < S m. +intros; +unfold lt in H; +apply (le_S_S ? ? H). +qed. + +theorem lt_O_S: ∀n. O < S n. +intro; +unfold lt; +apply le_S_S; +apply le_O_n. +qed. + +theorem le_n_m_to_lt_m_Sn_to_eq_n_m: ∀n,m. n ≤ m → m < S n → n=m. +intros; +unfold lt in H1; +generalize in match (le_S_S_to_le ? ? H1); +intro; +apply cic:/matita/nat/orders/antisym_le.con; +assumption. +qed. + +theorem pigeonhole: + ∀n:nat.∀f:nat→nat. + (∀x,y.x≤n → y≤n → f x = f y → x=y) → + (∀m. m ≤ n → f m ≤ n) → + ∀x. x≤n \to ∃y.f y = x ∧ y ≤ n. +intro; +elim n; +[ apply (ex_intro ? ? O); + split; + [ rewrite < (le_n_O_to_eq ? H2); + rewrite < (le_n_O_to_eq ? (H1 O ?)); + [ reflexivity + | apply le_n + ] + | apply le_n + ] +| clear n; + letin f' ≝ + (λx. + let fSn1 ≝ f (S n1) in + let fx ≝ f x in + match ltb fSn1 fx with + [ true ⇒ pred fx + | false ⇒ fx + ]); + cut (∀x,y. x ≤ n1 → y ≤ n1 → f' x = f' y → x=y); + [ cut (∀x. x ≤ n1 → f' x ≤ n1); + [ apply (nat_compare_elim (f (S n1)) x); + [ intro; + elim (H f' ? ? (pred x)); + [ simplify in H5; + clear Hcut; + clear Hcut1; + clear f'; + elim H5; + clear H5; + apply (ex_intro ? ? a); + split; + [ generalize in match (eq_f ? ? S ? ? H6); + clear H6; + intro; + rewrite < S_pred in H5; + [ generalize in match H4; + clear H4; + rewrite < H5; + clear H5; + apply (ltb_elim (f (S n1)) (f a)); + [ simplify; + intros; + rewrite < S_pred; + [ reflexivity + | apply (ltn_to_ltO ? ? H4) + ] + | simplify; + intros; + generalize in match (not_lt_to_le ? ? H4); + clear H4; + intro; + generalize in match (le_n_m_to_lt_m_Sn_to_eq_n_m ? ? H6 H5); + intro; + generalize in match (H1 ? ? ? ? H4); + [ intro; + | + | + ] + ] + | apply (ltn_to_ltO ? ? H4) + ] + | apply le_S; + assumption + ] + | apply Hcut + | apply Hcut1 + | apply le_S_S_to_le; + rewrite < S_pred; + exact H3 + ] + (* TODO: caso complicato, ma simile al terzo *) + | intros; + apply (ex_intro ? ? (S n1)); + split; + [ assumption + | constructor 1 + ] + | intro; + elim (H f' ? ? x); + [ simplify in H5; + clear Hcut; + clear Hcut1; + clear f'; + elim H5; + clear H5; + apply (ex_intro ? ? a); + split; + [ generalize in match H4; + clear H4; + rewrite < H6; + clear H6; + apply (ltb_elim (f (S n1)) (f a)); + [ simplify; + intros; + generalize in match (lt_S_S ? ? H5); + intro; + rewrite < S_pred in H6; + [ elim (lt_n_m_to_not_lt_m_Sn ? ? H4 H6) + | apply (ltn_to_ltO ? ? H4) + ] + | simplify; + intros; + reflexivity + ] + | apply le_S; + assumption + ] + | apply Hcut + | apply Hcut1 + | rewrite > (pred_Sn n1); + simplify; + generalize in match (H2 (S n1)); + intro; + generalize in match (lt_to_le_to_lt ? ? ? H4 (H5 (le_n ?))); + intro; + unfold lt in H6; + apply le_S_S_to_le; + assumption + ] + ] + | unfold f'; + simplify; + intro; + apply (ltb_elim (f (S n1)) (f x1)); + simplify; + intros; + [ generalize in match (H2 x1); + intro; + change in match n1 with (pred (S n1)); + apply le_to_le_pred; + apply H6; + apply le_S; + assumption + | generalize in match (H2 (S n1) (le_n ?)); + intro; + generalize in match (not_lt_to_le ? ? H4); + intro; + generalize in match (transitive_le ? ? ? H7 H6); + intro; + cut (f x1 ≠ f (S n1)); + [ generalize in match (not_eq_to_le_to_lt ? ? Hcut1 H7); + intro; + unfold lt in H9; + generalize in match (transitive_le ? ? ? H9 H6); + intro; + apply le_S_S_to_le; + assumption + | unfold Not; + intro; + generalize in match (H1 ? ? ? ? H9); + [ intro; + rewrite > H10 in H5; + apply (not_le_Sn_n ? H5) + | apply le_S; + assumption + | apply le_n + ] + ] + ] + ] + | intros 4; + unfold f'; + simplify; + apply (ltb_elim (f (S n1)) (f x1)); + simplify; + apply (ltb_elim (f (S n1)) (f y)); + simplify; + intros; + [ cut (f x1 = f y); + [ apply (H1 ? ? ? ? Hcut); + apply le_S; + assumption + | apply eq_pred_to_eq; + [ apply (ltn_to_ltO ? ? H7) + | apply (ltn_to_ltO ? ? H6) + | assumption + ] + ] + | (* pred (f x1) = f y absurd since y ≠ S n1 and thus f y ≠ f (S n1) + so that f y < f (S n1) < f x1; hence pred (f x1) = f y is absurd *) + cut (y < S n1); + [ generalize in match (lt_to_not_eq ? ? Hcut); + intro; + cut (f y ≠ f (S n1)); + [ cut (f y < f (S n1)); + [ rewrite < H8 in Hcut2; + unfold lt in Hcut2; + unfold lt in H7; + generalize in match (le_S_S ? ? Hcut2); + intro; + generalize in match (transitive_le ? ? ? H10 H7); + intros; + rewrite < (S_pred (f x1)) in H11; + [ elim (not_le_Sn_n ? H11) + | fold simplify ((f (S n1)) < (f x1)) in H7; + apply (ltn_to_ltO ? ? H7) + ] + | apply not_eq_to_le_to_lt; + [ assumption + | apply not_lt_to_le; + assumption + ] + ] + | unfold Not; + intro; + apply H9; + apply (H1 ? ? ? ? H10); + [ apply lt_to_le; + assumption + | constructor 1 + ] + ] + | unfold lt; + apply le_S_S; + assumption + ] + | (* f x1 = pred (f y) absurd since it implies S (f x1) = f y and + f x1 ≤ f (S n1) < f y = S (f x1) so that f x1 = f (S n1); by + injectivity x1 = S n1 that is absurd since x1 ≤ n1 *) + generalize in match (eq_f ? ? S ? ? H8); + intro; + rewrite < S_pred in H9; + [ rewrite < H9 in H6; + generalize in match (not_lt_to_le ? ? H7); + intro; + unfold lt in H6; + generalize in match (le_S_S ? ? H10); + intro; + generalize in match (antisym_le ? ? H11 H6); + intro; + generalize in match (inj_S ? ? H12); + intro; + generalize in match (H1 ? ? ? ? H13); + [ intro; + rewrite > H14 in H4; + elim (not_le_Sn_n ? H4) + | apply le_S; + assumption + | apply le_n + ] + | apply (ltn_to_ltO ? ? H6) + ] + | apply (H1 ? ? ? ? H8); + apply le_S; + assumption + ] + ] +]. +qed. + +theorem foo: + ∀G:finite_enumerable_SemiGroup. + left_cancellable ? (op G) → + right_cancellable ? (op G) → + ∃e:G. isMonoid (mk_PreMonoid G e). +intros; +letin f ≝ (λn.ι(G \sub O · G \sub n)); +cut (∀n.n ≤ order ? (is_finite_enumerable G) → ∃m.f m = n); +[ letin EX ≝ (Hcut O ?); + [ apply le_O_n + | clearbody EX; + clear Hcut; + unfold f in EX; + elim EX; + clear EX; + letin HH ≝ (eq_f ? ? (repr ? (is_finite_enumerable G)) ? ? H2); + clearbody HH; + rewrite > (repr_index_of ? (is_finite_enumerable G)) in HH; + apply (ex_intro ? ? (G \sub a)); + letin GOGO ≝ (refl_eq ? (repr ? (is_finite_enumerable G) O)); + clearbody GOGO; + rewrite < HH in GOGO; + rewrite < HH in GOGO:(? ? % ?); + rewrite > (associative ? G) in GOGO; + letin GaGa ≝ (H ? ? ? GOGO); + clearbody GaGa; + clear GOGO; + constructor 1; + [ simplify; + apply (semigroup_properties G) + | unfold is_left_unit; intro; + letin GaxGax ≝ (refl_eq ? (G \sub a ·x)); + clearbody GaxGax; + rewrite < GaGa in GaxGax:(? ? % ?); + rewrite > (associative ? (semigroup_properties G)) in GaxGax; + apply (H ? ? ? GaxGax) + | unfold is_right_unit; intro; + letin GaxGax ≝ (refl_eq ? (x·G \sub a)); + clearbody GaxGax; + rewrite < GaGa in GaxGax:(? ? % ?); + rewrite < (associative ? (semigroup_properties G)) in GaxGax; + apply (H1 ? ? ? GaxGax) + ] + ] +| apply pigeonhole +]. diff --git a/helm/software/matita/library/algebra/monoids.ma b/helm/software/matita/library/algebra/monoids.ma new file mode 100644 index 000000000..c3f3cc48e --- /dev/null +++ b/helm/software/matita/library/algebra/monoids.ma @@ -0,0 +1,85 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/algebra/monoids/". + +include "algebra/semigroups.ma". + +record PreMonoid : Type ≝ + { magma:> Magma; + e: magma + }. + +notation < "M" for @{ 'pmmagma $M }. +interpretation "premonoid magma coercion" 'pmmagma M = + (cic:/matita/algebra/monoids/magma.con M). + +record isMonoid (M:PreMonoid) : Prop ≝ + { is_semi_group: isSemiGroup M; + e_is_left_unit: + is_left_unit (mk_SemiGroup ? is_semi_group) (e M); + e_is_right_unit: + is_right_unit (mk_SemiGroup ? is_semi_group) (e M) + }. + +record Monoid : Type ≝ + { premonoid:> PreMonoid; + monoid_properties:> isMonoid premonoid + }. + +notation < "M" for @{ 'semigroup $M }. +interpretation "premonoid coercion" 'premonoid M = + (cic:/matita/algebra/monoids/premonoid.con M). + +notation < "M" for @{ 'typeofmonoid $M }. +interpretation "premonoid coercion" 'typeofmonoid M = + (cic:/matita/algebra/monoids/Type_of_Monoid.con M). + +notation < "M" for @{ 'magmaofmonoid $M }. +interpretation "premonoid coercion" 'magmaofmonoid M = + (cic:/matita/algebra/monoids/Magma_of_Monoid.con M). + +notation "1" with precedence 89 +for @{ 'munit }. + +interpretation "Monoid unit" 'munit = + (cic:/matita/algebra/monoids/e.con _). + +definition is_left_inverse ≝ + λM:Monoid. + λopp: M → M. + ∀x:M. (opp x)·x = 1. + +definition is_right_inverse ≝ + λM:Monoid. + λopp: M → M. + ∀x:M. x·(opp x) = 1. + +theorem is_left_inverse_to_is_right_inverse_to_eq: + ∀M:Monoid. ∀l,r. + is_left_inverse M l → is_right_inverse M r → + ∀x:M. l x = r x. + intros; + generalize in match (H x); intro; + generalize in match (eq_f ? ? (λy.y·(r x)) ? ? H2); + simplify; fold simplify (op M); + intro; clear H2; + generalize in match (associative ? (is_semi_group ? (monoid_properties M))); + intro; + rewrite > H2 in H3; clear H2; + rewrite > H1 in H3; + rewrite > (e_is_left_unit ? (monoid_properties M)) in H3; + rewrite > (e_is_right_unit ? (monoid_properties M)) in H3; + assumption. +qed. diff --git a/helm/software/matita/library/algebra/semigroups.ma b/helm/software/matita/library/algebra/semigroups.ma new file mode 100644 index 000000000..5b461d1a4 --- /dev/null +++ b/helm/software/matita/library/algebra/semigroups.ma @@ -0,0 +1,64 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/algebra/semigroups". + +include "higher_order_defs/functions.ma". + +(* Magmas *) + +record Magma : Type ≝ + { carrier:> Type; + op: carrier → carrier → carrier + }. + +notation < "M" for @{ 'carrier $M }. +interpretation "carrier coercion" 'carrier S = + (cic:/matita/algebra/semigroups/carrier.con S). + +notation "hvbox(a break \middot b)" + left associative with precedence 55 +for @{ 'magma_op $a $b }. + +interpretation "magma operation" 'magma_op a b = + (cic:/matita/algebra/semigroups/op.con _ a b). + +(* Semigroups *) + +record isSemiGroup (M:Magma) : Prop ≝ + { associative: associative ? (op M) }. + +record SemiGroup : Type ≝ + { magma:> Magma; + semigroup_properties:> isSemiGroup magma + }. + +notation < "S" for @{ 'magma $S }. +interpretation "magma coercion" 'magma S = + (cic:/matita/algebra/semigroups/magma.con S). + +definition is_left_unit ≝ + λS:SemiGroup. λe:S. ∀x:S. e·x = x. + +definition is_right_unit ≝ + λS:SemiGroup. λe:S. ∀x:S. x·e = x. + +theorem is_left_unit_to_is_right_unit_to_eq: + ∀S:SemiGroup. ∀e,e':S. + is_left_unit ? e → is_right_unit ? e' → e=e'. + intros; + rewrite < (H e'); + rewrite < (H1 e) in \vdash (? ? % ?); + reflexivity. +qed. diff --git a/helm/software/matita/library/datatypes/bool.ma b/helm/software/matita/library/datatypes/bool.ma new file mode 100644 index 000000000..3292e6789 --- /dev/null +++ b/helm/software/matita/library/datatypes/bool.ma @@ -0,0 +1,126 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/datatypes/bool/". + +include "logic/equality.ma". + +inductive bool : Set \def + | true : bool + | false : bool. + +theorem bool_elim: \forall P:bool \to Prop. \forall b:bool. + (b = true \to P true) + \to (b = false \to P false) + \to P b. + intros 2 (P b). + elim b; + [ apply H; reflexivity + | apply H1; reflexivity + ] +qed. + +theorem not_eq_true_false : true \neq false. +unfold Not.intro. +change with +match true with +[ true \Rightarrow False +| flase \Rightarrow True]. +rewrite > H.simplify.exact I. +qed. + +definition notb : bool \to bool \def +\lambda b:bool. + match b with + [ true \Rightarrow false + | false \Rightarrow true ]. + +theorem notb_elim: \forall b:bool.\forall P:bool \to Prop. +match b with +[ true \Rightarrow P false +| false \Rightarrow P true] \to P (notb b). +intros 2.elim b.exact H. exact H. +qed. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "boolean not" 'not x = (cic:/matita/datatypes/bool/notb.con x). + +definition andb : bool \to bool \to bool\def +\lambda b1,b2:bool. + match b1 with + [ true \Rightarrow b2 + | false \Rightarrow false ]. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "boolean and" 'and x y = (cic:/matita/datatypes/bool/andb.con x y). + +theorem andb_elim: \forall b1,b2:bool. \forall P:bool \to Prop. +match b1 with +[ true \Rightarrow P b2 +| false \Rightarrow P false] \to P (b1 \land b2). +intros 3.elim b1.exact H. exact H. +qed. + +theorem andb_true_true: \forall b1,b2. (b1 \land b2) = true \to b1 = true. +intro. elim b1. +reflexivity. +assumption. +qed. + +definition orb : bool \to bool \to bool\def +\lambda b1,b2:bool. + match b1 with + [ true \Rightarrow true + | false \Rightarrow b2]. + +theorem orb_elim: \forall b1,b2:bool. \forall P:bool \to Prop. +match b1 with +[ true \Rightarrow P true +| false \Rightarrow P b2] \to P (orb b1 b2). +intros 3.elim b1.exact H. exact H. +qed. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "boolean or" 'or x y = (cic:/matita/datatypes/bool/orb.con x y). + +definition if_then_else : bool \to Prop \to Prop \to Prop \def +\lambda b:bool.\lambda P,Q:Prop. +match b with +[ true \Rightarrow P +| false \Rightarrow Q]. + +(*CSC: missing notation for if_then_else *) + +theorem bool_to_decidable_eq: + \forall b1,b2:bool. decidable (b1=b2). + intros. + unfold decidable. + elim b1. + elim b2. + left. reflexivity. + right. exact not_eq_true_false. + elim b2. + right. unfold Not. intro. + apply not_eq_true_false. + symmetry. exact H. + left. reflexivity. +qed. + +theorem P_x_to_P_x_to_eq: + \forall A:Set. \forall P: A \to bool. + \forall x:A. \forall p1,p2:P x = true. p1 = p2. + intros. + apply eq_to_eq_to_eq_p_q. + exact bool_to_decidable_eq. +qed. diff --git a/helm/software/matita/library/datatypes/compare.ma b/helm/software/matita/library/datatypes/compare.ma new file mode 100644 index 000000000..c4fd119a5 --- /dev/null +++ b/helm/software/matita/library/datatypes/compare.ma @@ -0,0 +1,27 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/datatypes/compare/". + +inductive compare :Set \def +| LT : compare +| EQ : compare +| GT : compare. + +definition compare_invert: compare \to compare \def + \lambda c. + match c with + [ LT \Rightarrow GT + | EQ \Rightarrow EQ + | GT \Rightarrow LT ]. diff --git a/helm/software/matita/library/datatypes/constructors.ma b/helm/software/matita/library/datatypes/constructors.ma new file mode 100644 index 000000000..2ac1cb376 --- /dev/null +++ b/helm/software/matita/library/datatypes/constructors.ma @@ -0,0 +1,38 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/datatypes/constructors/". +include "logic/equality.ma". + +inductive void : Set \def. + +inductive Prod (A,B:Set) : Set \def +pair : A \to B \to Prod A B. + +definition fst \def \lambda A,B:Set.\lambda p: Prod A B. +match p with +[(pair a b) \Rightarrow a]. + +definition snd \def \lambda A,B:Set.\lambda p: Prod A B. +match p with +[(pair a b) \Rightarrow b]. + +theorem eq_pair_fst_snd: \forall A,B:Set.\forall p: Prod A B. +p = pair A B (fst A B p) (snd A B p). +intros.elim p.simplify.reflexivity. +qed. + +inductive Sum (A,B:Set) : Set \def + inl : A \to Sum A B +| inr : B \to Sum A B. diff --git a/helm/software/matita/library/higher_order_defs/functions.ma b/helm/software/matita/library/higher_order_defs/functions.ma new file mode 100644 index 000000000..a1b54c80c --- /dev/null +++ b/helm/software/matita/library/higher_order_defs/functions.ma @@ -0,0 +1,67 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/higher_order_defs/functions/". + +include "logic/equality.ma". + +definition compose \def + \lambda A,B,C:Type.\lambda f:(B\to C).\lambda g:(A\to B).\lambda x:A. + f (g x). + +notation "hvbox(a break \circ b)" + left associative with precedence 70 +for @{ 'compose $a $b }. + +interpretation "function composition" 'compose f g = + (cic:/matita/higher_order_defs/functions/compose.con _ _ _ f g). + +definition injective: \forall A,B:Type.\forall f:A \to B.Prop +\def \lambda A,B.\lambda f. + \forall x,y:A.f x = f y \to x=y. + +definition surjective: \forall A,B:Type.\forall f:A \to B.Prop +\def \lambda A,B.\lambda f. + \forall z:B. \exists x:A.z=f x. + +definition symmetric: \forall A:Type.\forall f:A \to A\to A.Prop +\def \lambda A.\lambda f.\forall x,y.f x y = f y x. + +definition symmetric2: \forall A,B:Type.\forall f:A \to A\to B.Prop +\def \lambda A,B.\lambda f.\forall x,y.f x y = f y x. + +definition associative: \forall A:Type.\forall f:A \to A\to A.Prop +\def \lambda A.\lambda f.\forall x,y,z.f (f x y) z = f x (f y z). + +theorem eq_f_g_h: + \forall A,B,C,D:Type. + \forall f:C \to D.\forall g:B \to C.\forall h:A \to B. + f \circ (g \circ h) = (f \circ g) \circ h. + intros. + reflexivity. +qed. + +(* functions and relations *) +definition monotonic : \forall A:Type.\forall R:A \to A \to Prop. +\forall f:A \to A.Prop \def +\lambda A. \lambda R. \lambda f. \forall x,y:A.R x y \to R (f x) (f y). + +(* functions and functions *) +definition distributive: \forall A:Type.\forall f,g:A \to A \to A.Prop +\def \lambda A.\lambda f,g.\forall x,y,z:A. f x (g y z) = g (f x y) (f x z). + +definition distributive2: \forall A,B:Type.\forall f:A \to B \to B. +\forall g: B\to B\to B. Prop +\def \lambda A,B.\lambda f,g.\forall x:A.\forall y,z:B. f x (g y z) = g (f x y) (f x z). + diff --git a/helm/software/matita/library/higher_order_defs/ordering.ma b/helm/software/matita/library/higher_order_defs/ordering.ma new file mode 100644 index 000000000..c2b351d7a --- /dev/null +++ b/helm/software/matita/library/higher_order_defs/ordering.ma @@ -0,0 +1,22 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/higher_order_defs/ordering/". + +include "logic/equality.ma". + +definition antisymmetric: \forall A:Type.\forall R:A \to A \to Prop.Prop +\def +\lambda A.\lambda R.\forall x,y:A.R x y \to R y x \to x=y. + diff --git a/helm/software/matita/library/higher_order_defs/relations.ma b/helm/software/matita/library/higher_order_defs/relations.ma new file mode 100644 index 000000000..029b229dc --- /dev/null +++ b/helm/software/matita/library/higher_order_defs/relations.ma @@ -0,0 +1,33 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/higher_order_defs/relations/". + +include "logic/connectives.ma". + +definition reflexive: \forall A:Type.\forall R:A \to A \to Prop.Prop +\def +\lambda A.\lambda R.\forall x:A.R x x. + +definition symmetric: \forall A:Type.\forall R:A \to A \to Prop.Prop +\def +\lambda A.\lambda R.\forall x,y:A.R x y \to R y x. + +definition transitive: \forall A:Type.\forall R:A \to A \to Prop.Prop +\def +\lambda A.\lambda R.\forall x,y,z:A.R x y \to R y z \to R x z. + +definition irreflexive: \forall A:Type.\forall R:A \to A \to Prop.Prop +\def +\lambda A.\lambda R.\forall x:A.\lnot (R x x). diff --git a/helm/software/matita/library/legacy/coq.ma b/helm/software/matita/library/legacy/coq.ma new file mode 100644 index 000000000..d3c74fe21 --- /dev/null +++ b/helm/software/matita/library/legacy/coq.ma @@ -0,0 +1,58 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/legacy/coq/". + +(* aritmetic operators *) + +interpretation "Coq's natural plus" 'plus x y = (cic:/Coq/Init/Peano/plus.con x y). +interpretation "Coq's real plus" 'plus x y = (cic:/Coq/Reals/Rdefinitions/Rplus.con x y). +interpretation "Coq's binary integer plus" 'plus x y = (cic:/Coq/ZArith/BinInt/Zplus.con x y). +interpretation "Coq's binary positive plus" 'plus x y = (cic:/Coq/NArith/BinPos/Pplus.con x y). +interpretation "Coq's natural minus" 'minus x y = (cic:/Coq/Init/Peano/minus.con x y). +interpretation "Coq's real minus" 'minus x y = (cic:/Coq/Reals/Rdefinitions/Rminus.con x y). +interpretation "Coq's binary integer minus" 'minus x y = (cic:/Coq/ZArith/BinInt/Zminus.con x y). +interpretation "Coq's binary positive minus" 'minus x y = (cic:/Coq/NArith/BinPos/Pminus.con x y). +interpretation "Coq's natural times" 'times x y = (cic:/Coq/Init/Peano/mult.con x y). +interpretation "Coq's real times" 'times x y = (cic:/Coq/Reals/Rdefinitions/Rmult.con x y). +interpretation "Coq's binary positive times" 'times x y = (cic:/Coq/NArith/BinPos/Pmult.con x y). +interpretation "Coq's binary integer times" 'times x y = (cic:/Coq/ZArith/BinInt/Zmult.con x y). +interpretation "Coq's real power" 'power x y = (cic:/Coq/Reals/Rfunctions/pow.con x y). +interpretation "Coq's integer power" 'power x y = (cic:/Coq/ZArith/Zpower/Zpower.con x y). +interpretation "Coq's real divide" 'divide x y = (cic:/Coq/Reals/Rdefinitions/Rdiv.con x y). +interpretation "Coq's real unary minus" 'uminus x = (cic:/Coq/Reals/Rdefinitions/Ropp.con x). +interpretation "Coq's binary integer negative sign" 'uminus x = (cic:/Coq/ZArith/BinInt/Z.ind#xpointer(1/1/3) x). +interpretation "Coq's binary integer unary minus" 'uminus x = (cic:/Coq/ZArith/BinInt/Zopp.con x). + +(* logical operators *) + +interpretation "Coq's logical and" 'and x y = (cic:/Coq/Init/Logic/and.ind#xpointer(1/1) x y). +interpretation "Coq's logical or" 'or x y = (cic:/Coq/Init/Logic/or.ind#xpointer(1/1) x y). +interpretation "Coq's logical not" 'not x = (cic:/Coq/Init/Logic/not.con x). +interpretation "Coq's exists" 'exists \eta.x = (cic:/Coq/Init/Logic/ex.ind#xpointer(1/1) _ x). + +(* relational operators *) + +interpretation "Coq's natural 'less or equal to'" 'leq x y = (cic:/Coq/Init/Peano/le.ind#xpointer(1/1) x y). +interpretation "Coq's real 'less or equal to'" 'leq x y = (cic:/Coq/Reals/Rdefinitions/Rle.con x y). +interpretation "Coq's natural 'greater or equal to'" 'geq x y = (cic:/Coq/Init/Peano/ge.con x y). +interpretation "Coq's real 'greater or equal to'" 'geq x y = (cic:/Coq/Reals/Rdefinitions/Rge.con x y). +interpretation "Coq's natural 'less than'" 'lt x y = (cic:/Coq/Init/Peano/lt.con x y). +interpretation "Coq's real 'less than'" 'lt x y = (cic:/Coq/Reals/Rdefinitions/Rlt.con x y). +interpretation "Coq's natural 'greater than'" 'gt x y = (cic:/Coq/Init/Peano/gt.con x y). +interpretation "Coq's real 'greater than'" 'gt x y = (cic:/Coq/Reals/Rdefinitions/Rgt.con x y). + +interpretation "Coq's leibnitz's equality" 'eq x y = (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y). +interpretation "Coq's not equal to (leibnitz)" 'neq x y = (cic:/Coq/Init/Logic/not.con (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y)). + diff --git a/helm/software/matita/library/list/list.ma b/helm/software/matita/library/list/list.ma new file mode 100644 index 000000000..ffa2c8ef9 --- /dev/null +++ b/helm/software/matita/library/list/list.ma @@ -0,0 +1,112 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/list/". +include "logic/equality.ma". +include "higher_order_defs/functions.ma". + +inductive list (A:Set) : Set := + | nil: list A + | cons: A -> list A -> list A. + +notation "hvbox(hd break :: tl)" + right associative with precedence 46 + for @{'cons $hd $tl}. + +notation "[ list0 x sep ; ]" + non associative with precedence 90 + for ${fold right @'nil rec acc @{'cons $x $acc}}. + +notation "hvbox(l1 break @ l2)" + right associative with precedence 47 + for @{'append $l1 $l2 }. + +interpretation "nil" 'nil = (cic:/matita/list/list.ind#xpointer(1/1/1) _). +interpretation "cons" 'cons hd tl = + (cic:/matita/list/list.ind#xpointer(1/1/2) _ hd tl). + +(* theorem test_notation: [O; S O; S (S O)] = O :: S O :: S (S O) :: []. *) + +theorem nil_cons: + \forall A:Set.\forall l:list A.\forall a:A. + a::l <> []. + intros; + unfold Not; + intros; + discriminate H. +qed. + +let rec id_list A (l: list A) on l := + match l with + [ nil => [] + | (cons hd tl) => hd :: id_list A tl ]. + +let rec append A (l1: list A) l2 on l1 := + match l1 with + [ nil => l2 + | (cons hd tl) => hd :: append A tl l2 ]. + +definition tail := \lambda A:Set. \lambda l: list A. + match l with + [ nil => [] + | (cons hd tl) => tl]. + +interpretation "append" 'append l1 l2 = (cic:/matita/list/append.con _ l1 l2). + +theorem append_nil: \forall A:Set.\forall l:list A.l @ [] = l. + intros; + elim l; + [ reflexivity; + | simplify; + rewrite > H; + reflexivity; + ] +qed. + +theorem associative_append: \forall A:Set.associative (list A) (append A). + intros; unfold; intros; + elim x; + [ simplify; + reflexivity; + | simplify; + rewrite > H; + reflexivity; + ] +qed. + +theorem cons_append_commute: + \forall A:Set.\forall l1,l2:list A.\forall a:A. + a :: (l1 @ l2) = (a :: l1) @ l2. + intros; + reflexivity; +qed. + +(* +theorem nil_append_nil_both: + \forall A:Set.\forall l1,l2:list A. + l1 @ l2 = [] \to l1 = [] \land l2 = []. +*) + +(* +include "nat/nat.ma". + +theorem test_notation: [O; S O; S (S O)] = O :: S O :: S (S O) :: []. +reflexivity. +qed. + +theorem test_append: [O;O;O;O;O;O] = [O;O;O] @ [O;O] @ [O]. +simplify. +reflexivity. +qed. +*) diff --git a/helm/software/matita/library/list/sort.ma b/helm/software/matita/library/list/sort.ma new file mode 100644 index 000000000..939cecede --- /dev/null +++ b/helm/software/matita/library/list/sort.ma @@ -0,0 +1,172 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/list/sort/". + +include "datatypes/bool.ma". +include "datatypes/constructors.ma". +include "list/list.ma". + +let rec mem (A:Set) (eq: A → A → bool) x (l: list A) on l ≝ + match l with + [ nil ⇒ false + | (cons a l') ⇒ + match eq x a with + [ true ⇒ true + | false ⇒ mem A eq x l' + ] + ]. + +let rec ordered (A:Set) (le: A → A → bool) (l: list A) on l ≝ + match l with + [ nil ⇒ true + | (cons x l') ⇒ + match l' with + [ nil ⇒ true + | (cons y l'') ⇒ + le x y \land ordered A le l' + ] + ]. + +let rec insert (A:Set) (le: A → A → bool) x (l: list A) on l ≝ + match l with + [ nil ⇒ [x] + | (cons he l') ⇒ + match le x he with + [ true ⇒ x::l + | false ⇒ he::(insert A le x l') + ] + ]. + +lemma insert_ind : + ∀A:Set. ∀le: A → A → bool. ∀x. + ∀P:(list A → list A → Prop). + ∀H:(∀l: list A. l=[] → P [] [x]). + ∀H2: + (∀l: list A. ∀he. ∀l'. P l' (insert ? le x l') → + le x he = false → l=he::l' → P (he::l') (he::(insert ? le x l'))). + ∀H3: + (∀l: list A. ∀he. ∀l'. P l' (insert ? le x l') → + le x he = true → l=he::l' → P (he::l') (x::he::l')). + ∀l:list A. P l (insert ? le x l). + intros. + apply ( + let rec insert_ind (l: list A) \def + match l in list + return + λli. + l = li → P li (insert ? le x li) + with + [ nil ⇒ H l + | (cons he l') ⇒ + match le x he + return + λb. le x he = b → l = he::l' → + P (he::l') + (match b with + [ true ⇒ x::he::l' + | false ⇒ he::(insert ? le x l') ]) + with + [ true ⇒ H2 l he l' (insert_ind l') + | false ⇒ H1 l he l' (insert_ind l') + ] + (refl_eq ? (le x he)) + ] (refl_eq ? l) in insert_ind l). +qed. + + +let rec insertionsort (A:Set) (le: A → A → bool) (l: list A) on l ≝ + match l with + [ nil ⇒ [] + | (cons he l') ⇒ + let l'' ≝ insertionsort A le l' in + insert A le he l'' + ]. + +lemma ordered_injective: + ∀A:Set. ∀le:A → A → bool. + ∀l:list A. ordered A le l = true → ordered A le (tail A l) = true. + intros 3 (A le l). + elim l + [ simplify; reflexivity; + | simplify; + generalize in match H1; + clear H1; + elim l1; + [ simplify; reflexivity; + | cut ((le s s1 \land ordered A le (s1::l2)) = true); + [ generalize in match Hcut; + apply andb_elim; + elim (le s s1); + [ simplify; + fold simplify (ordered ? le (s1::l2)); + intros; assumption; + | simplify; + intros (Habsurd); + apply False_ind; + apply (not_eq_true_false); + symmetry; + assumption + ] + | exact H2; + ] + ] + ]. +qed. + +lemma insert_sorted: + \forall A:Set. \forall le:A\to A\to bool. + (\forall a,b:A. le a b = false \to le b a = true) \to + \forall l:list A. \forall x:A. + ordered A le l = true \to ordered A le (insert A le x l) = true. + intros 5 (A le H l x). + apply (insert_ind ? ? ? (λl,il. ordered ? le l = true → ordered ? le il = true)); + clear l; intros; simplify; intros; + [2: rewrite > H1; + [ generalize in match (H ? ? H2); clear H2; intro; + generalize in match H4; clear H4; + elim l'; simplify; + [ rewrite > H5; + reflexivity + | elim (le x s); simplify; + [ rewrite > H5; + reflexivity + | simplify in H4; + rewrite > (andb_true_true ? ? H4); + reflexivity + ] + ] + | apply (ordered_injective ? ? ? H4) + ] + | reflexivity + | rewrite > H2; + rewrite > H4; + reflexivity + ]. +qed. + +theorem insertionsort_sorted: + ∀A:Set. + ∀le:A → A → bool.∀eq:A → A → bool. + (∀a,b:A. le a b = false → le b a = true) \to + ∀l:list A. + ordered A le (insertionsort A le l) = true. + intros 5 (A le eq le_tot l). + elim l; + [ simplify; + reflexivity; + | apply (insert_sorted ? ? le_tot (insertionsort ? le l1) s); + assumption; + ] +qed. \ No newline at end of file diff --git a/helm/software/matita/library/logic/connectives.ma b/helm/software/matita/library/logic/connectives.ma new file mode 100644 index 000000000..4cbea3529 --- /dev/null +++ b/helm/software/matita/library/logic/connectives.ma @@ -0,0 +1,90 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/logic/connectives/". + +inductive True: Prop \def +I : True. + +default "true" cic:/matita/logic/connectives/True.ind. + +inductive False: Prop \def . + +default "false" cic:/matita/logic/connectives/False.ind. + +definition Not: Prop \to Prop \def +\lambda A. (A \to False). + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "logical not" 'not x = (cic:/matita/logic/connectives/Not.con x). + +theorem absurd : \forall A,C:Prop. A \to \lnot A \to C. +intros. elim (H1 H). +qed. + +default "absurd" cic:/matita/logic/connectives/absurd.con. + +inductive And (A,B:Prop) : Prop \def + conj : A \to B \to (And A B). + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "logical and" 'and x y = (cic:/matita/logic/connectives/And.ind#xpointer(1/1) x y). + +theorem proj1: \forall A,B:Prop. A \land B \to A. +intros. elim H. assumption. +qed. + +theorem proj2: \forall A,B:Prop. A \land B \to B. +intros. elim H. assumption. +qed. + +inductive Or (A,B:Prop) : Prop \def + or_introl : A \to (Or A B) + | or_intror : B \to (Or A B). + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "logical or" 'or x y = + (cic:/matita/logic/connectives/Or.ind#xpointer(1/1) x y). + +theorem Or_ind': + \forall A,B:Prop. + \forall P: A \lor B \to Prop. + (\forall p:A. P (or_introl ? ? p)) \to + (\forall q:B. P (or_intror ? ? q)) \to + \forall p:A \lor B. P p. + intros. + apply + (match p return \lambda p.P p with + [(or_introl p) \Rightarrow H p + |(or_intror q) \Rightarrow H1 q]). +qed. + +definition decidable : Prop \to Prop \def \lambda A:Prop. A \lor \lnot A. + +inductive ex (A:Type) (P:A \to Prop) : Prop \def + ex_intro: \forall x:A. P x \to ex A P. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "exists" 'exists \eta.x = + (cic:/matita/logic/connectives/ex.ind#xpointer(1/1) _ x). + +notation < "hvbox(\exists ident i opt (: ty) break . p)" + right associative with precedence 20 +for @{ 'exists ${default + @{\lambda ${ident i} : $ty. $p)} + @{\lambda ${ident i} . $p}}}. + +inductive ex2 (A:Type) (P,Q:A \to Prop) : Prop \def + ex_intro2: \forall x:A. P x \to Q x \to ex2 A P Q. + diff --git a/helm/software/matita/library/logic/equality.ma b/helm/software/matita/library/logic/equality.ma new file mode 100644 index 000000000..b87dc6c95 --- /dev/null +++ b/helm/software/matita/library/logic/equality.ma @@ -0,0 +1,214 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/logic/equality/". + +include "higher_order_defs/relations.ma". + +inductive eq (A:Type) (x:A) : A \to Prop \def + refl_eq : eq A x x. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "leibnitz's equality" + 'eq x y = (cic:/matita/logic/equality/eq.ind#xpointer(1/1) _ x y). +(*CSC: the URI must disappear: there is a bug now *) +interpretation "leibnitz's non-equality" + 'neq x y = (cic:/matita/logic/connectives/Not.con + (cic:/matita/logic/equality/eq.ind#xpointer(1/1) _ x y)). + +theorem eq_ind': + \forall A. \forall x:A. \forall P: \forall y:A. x=y \to Prop. + P ? (refl_eq ? x) \to \forall y:A. \forall p:x=y. P y p. + intros. + exact + (match p return \lambda y. \lambda p.P y p with + [refl_eq \Rightarrow H]). +qed. + +theorem reflexive_eq : \forall A:Type. reflexive A (eq A). +simplify.intros.apply refl_eq. +qed. + +theorem symmetric_eq: \forall A:Type. symmetric A (eq A). +unfold symmetric.intros.elim H. apply refl_eq. +qed. + +theorem sym_eq : \forall A:Type.\forall x,y:A. x=y \to y=x +\def symmetric_eq. + +theorem transitive_eq : \forall A:Type. transitive A (eq A). +unfold transitive.intros.elim H1.assumption. +qed. + +theorem trans_eq : \forall A:Type.\forall x,y,z:A. x=y \to y=z \to x=z +\def transitive_eq. + +theorem eq_elim_r: + \forall A:Type.\forall x:A. \forall P: A \to Prop. + P x \to \forall y:A. y=x \to P y. +intros. elim (sym_eq ? ? ? H1).assumption. +qed. + +default "equality" + cic:/matita/logic/equality/eq.ind + cic:/matita/logic/equality/sym_eq.con + cic:/matita/logic/equality/trans_eq.con + cic:/matita/logic/equality/eq_ind.con + cic:/matita/logic/equality/eq_elim_r.con. + +theorem eq_f: \forall A,B:Type.\forall f:A\to B. +\forall x,y:A. x=y \to f x = f y. +intros.elim H.reflexivity. +qed. + +theorem eq_f2: \forall A,B,C:Type.\forall f:A\to B \to C. +\forall x1,x2:A. \forall y1,y2:B. +x1=x2 \to y1=y2 \to f x1 y1 = f x2 y2. +intros.elim H1.elim H.reflexivity. +qed. + +definition comp \def + \lambda A. + \lambda x,y,y':A. + \lambda eq1:x=y. + \lambda eq2:x=y'. + eq_ind ? ? (\lambda a.a=y') eq2 ? eq1. + +lemma trans_sym_eq: + \forall A. + \forall x,y:A. + \forall u:x=y. + comp ? ? ? ? u u = refl_eq ? y. + intros. + apply (eq_ind' ? ? ? ? ? u). + reflexivity. +qed. + +definition nu \def + \lambda A. + \lambda H: \forall x,y:A. decidable (x=y). + \lambda x,y. \lambda p:x=y. + match H x y with + [ (or_introl p') \Rightarrow p' + | (or_intror K) \Rightarrow False_ind ? (K p) ]. + +theorem nu_constant: + \forall A. + \forall H: \forall x,y:A. decidable (x=y). + \forall x,y:A. + \forall u,v:x=y. + nu ? H ? ? u = nu ? H ? ? v. + intros. + unfold nu. + unfold decidable in H. + apply (Or_ind' ? ? ? ? ? (H x y)); simplify. + intro; reflexivity. + intro; elim (q u). +qed. + +definition nu_inv \def + \lambda A. + \lambda H: \forall x,y:A. decidable (x=y). + \lambda x,y:A. + \lambda v:x=y. + comp ? ? ? ? (nu ? H ? ? (refl_eq ? x)) v. + +theorem nu_left_inv: + \forall A. + \forall H: \forall x,y:A. decidable (x=y). + \forall x,y:A. + \forall u:x=y. + nu_inv ? H ? ? (nu ? H ? ? u) = u. + intros. + apply (eq_ind' ? ? ? ? ? u). + unfold nu_inv. + apply trans_sym_eq. +qed. + +theorem eq_to_eq_to_eq_p_q: + \forall A. \forall x,y:A. + (\forall x,y:A. decidable (x=y)) \to + \forall p,q:x=y. p=q. + intros. + rewrite < (nu_left_inv ? H ? ? p). + rewrite < (nu_left_inv ? H ? ? q). + elim (nu_constant ? H ? ? q). + reflexivity. +qed. + +(*CSC: alternative proof that does not pollute the environment with + technical lemmata. Unfortunately, it is a pain to do without proper + support for let-ins. +theorem eq_to_eq_to_eq_p_q: + \forall A. \forall x,y:A. + (\forall x,y:A. decidable (x=y)) \to + \forall p,q:x=y. p=q. +intros. +letin nu \def + (\lambda x,y. \lambda p:x=y. + match H x y with + [ (or_introl p') \Rightarrow p' + | (or_intror K) \Rightarrow False_ind ? (K p) ]). +cut + (\forall q:x=y. + eq_ind ? ? (\lambda z. z=y) (nu ? ? q) ? (nu ? ? (refl_eq ? x)) + = q). +focus 8. + clear q; clear p. + intro. + apply (eq_ind' ? ? ? ? ? q); + fold simplify (nu ? ? (refl_eq ? x)). + generalize in match (nu ? ? (refl_eq ? x)); intro. + apply + (eq_ind' A x + (\lambda y. \lambda u. + eq_ind A x (\lambda a.a=y) u y u = refl_eq ? y) + ? x H1). + reflexivity. +unfocus. +rewrite < (Hcut p); fold simplify (nu ? ? p). +rewrite < (Hcut q); fold simplify (nu ? ? q). +apply (Or_ind' (x=x) (x \neq x) + (\lambda p:decidable (x=x). eq_ind A x (\lambda z.z=y) (nu x y p) x + ([\lambda H1.eq A x x] + match p with + [(or_introl p') \Rightarrow p' + |(or_intror K) \Rightarrow False_ind (x=x) (K (refl_eq A x))]) = + eq_ind A x (\lambda z.z=y) (nu x y q) x + ([\lambda H1.eq A x x] + match p with + [(or_introl p') \Rightarrow p' + |(or_intror K) \Rightarrow False_ind (x=x) (K (refl_eq A x))])) + ? ? (H x x)). +intro; simplify; reflexivity. +intro q; elim (q (refl_eq ? x)). +qed. +*) + +(* +theorem a:\forall x.x=x\land True. +[ +2:intros; + split; + [ + exact (refl_eq Prop x); + | + exact I; + ] +1: + skip +] +qed. +*) + diff --git a/helm/software/matita/library/nat/chinese_reminder.ma b/helm/software/matita/library/nat/chinese_reminder.ma new file mode 100644 index 000000000..30cc7440f --- /dev/null +++ b/helm/software/matita/library/nat/chinese_reminder.ma @@ -0,0 +1,251 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/chinese_reminder". + +include "nat/exp.ma". +include "nat/gcd.ma". +include "nat/permutation.ma". +include "nat/congruence.ma". + +theorem and_congruent_congruent: \forall m,n,a,b:nat. O < n \to O < m \to +gcd n m = (S O) \to ex nat (\lambda x. congruent x a m \land congruent x b n). +intros. +cut (\exists c,d.c*n - d*m = (S O) \lor d*m - c*n = (S O)). +elim Hcut.elim H3.elim H4. +apply (ex_intro nat ? ((a+b*m)*a1*n-b*a2*m)). +split. +(* congruent to a *) +cut (a1*n = a2*m + (S O)). +rewrite > assoc_times. +rewrite > Hcut1. +rewrite < (sym_plus ? (a2*m)). +rewrite > distr_times_plus. +rewrite < times_n_SO. +rewrite > assoc_plus. +rewrite < assoc_times. +rewrite < times_plus_l. +rewrite > eq_minus_plus_plus_minus. +rewrite < times_minus_l. +rewrite > sym_plus. +apply (eq_times_plus_to_congruent ? ? ? ((b+(a+b*m)*a2)-b*a2)). +assumption.reflexivity. +apply le_times_l. +apply (trans_le ? ((a+b*m)*a2)). +apply le_times_l. +apply (trans_le ? (b*m)). +rewrite > times_n_SO in \vdash (? % ?). +apply le_times_r.assumption. +apply le_plus_n. +apply le_plus_n. +apply minus_to_plus. +apply lt_to_le. +change with (O + a2*m < a1*n). +apply lt_minus_to_plus. +rewrite > H5.unfold lt.apply le_n. +assumption. +(* congruent to b *) +cut (a2*m = a1*n - (S O)). +rewrite > (assoc_times b a2). +rewrite > Hcut1. +rewrite > distr_times_minus. +rewrite < assoc_times. +rewrite < eq_plus_minus_minus_minus. +rewrite < times_n_SO. +rewrite < times_minus_l. +rewrite < sym_plus. +apply (eq_times_plus_to_congruent ? ? ? ((a+b*m)*a1-b*a1)). +assumption.reflexivity. +rewrite > assoc_times. +apply le_times_r. +apply (trans_le ? (a1*n - a2*m)). +rewrite > H5.apply le_n. +apply (le_minus_m ? (a2*m)). +apply le_times_l. +apply le_times_l. +apply (trans_le ? (b*m)). +rewrite > times_n_SO in \vdash (? % ?). +apply le_times_r.assumption. +apply le_plus_n. +apply sym_eq. apply plus_to_minus. +rewrite > sym_plus. +apply minus_to_plus. +apply lt_to_le. +change with (O + a2*m < a1*n). +apply lt_minus_to_plus. +rewrite > H5.unfold lt.apply le_n. +assumption. +(* and now the symmetric case; the price to pay for working + in nat instead than Z *) +apply (ex_intro nat ? ((b+a*n)*a2*m-a*a1*n)). +split. +(* congruent to a *) +cut (a1*n = a2*m - (S O)). +rewrite > (assoc_times a a1). +rewrite > Hcut1. +rewrite > distr_times_minus. +rewrite < assoc_times. +rewrite < eq_plus_minus_minus_minus. +rewrite < times_n_SO. +rewrite < times_minus_l. +rewrite < sym_plus. +apply (eq_times_plus_to_congruent ? ? ? ((b+a*n)*a2-a*a2)). +assumption.reflexivity. +rewrite > assoc_times. +apply le_times_r. +apply (trans_le ? (a2*m - a1*n)). +rewrite > H5.apply le_n. +apply (le_minus_m ? (a1*n)). +rewrite > assoc_times.rewrite > assoc_times. +apply le_times_l. +apply (trans_le ? (a*n)). +rewrite > times_n_SO in \vdash (? % ?). +apply le_times_r.assumption. +apply le_plus_n. +apply sym_eq.apply plus_to_minus. +rewrite > sym_plus. +apply minus_to_plus. +apply lt_to_le. +change with (O + a1*n < a2*m). +apply lt_minus_to_plus. +rewrite > H5.unfold lt.apply le_n. +assumption. +(* congruent to a *) +cut (a2*m = a1*n + (S O)). +rewrite > assoc_times. +rewrite > Hcut1. +rewrite > (sym_plus (a1*n)). +rewrite > distr_times_plus. +rewrite < times_n_SO. +rewrite < assoc_times. +rewrite > assoc_plus. +rewrite < times_plus_l. +rewrite > eq_minus_plus_plus_minus. +rewrite < times_minus_l. +rewrite > sym_plus. +apply (eq_times_plus_to_congruent ? ? ? ((a+(b+a*n)*a1)-a*a1)). +assumption.reflexivity. +apply le_times_l. +apply (trans_le ? ((b+a*n)*a1)). +apply le_times_l. +apply (trans_le ? (a*n)). +rewrite > times_n_SO in \vdash (? % ?). +apply le_times_r. +assumption. +apply le_plus_n. +apply le_plus_n. +apply minus_to_plus. +apply lt_to_le. +change with (O + a1*n < a2*m). +apply lt_minus_to_plus. +rewrite > H5.unfold lt.apply le_n. +assumption. +(* proof of the cut *) +rewrite < H2. +apply eq_minus_gcd. +qed. + +theorem and_congruent_congruent_lt: \forall m,n,a,b:nat. O < n \to O < m \to +gcd n m = (S O) \to +ex nat (\lambda x. (congruent x a m \land congruent x b n) \land + (x < m*n)). +intros.elim (and_congruent_congruent m n a b). +elim H3. +apply (ex_intro ? ? (a1 \mod (m*n))). +split.split. +apply (transitive_congruent m ? a1). +unfold congruent. +apply sym_eq. +change with (congruent a1 (a1 \mod (m*n)) m). +rewrite < sym_times. +apply congruent_n_mod_times. +assumption.assumption.assumption. +apply (transitive_congruent n ? a1). +unfold congruent. +apply sym_eq. +change with (congruent a1 (a1 \mod (m*n)) n). +apply congruent_n_mod_times. +assumption.assumption.assumption. +apply lt_mod_m_m. +rewrite > (times_n_O O). +apply lt_times.assumption.assumption. +assumption.assumption.assumption. +qed. + +definition cr_pair : nat \to nat \to nat \to nat \to nat \def +\lambda n,m,a,b. +min (pred (n*m)) (\lambda x. andb (eqb (x \mod n) a) (eqb (x \mod m) b)). + +theorem cr_pair1: cr_pair (S (S O)) (S (S (S O))) O O = O. +reflexivity. +qed. + +theorem cr_pair2: cr_pair (S(S O)) (S(S(S O))) (S O) O = (S(S(S O))). +simplify. +reflexivity. +qed. + +theorem cr_pair3: cr_pair (S(S O)) (S(S(S O))) (S O) (S(S O)) = (S(S(S(S(S O))))). +reflexivity. +qed. + +theorem cr_pair4: cr_pair (S(S(S(S(S O))))) (S(S(S(S(S(S(S O))))))) (S(S(S O))) (S(S O)) = +(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S(S O))))))))))))))))))))))). +reflexivity. +qed. + +theorem mod_cr_pair : \forall m,n,a,b. a \lt m \to b \lt n \to +gcd n m = (S O) \to +(cr_pair m n a b) \mod m = a \land (cr_pair m n a b) \mod n = b. +intros. +cut (andb (eqb ((cr_pair m n a b) \mod m) a) + (eqb ((cr_pair m n a b) \mod n) b) = true). +generalize in match Hcut. +apply andb_elim. +apply eqb_elim.intro. +rewrite > H3. +change with +(eqb ((cr_pair m n a b) \mod n) b = true \to +a = a \land (cr_pair m n a b) \mod n = b). +intro.split.reflexivity. +apply eqb_true_to_eq.assumption. +intro. +change with (false = true \to +(cr_pair m n a b) \mod m = a \land (cr_pair m n a b) \mod n = b). +intro.apply False_ind. +apply not_eq_true_false.apply sym_eq.assumption. +apply (f_min_aux_true +(\lambda x. andb (eqb (x \mod m) a) (eqb (x \mod n) b)) (pred (m*n)) (pred (m*n))). +elim (and_congruent_congruent_lt m n a b). +apply (ex_intro ? ? a1).split.split. +rewrite < minus_n_n.apply le_O_n. +elim H3.apply le_S_S_to_le.apply (trans_le ? (m*n)). +assumption.apply (nat_case (m*n)).apply le_O_n. +intro. +rewrite < pred_Sn.apply le_n. +elim H3.elim H4. +apply andb_elim. +cut (a1 \mod m = a). +cut (a1 \mod n = b). +rewrite > (eq_to_eqb_true ? ? Hcut). +rewrite > (eq_to_eqb_true ? ? Hcut1). +simplify.reflexivity. +rewrite < (lt_to_eq_mod b n).assumption. +assumption. +rewrite < (lt_to_eq_mod a m).assumption. +assumption. +apply (le_to_lt_to_lt ? b).apply le_O_n.assumption. +apply (le_to_lt_to_lt ? a).apply le_O_n.assumption. +assumption. +qed. \ No newline at end of file diff --git a/helm/software/matita/library/nat/compare.ma b/helm/software/matita/library/nat/compare.ma new file mode 100644 index 000000000..264731580 --- /dev/null +++ b/helm/software/matita/library/nat/compare.ma @@ -0,0 +1,227 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/compare". + +include "datatypes/bool.ma". +include "datatypes/compare.ma". +include "nat/orders.ma". + +let rec eqb n m \def +match n with + [ O \Rightarrow + match m with + [ O \Rightarrow true + | (S q) \Rightarrow false] + | (S p) \Rightarrow + match m with + [ O \Rightarrow false + | (S q) \Rightarrow eqb p q]]. + +theorem eqb_to_Prop: \forall n,m:nat. +match (eqb n m) with +[ true \Rightarrow n = m +| false \Rightarrow n \neq m]. +intros. +apply (nat_elim2 +(\lambda n,m:nat.match (eqb n m) with +[ true \Rightarrow n = m +| false \Rightarrow n \neq m])). +intro.elim n1. +simplify.reflexivity. +simplify.apply not_eq_O_S. +intro. +simplify.unfold Not. +intro. apply (not_eq_O_S n1).apply sym_eq.assumption. +intros.simplify. +generalize in match H. +elim ((eqb n1 m1)). +simplify.apply eq_f.apply H1. +simplify.unfold Not.intro.apply H1.apply inj_S.assumption. +qed. + +theorem eqb_elim : \forall n,m:nat.\forall P:bool \to Prop. +(n=m \to (P true)) \to (n \neq m \to (P false)) \to (P (eqb n m)). +intros. +cut +(match (eqb n m) with +[ true \Rightarrow n = m +| false \Rightarrow n \neq m] \to (P (eqb n m))). +apply Hcut.apply eqb_to_Prop. +elim (eqb n m). +apply ((H H2)). +apply ((H1 H2)). +qed. + +theorem eqb_n_n: \forall n. eqb n n = true. +intro.elim n.simplify.reflexivity. +simplify.assumption. +qed. + +theorem eqb_true_to_eq: \forall n,m:nat. +eqb n m = true \to n = m. +intros. +change with +match true with +[ true \Rightarrow n = m +| false \Rightarrow n \neq m]. +rewrite < H. +apply eqb_to_Prop. +qed. + +theorem eqb_false_to_not_eq: \forall n,m:nat. +eqb n m = false \to n \neq m. +intros. +change with +match false with +[ true \Rightarrow n = m +| false \Rightarrow n \neq m]. +rewrite < H. +apply eqb_to_Prop. +qed. + +theorem eq_to_eqb_true: \forall n,m:nat. +n = m \to eqb n m = true. +intros.apply (eqb_elim n m). +intros. reflexivity. +intros.apply False_ind.apply (H1 H). +qed. + +theorem not_eq_to_eqb_false: \forall n,m:nat. +\lnot (n = m) \to eqb n m = false. +intros.apply (eqb_elim n m). +intros. apply False_ind.apply (H H1). +intros.reflexivity. +qed. + +let rec leb n m \def +match n with + [ O \Rightarrow true + | (S p) \Rightarrow + match m with + [ O \Rightarrow false + | (S q) \Rightarrow leb p q]]. + +theorem leb_to_Prop: \forall n,m:nat. +match (leb n m) with +[ true \Rightarrow n \leq m +| false \Rightarrow n \nleq m]. +intros. +apply (nat_elim2 +(\lambda n,m:nat.match (leb n m) with +[ true \Rightarrow n \leq m +| false \Rightarrow n \nleq m])). +simplify.exact le_O_n. +simplify.exact not_le_Sn_O. +intros 2.simplify.elim ((leb n1 m1)). +simplify.apply le_S_S.apply H. +simplify.unfold Not.intros.apply H.apply le_S_S_to_le.assumption. +qed. + +theorem leb_elim: \forall n,m:nat. \forall P:bool \to Prop. +(n \leq m \to (P true)) \to (n \nleq m \to (P false)) \to +P (leb n m). +intros. +cut +(match (leb n m) with +[ true \Rightarrow n \leq m +| false \Rightarrow n \nleq m] \to (P (leb n m))). +apply Hcut.apply leb_to_Prop. +elim (leb n m). +apply ((H H2)). +apply ((H1 H2)). +qed. + +let rec nat_compare n m: compare \def +match n with +[ O \Rightarrow + match m with + [ O \Rightarrow EQ + | (S q) \Rightarrow LT ] +| (S p) \Rightarrow + match m with + [ O \Rightarrow GT + | (S q) \Rightarrow nat_compare p q]]. + +theorem nat_compare_n_n: \forall n:nat. nat_compare n n = EQ. +intro.elim n. +simplify.reflexivity. +simplify.assumption. +qed. + +theorem nat_compare_S_S: \forall n,m:nat. +nat_compare n m = nat_compare (S n) (S m). +intros.simplify.reflexivity. +qed. + +theorem S_pred: \forall n:nat.lt O n \to eq nat n (S (pred n)). +intro.elim n.apply False_ind.exact (not_le_Sn_O O H). +apply eq_f.apply pred_Sn. +qed. + +theorem nat_compare_pred_pred: +\forall n,m:nat.lt O n \to lt O m \to +eq compare (nat_compare n m) (nat_compare (pred n) (pred m)). +intros. +apply (lt_O_n_elim n H). +apply (lt_O_n_elim m H1). +intros. +simplify.reflexivity. +qed. + +theorem nat_compare_to_Prop: \forall n,m:nat. +match (nat_compare n m) with + [ LT \Rightarrow n < m + | EQ \Rightarrow n=m + | GT \Rightarrow m < n ]. +intros. +apply (nat_elim2 (\lambda n,m.match (nat_compare n m) with + [ LT \Rightarrow n < m + | EQ \Rightarrow n=m + | GT \Rightarrow m < n ])). +intro.elim n1.simplify.reflexivity. +simplify.unfold lt.apply le_S_S.apply le_O_n. +intro.simplify.unfold lt.apply le_S_S. apply le_O_n. +intros 2.simplify.elim ((nat_compare n1 m1)). +simplify. unfold lt. apply le_S_S.apply H. +simplify. apply eq_f. apply H. +simplify. unfold lt.apply le_S_S.apply H. +qed. + +theorem nat_compare_n_m_m_n: \forall n,m:nat. +nat_compare n m = compare_invert (nat_compare m n). +intros. +apply (nat_elim2 (\lambda n,m. nat_compare n m = compare_invert (nat_compare m n))). +intros.elim n1.simplify.reflexivity. +simplify.reflexivity. +intro.elim n1.simplify.reflexivity. +simplify.reflexivity. +intros.simplify.elim H.reflexivity. +qed. + +theorem nat_compare_elim : \forall n,m:nat. \forall P:compare \to Prop. +(n < m \to P LT) \to (n=m \to P EQ) \to (m < n \to P GT) \to +(P (nat_compare n m)). +intros. +cut (match (nat_compare n m) with +[ LT \Rightarrow n < m +| EQ \Rightarrow n=m +| GT \Rightarrow m < n] \to +(P (nat_compare n m))). +apply Hcut.apply nat_compare_to_Prop. +elim ((nat_compare n m)). +apply ((H H3)). +apply ((H1 H3)). +apply ((H2 H3)). +qed. diff --git a/helm/software/matita/library/nat/congruence.ma b/helm/software/matita/library/nat/congruence.ma new file mode 100644 index 000000000..af744cf34 --- /dev/null +++ b/helm/software/matita/library/nat/congruence.ma @@ -0,0 +1,177 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/congruence". + +include "nat/relevant_equations.ma". +include "nat/primes.ma". + +definition S_mod: nat \to nat \to nat \def +\lambda n,m:nat. (S m) \mod n. + +definition congruent: nat \to nat \to nat \to Prop \def +\lambda n,m,p:nat. mod n p = mod m p. + +theorem congruent_n_n: \forall n,p:nat.congruent n n p. +intros.unfold congruent.reflexivity. +qed. + +theorem transitive_congruent: \forall p:nat. transitive nat +(\lambda n,m. congruent n m p). +intros.unfold transitive.unfold congruent.intros. +whd.apply (trans_eq ? ? (y \mod p)). +apply H.apply H1. +qed. + +theorem le_to_mod: \forall n,m:nat. n \lt m \to n = n \mod m. +intros. +apply (div_mod_spec_to_eq2 n m O n (n/m) (n \mod m)). +constructor 1.assumption.simplify.reflexivity. +apply div_mod_spec_div_mod. +apply (le_to_lt_to_lt O n m).apply le_O_n.assumption. +qed. + +theorem mod_mod : \forall n,p:nat. O

    (div_mod (n \mod p) p) in \vdash (? ? % ?). +rewrite > (eq_div_O ? p).reflexivity. +(* uffa: hint non lo trova lt vs. le*) +apply lt_mod_m_m. +assumption. +assumption. +qed. + +theorem mod_times_mod : \forall n,m,p:nat. O

    times_plus_l. +rewrite > assoc_plus. +rewrite < div_mod. +rewrite > assoc_times. +rewrite < div_mod. +reflexivity. +rewrite > (times_n_O O). +apply lt_times. +assumption.assumption.assumption. +qed. + +theorem congruent_n_mod_n : +\forall n,p:nat. O < p \to congruent n (n \mod p) p. +intros.unfold congruent. +apply mod_mod.assumption. +qed. + +theorem congruent_n_mod_times : +\forall n,m,p:nat. O < p \to O < m \to congruent n (n \mod (m*p)) p. +intros.unfold congruent. +apply mod_times_mod.assumption.assumption. +qed. + +theorem eq_times_plus_to_congruent: \forall n,m,p,r:nat. O< p \to +n = r*p+m \to congruent n m p. +intros.unfold congruent. +apply (div_mod_spec_to_eq2 n p (div n p) (mod n p) (r +(div m p)) (mod m p)). +apply div_mod_spec_div_mod.assumption. +constructor 1. +apply lt_mod_m_m.assumption. +rewrite > sym_times. +rewrite > distr_times_plus. +rewrite > sym_times. +rewrite > (sym_times p). +rewrite > assoc_plus. +rewrite < div_mod. +assumption.assumption. +qed. + +theorem divides_to_congruent: \forall n,m,p:nat. O < p \to m \le n \to +divides p (n - m) \to congruent n m p. +intros.elim H2. +apply (eq_times_plus_to_congruent n m p n2). +assumption. +rewrite < sym_plus. +apply minus_to_plus.assumption. +rewrite > sym_times. assumption. +qed. + +theorem congruent_to_divides: \forall n,m,p:nat. +O < p \to congruent n m p \to divides p (n - m). +intros.unfold congruent in H1. +apply (witness ? ? ((n / p)-(m / p))). +rewrite > sym_times. +rewrite > (div_mod n p) in \vdash (? ? % ?). +rewrite > (div_mod m p) in \vdash (? ? % ?). +rewrite < (sym_plus (m \mod p)). +rewrite < H1. +rewrite < (eq_minus_minus_minus_plus ? (n \mod p)). +rewrite < minus_plus_m_m. +apply sym_eq. +apply times_minus_l. +assumption.assumption. +qed. + +theorem mod_times: \forall n,m,p:nat. +O < p \to mod (n*m) p = mod ((mod n p)*(mod m p)) p. +intros. +change with (congruent (n*m) ((mod n p)*(mod m p)) p). +apply (eq_times_plus_to_congruent ? ? p +((n / p)*p*(m / p) + (n / p)*(m \mod p) + (n \mod p)*(m / p))). +assumption. +apply (trans_eq ? ? (((n/p)*p+(n \mod p))*((m/p)*p+(m \mod p)))). +apply eq_f2. +apply div_mod.assumption. +apply div_mod.assumption. +apply (trans_eq ? ? (((n/p)*p)*((m/p)*p) + (n/p)*p*(m \mod p) + +(n \mod p)*((m / p)*p) + (n \mod p)*(m \mod p))). +apply times_plus_plus. +apply eq_f2. +rewrite < assoc_times. +rewrite > (assoc_times (n/p) p (m \mod p)). +rewrite > (sym_times p (m \mod p)). +rewrite < (assoc_times (n/p) (m \mod p) p). +rewrite < times_plus_l. +rewrite < (assoc_times (n \mod p)). +rewrite < times_plus_l. +apply eq_f2. +apply eq_f2.reflexivity. +reflexivity.reflexivity. +reflexivity. +qed. + +theorem congruent_times: \forall n,m,n1,m1,p. O < p \to congruent n n1 p \to +congruent m m1 p \to congruent (n*m) (n1*m1) p. +unfold congruent. +intros. +rewrite > (mod_times n m p H). +rewrite > H1. +rewrite > H2. +apply sym_eq. +apply mod_times.assumption. +qed. + +theorem congruent_pi: \forall f:nat \to nat. \forall n,m,p:nat.O < p \to +congruent (pi n f m) (pi n (\lambda m. mod (f m) p) m) p. +intros. +elim n.change with (congruent (f m) (f m \mod p) p). +apply congruent_n_mod_n.assumption. +change with (congruent ((f (S n1+m))*(pi n1 f m)) +(((f (S n1+m))\mod p)*(pi n1 (\lambda m.(f m) \mod p) m)) p). +apply congruent_times. +assumption. +apply congruent_n_mod_n.assumption. +assumption. +qed. diff --git a/helm/software/matita/library/nat/count.ma b/helm/software/matita/library/nat/count.ma new file mode 100644 index 000000000..20913fa60 --- /dev/null +++ b/helm/software/matita/library/nat/count.ma @@ -0,0 +1,246 @@ +(**************************************************************************) +(* __ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/count". + +include "nat/relevant_equations.ma". +include "nat/sigma_and_pi.ma". +include "nat/permutation.ma". + +theorem sigma_f_g : \forall n,m:nat.\forall f,g:nat \to nat. +sigma n (\lambda p.f p + g p) m = sigma n f m + sigma n g m. +intros.elim n. +simplify.reflexivity. +simplify.rewrite > H. +rewrite > assoc_plus. +rewrite < (assoc_plus (g (S (n1+m)))). +rewrite > (sym_plus (g (S (n1+m)))). +rewrite > (assoc_plus (sigma n1 f m)). +rewrite < assoc_plus. +reflexivity. +qed. + +theorem sigma_plus: \forall n,p,m:nat.\forall f:nat \to nat. +sigma (S (p+n)) f m = sigma p (\lambda x.(f ((S n) + x))) m + sigma n f m. +intros. elim p. +simplify. +rewrite < (sym_plus n m).reflexivity. +simplify. +rewrite > assoc_plus in \vdash (? ? ? %). +rewrite < H. +simplify. +rewrite < plus_n_Sm. +rewrite > (sym_plus n). +rewrite > assoc_plus. +rewrite < (sym_plus m). +rewrite < (assoc_plus n1). +reflexivity. +qed. + +theorem sigma_plus1: \forall n,p,m:nat.\forall f:nat \to nat. +sigma (p+(S n)) f m = sigma p (\lambda x.(f ((S n) + x))) m + sigma n f m. +intros. elim p. +simplify.reflexivity. +simplify. +rewrite > assoc_plus in \vdash (? ? ? %). +rewrite < H. +rewrite < plus_n_Sm. +rewrite < plus_n_Sm.simplify. +rewrite < (sym_plus n). +rewrite > assoc_plus. +rewrite < (sym_plus m). +rewrite < (assoc_plus n). +reflexivity. +qed. + +theorem eq_sigma_sigma : \forall n,m:nat.\forall f:nat \to nat. +sigma (pred ((S n)*(S m))) f O = +sigma m (\lambda a.(sigma n (\lambda b.f (b*(S m) + a)) O)) O. +intro.elim n.simplify. +rewrite < plus_n_O. +apply eq_sigma.intros.reflexivity. +change with +(sigma (m+(S n1)*(S m)) f O = +sigma m (\lambda a.(f ((S(n1+O))*(S m)+a)) + (sigma n1 (\lambda b.f (b*(S m)+a)) O)) O). +rewrite > sigma_f_g. +rewrite < plus_n_O. +rewrite < H. +rewrite > (S_pred ((S n1)*(S m))). +apply sigma_plus1. +simplify.unfold lt.apply le_S_S.apply le_O_n. +qed. + +theorem eq_sigma_sigma1 : \forall n,m:nat.\forall f:nat \to nat. +sigma (pred ((S n)*(S m))) f O = +sigma n (\lambda a.(sigma m (\lambda b.f (b*(S n) + a)) O)) O. +intros. +rewrite > sym_times. +apply eq_sigma_sigma. +qed. + +theorem sigma_times: \forall n,m,p:nat.\forall f:nat \to nat. +(sigma n f m)*p = sigma n (\lambda i.(f i) * p) m. +intro. elim n.simplify.reflexivity. +simplify.rewrite < H. +apply times_plus_l. +qed. + +definition bool_to_nat: bool \to nat \def +\lambda b. match b with +[ true \Rightarrow (S O) +| false \Rightarrow O ]. + +theorem bool_to_nat_andb: \forall a,b:bool. +bool_to_nat (andb a b) = (bool_to_nat a)*(bool_to_nat b). +intros. elim a.elim b. +simplify.reflexivity. +reflexivity. +reflexivity. +qed. + +definition count : nat \to (nat \to bool) \to nat \def +\lambda n.\lambda f. sigma (pred n) (\lambda n.(bool_to_nat (f n))) O. + +theorem count_times:\forall n,m:nat. +\forall f,f1,f2:nat \to bool. +\forall g:nat \to nat \to nat. +\forall g1,g2: nat \to nat. +(\forall a,b:nat. a < (S n) \to b < (S m) \to (g b a) < (S n)*(S m)) \to +(\forall a,b:nat. a < (S n) \to b < (S m) \to (g1 (g b a)) = a) \to +(\forall a,b:nat. a < (S n) \to b < (S m) \to (g2 (g b a)) = b) \to +(\forall a,b:nat. a < (S n) \to b < (S m) \to f (g b a) = andb (f2 b) (f1 a)) \to +(count ((S n)*(S m)) f) = (count (S n) f1)*(count (S m) f2). +intros.unfold count. +rewrite < eq_map_iter_i_sigma. +rewrite > (permut_to_eq_map_iter_i plus assoc_plus sym_plus ? ? ? + (\lambda i.g (div i (S n)) (mod i (S n)))). +rewrite > eq_map_iter_i_sigma. +rewrite > eq_sigma_sigma1. +apply (trans_eq ? ? +(sigma n (\lambda a. + sigma m (\lambda b.(bool_to_nat (f2 b))*(bool_to_nat (f1 a))) O) O)). +apply eq_sigma.intros. +apply eq_sigma.intros. +rewrite > (div_mod_spec_to_eq (i1*(S n) + i) (S n) ((i1*(S n) + i)/(S n)) + ((i1*(S n) + i) \mod (S n)) i1 i). +rewrite > (div_mod_spec_to_eq2 (i1*(S n) + i) (S n) ((i1*(S n) + i)/(S n)) + ((i1*(S n) + i) \mod (S n)) i1 i). +rewrite > H3. +apply bool_to_nat_andb. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.assumption. +apply div_mod_spec_div_mod. +unfold lt.apply le_S_S.apply le_O_n. +constructor 1.unfold lt.apply le_S_S.assumption. +reflexivity. +apply div_mod_spec_div_mod. +unfold lt.apply le_S_S.apply le_O_n. +constructor 1.unfold lt.apply le_S_S.assumption. +reflexivity. +apply (trans_eq ? ? +(sigma n (\lambda n.((bool_to_nat (f1 n)) * +(sigma m (\lambda n.bool_to_nat (f2 n)) O))) O)). +apply eq_sigma. +intros. +rewrite > sym_times. +apply (trans_eq ? ? +(sigma m (\lambda n.(bool_to_nat (f2 n))*(bool_to_nat (f1 i))) O)). +reflexivity. +apply sym_eq. apply sigma_times. +change in match (pred (S n)) with n. +change in match (pred (S m)) with m. +apply sym_eq. apply sigma_times. +unfold permut. +split. +intros. +rewrite < plus_n_O. +apply le_S_S_to_le. +rewrite < S_pred in \vdash (? ? %). +change with ((g (i/(S n)) (i \mod (S n))) \lt (S n)*(S m)). +apply H. +apply lt_mod_m_m. +unfold lt. apply le_S_S.apply le_O_n. +apply (lt_times_to_lt_l n). +apply (le_to_lt_to_lt ? i). +rewrite > (div_mod i (S n)) in \vdash (? ? %). +rewrite > sym_plus. +apply le_plus_n. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. +rewrite > S_pred in \vdash (? ? %). +apply le_S_S. +rewrite > plus_n_O in \vdash (? ? %). +rewrite > sym_times. assumption. +rewrite > (times_n_O O). +apply lt_times. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. apply le_S_S.apply le_O_n. +rewrite > (times_n_O O). +apply lt_times. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. apply le_S_S.apply le_O_n. +rewrite < plus_n_O. +unfold injn. +intros. +cut (i < (S n)*(S m)). +cut (j < (S n)*(S m)). +cut ((i \mod (S n)) < (S n)). +cut ((i/(S n)) < (S m)). +cut ((j \mod (S n)) < (S n)). +cut ((j/(S n)) < (S m)). +rewrite > (div_mod i (S n)). +rewrite > (div_mod j (S n)). +rewrite < (H1 (i \mod (S n)) (i/(S n)) Hcut2 Hcut3). +rewrite < (H2 (i \mod (S n)) (i/(S n)) Hcut2 Hcut3) in \vdash (? ? (? % ?) ?). +rewrite < (H1 (j \mod (S n)) (j/(S n)) Hcut4 Hcut5). +rewrite < (H2 (j \mod (S n)) (j/(S n)) Hcut4 Hcut5) in \vdash (? ? ? (? % ?)). +rewrite > H6.reflexivity. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. apply le_S_S.apply le_O_n. +apply (lt_times_to_lt_l n). +apply (le_to_lt_to_lt ? j). +rewrite > (div_mod j (S n)) in \vdash (? ? %). +rewrite > sym_plus. +apply le_plus_n. +unfold lt. apply le_S_S.apply le_O_n. +rewrite < sym_times. assumption. +apply lt_mod_m_m. +unfold lt. apply le_S_S.apply le_O_n. +apply (lt_times_to_lt_l n). +apply (le_to_lt_to_lt ? i). +rewrite > (div_mod i (S n)) in \vdash (? ? %). +rewrite > sym_plus. +apply le_plus_n. +unfold lt. apply le_S_S.apply le_O_n. +rewrite < sym_times. assumption. +apply lt_mod_m_m. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. +rewrite > S_pred in \vdash (? ? %). +apply le_S_S.assumption. +rewrite > (times_n_O O). +apply lt_times. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. +rewrite > S_pred in \vdash (? ? %). +apply le_S_S.assumption. +rewrite > (times_n_O O). +apply lt_times. +unfold lt. apply le_S_S.apply le_O_n. +unfold lt. apply le_S_S.apply le_O_n. +intros. +apply False_ind. +apply (not_le_Sn_O m1 H4). +qed. diff --git a/helm/software/matita/library/nat/div_and_mod.ma b/helm/software/matita/library/nat/div_and_mod.ma new file mode 100644 index 000000000..e9831f82a --- /dev/null +++ b/helm/software/matita/library/nat/div_and_mod.ma @@ -0,0 +1,298 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/div_and_mod". + +include "nat/minus.ma". + +let rec mod_aux p m n: nat \def +match (leb m n) with +[ true \Rightarrow m +| false \Rightarrow + match p with + [O \Rightarrow m + |(S q) \Rightarrow mod_aux q (m-(S n)) n]]. + +definition mod : nat \to nat \to nat \def +\lambda n,m. +match m with +[O \Rightarrow m +| (S p) \Rightarrow mod_aux n n p]. + +interpretation "natural remainder" 'module x y = + (cic:/matita/nat/div_and_mod/mod.con x y). + +let rec div_aux p m n : nat \def +match (leb m n) with +[ true \Rightarrow O +| false \Rightarrow + match p with + [O \Rightarrow O + |(S q) \Rightarrow S (div_aux q (m-(S n)) n)]]. + +definition div : nat \to nat \to nat \def +\lambda n,m. +match m with +[O \Rightarrow S n +| (S p) \Rightarrow div_aux n n p]. + +interpretation "natural divide" 'divide x y = + (cic:/matita/nat/div_and_mod/div.con x y). + +theorem le_mod_aux_m_m: +\forall p,n,m. n \leq p \to (mod_aux p n m) \leq m. +intro.elim p. +apply (le_n_O_elim n H (\lambda n.(mod_aux O n m) \leq m)). +simplify.apply le_O_n. +simplify. +apply (leb_elim n1 m). +simplify.intro.assumption. +simplify.intro.apply H. +cut (n1 \leq (S n) \to n1-(S m) \leq n). +apply Hcut.assumption. +elim n1. +simplify.apply le_O_n. +simplify.apply (trans_le ? n2 n). +apply le_minus_m.apply le_S_S_to_le.assumption. +qed. + +theorem lt_mod_m_m: \forall n,m. O < m \to (n \mod m) < m. +intros 2.elim m.apply False_ind. +apply (not_le_Sn_O O H). +simplify.unfold lt.apply le_S_S.apply le_mod_aux_m_m. +apply le_n. +qed. + +theorem div_aux_mod_aux: \forall p,n,m:nat. +(n=(div_aux p n m)*(S m) + (mod_aux p n m)). +intro.elim p. +simplify.elim (leb n m). +simplify.apply refl_eq. +simplify.apply refl_eq. +simplify. +apply (leb_elim n1 m). +simplify.intro.apply refl_eq. +simplify.intro. +rewrite > assoc_plus. +elim (H (n1-(S m)) m). +change with (n1=(S m)+(n1-(S m))). +rewrite < sym_plus. +apply plus_minus_m_m. +change with (m < n1). +apply not_le_to_lt.exact H1. +qed. + +theorem div_mod: \forall n,m:nat. O < m \to n=(n / m)*m+(n \mod m). +intros 2.elim m.elim (not_le_Sn_O O H). +simplify. +apply div_aux_mod_aux. +qed. + +inductive div_mod_spec (n,m,q,r:nat) : Prop \def +div_mod_spec_intro: r < m \to n=q*m+r \to (div_mod_spec n m q r). + +(* +definition div_mod_spec : nat \to nat \to nat \to nat \to Prop \def +\lambda n,m,q,r:nat.r < m \land n=q*m+r). +*) + +theorem div_mod_spec_to_not_eq_O: \forall n,m,q,r.(div_mod_spec n m q r) \to m \neq O. +intros 4.unfold Not.intros.elim H.absurd (le (S r) O). +rewrite < H1.assumption. +exact (not_le_Sn_O r). +qed. + +theorem div_mod_spec_div_mod: +\forall n,m. O < m \to (div_mod_spec n m (n / m) (n \mod m)). +intros. +apply div_mod_spec_intro. +apply lt_mod_m_m.assumption. +apply div_mod.assumption. +qed. + +theorem div_mod_spec_to_eq :\forall a,b,q,r,q1,r1. +(div_mod_spec a b q r) \to (div_mod_spec a b q1 r1) \to +(eq nat q q1). +intros.elim H.elim H1. +apply (nat_compare_elim q q1).intro. +apply False_ind. +cut (eq nat ((q1-q)*b+r1) r). +cut (b \leq (q1-q)*b+r1). +cut (b \leq r). +apply (lt_to_not_le r b H2 Hcut2). +elim Hcut.assumption. +apply (trans_le ? ((q1-q)*b)). +apply le_times_n. +apply le_SO_minus.exact H6. +rewrite < sym_plus. +apply le_plus_n. +rewrite < sym_times. +rewrite > distr_times_minus. +rewrite > plus_minus. +rewrite > sym_times. +rewrite < H5. +rewrite < sym_times. +apply plus_to_minus. +apply H3. +apply le_times_r. +apply lt_to_le. +apply H6. +(* eq case *) +intros.assumption. +(* the following case is symmetric *) +intro. +apply False_ind. +cut (eq nat ((q-q1)*b+r) r1). +cut (b \leq (q-q1)*b+r). +cut (b \leq r1). +apply (lt_to_not_le r1 b H4 Hcut2). +elim Hcut.assumption. +apply (trans_le ? ((q-q1)*b)). +apply le_times_n. +apply le_SO_minus.exact H6. +rewrite < sym_plus. +apply le_plus_n. +rewrite < sym_times. +rewrite > distr_times_minus. +rewrite > plus_minus. +rewrite > sym_times. +rewrite < H3. +rewrite < sym_times. +apply plus_to_minus. +apply H5. +apply le_times_r. +apply lt_to_le. +apply H6. +qed. + +theorem div_mod_spec_to_eq2 :\forall a,b,q,r,q1,r1. +(div_mod_spec a b q r) \to (div_mod_spec a b q1 r1) \to +(eq nat r r1). +intros.elim H.elim H1. +apply (inj_plus_r (q*b)). +rewrite < H3. +rewrite > (div_mod_spec_to_eq a b q r q1 r1 H H1). +assumption. +qed. + +theorem div_mod_spec_times : \forall n,m:nat.div_mod_spec ((S n)*m) (S n) m O. +intros.constructor 1. +unfold lt.apply le_S_S.apply le_O_n. +rewrite < plus_n_O.rewrite < sym_times.reflexivity. +qed. + +(* some properties of div and mod *) +theorem div_times: \forall n,m:nat. ((S n)*m) / (S n) = m. +intros. +apply (div_mod_spec_to_eq ((S n)*m) (S n) ? ? ? O). +goal 15. (* ?11 is closed with the following tactics *) +apply div_mod_spec_div_mod. +unfold lt.apply le_S_S.apply le_O_n. +apply div_mod_spec_times. +qed. + +theorem div_n_n: \forall n:nat. O < n \to n / n = S O. +intros. +apply (div_mod_spec_to_eq n n (n / n) (n \mod n) (S O) O). +apply div_mod_spec_div_mod.assumption. +constructor 1.assumption. +rewrite < plus_n_O.simplify.rewrite < plus_n_O.reflexivity. +qed. + +theorem eq_div_O: \forall n,m. n < m \to n / m = O. +intros. +apply (div_mod_spec_to_eq n m (n/m) (n \mod m) O n). +apply div_mod_spec_div_mod. +apply (le_to_lt_to_lt O n m). +apply le_O_n.assumption. +constructor 1.assumption.reflexivity. +qed. + +theorem mod_n_n: \forall n:nat. O < n \to n \mod n = O. +intros. +apply (div_mod_spec_to_eq2 n n (n / n) (n \mod n) (S O) O). +apply div_mod_spec_div_mod.assumption. +constructor 1.assumption. +rewrite < plus_n_O.simplify.rewrite < plus_n_O.reflexivity. +qed. + +theorem mod_S: \forall n,m:nat. O < m \to S (n \mod m) < m \to +((S n) \mod m) = S (n \mod m). +intros. +apply (div_mod_spec_to_eq2 (S n) m ((S n) / m) ((S n) \mod m) (n / m) (S (n \mod m))). +apply div_mod_spec_div_mod.assumption. +constructor 1.assumption.rewrite < plus_n_Sm. +apply eq_f. +apply div_mod. +assumption. +qed. + +theorem mod_O_n: \forall n:nat.O \mod n = O. +intro.elim n.simplify.reflexivity. +simplify.reflexivity. +qed. + +theorem lt_to_eq_mod:\forall n,m:nat. n < m \to n \mod m = n. +intros. +apply (div_mod_spec_to_eq2 n m (n/m) (n \mod m) O n). +apply div_mod_spec_div_mod. +apply (le_to_lt_to_lt O n m).apply le_O_n.assumption. +constructor 1. +assumption.reflexivity. +qed. + +(* injectivity *) +theorem injective_times_r: \forall n:nat.injective nat nat (\lambda m:nat.(S n)*m). +change with (\forall n,p,q:nat.(S n)*p = (S n)*q \to p=q). +intros. +rewrite < (div_times n). +rewrite < (div_times n q). +apply eq_f2.assumption. +reflexivity. +qed. + +variant inj_times_r : \forall n,p,q:nat.(S n)*p = (S n)*q \to p=q \def +injective_times_r. + +theorem lt_O_to_injective_times_r: \forall n:nat. O < n \to injective nat nat (\lambda m:nat.n*m). +change with (\forall n. O < n \to \forall p,q:nat.n*p = n*q \to p=q). +intros 4. +apply (lt_O_n_elim n H).intros. +apply (inj_times_r m).assumption. +qed. + +variant inj_times_r1:\forall n. O < n \to \forall p,q:nat.n*p = n*q \to p=q +\def lt_O_to_injective_times_r. + +theorem injective_times_l: \forall n:nat.injective nat nat (\lambda m:nat.m*(S n)). +change with (\forall n,p,q:nat.p*(S n) = q*(S n) \to p=q). +intros. +apply (inj_times_r n p q). +rewrite < sym_times. +rewrite < (sym_times q). +assumption. +qed. + +variant inj_times_l : \forall n,p,q:nat. p*(S n) = q*(S n) \to p=q \def +injective_times_l. + +theorem lt_O_to_injective_times_l: \forall n:nat. O < n \to injective nat nat (\lambda m:nat.m*n). +change with (\forall n. O < n \to \forall p,q:nat.p*n = q*n \to p=q). +intros 4. +apply (lt_O_n_elim n H).intros. +apply (inj_times_l m).assumption. +qed. + +variant inj_times_l1:\forall n. O < n \to \forall p,q:nat.p*n = q*n \to p=q +\def lt_O_to_injective_times_l. diff --git a/helm/software/matita/library/nat/exp.ma b/helm/software/matita/library/nat/exp.ma new file mode 100644 index 000000000..11d84f74c --- /dev/null +++ b/helm/software/matita/library/nat/exp.ma @@ -0,0 +1,97 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/exp". + +include "nat/div_and_mod.ma". + +let rec exp n m on m\def + match m with + [ O \Rightarrow (S O) + | (S p) \Rightarrow (times n (exp n p)) ]. + +interpretation "natural exponent" 'exp a b = (cic:/matita/nat/exp/exp.con a b). + +theorem exp_plus_times : \forall n,p,q:nat. +n \sup (p + q) = (n \sup p) * (n \sup q). +intros.elim p. +simplify.rewrite < plus_n_O.reflexivity. +simplify.rewrite > H.symmetry. +apply assoc_times. +qed. + +theorem exp_n_O : \forall n:nat. S O = n \sup O. +intro.simplify.reflexivity. +qed. + +theorem exp_n_SO : \forall n:nat. n = n \sup (S O). +intro.simplify.rewrite < times_n_SO.reflexivity. +qed. + +theorem exp_exp_times : \forall n,p,q:nat. +(n \sup p) \sup q = n \sup (p * q). +intros. +elim q.simplify.rewrite < times_n_O.simplify.reflexivity. +simplify.rewrite > H.rewrite < exp_plus_times. +rewrite < times_n_Sm.reflexivity. +qed. + +theorem lt_O_exp: \forall n,m:nat. O < n \to O < n \sup m. +intros.elim m.simplify.unfold lt.apply le_n. +simplify.unfold lt.rewrite > times_n_SO. +apply le_times.assumption.assumption. +qed. + +theorem lt_m_exp_nm: \forall n,m:nat. (S O) < n \to m < n \sup m. +intros.elim m.simplify.unfold lt.reflexivity. +simplify.unfold lt. +apply (trans_le ? ((S(S O))*(S n1))). +simplify. +rewrite < plus_n_Sm.apply le_S_S.apply le_S_S. +rewrite < sym_plus. +apply le_plus_n. +apply le_times.assumption.assumption. +qed. + +theorem exp_to_eq_O: \forall n,m:nat. (S O) < n +\to n \sup m = (S O) \to m = O. +intros.apply antisym_le.apply le_S_S_to_le. +rewrite < H1.change with (m < n \sup m). +apply lt_m_exp_nm.assumption. +apply le_O_n. +qed. + +theorem injective_exp_r: \forall n:nat. (S O) < n \to +injective nat nat (\lambda m:nat. n \sup m). +simplify.intros 4. +apply (nat_elim2 (\lambda x,y.n \sup x = n \sup y \to x = y)). +intros.apply sym_eq.apply (exp_to_eq_O n).assumption. +rewrite < H1.reflexivity. +intros.apply (exp_to_eq_O n).assumption.assumption. +intros.apply eq_f. +apply H1. +(* esprimere inj_times senza S *) +cut (\forall a,b:nat.O < n \to n*a=n*b \to a=b). +apply Hcut.simplify.unfold lt.apply le_S_S_to_le. apply le_S. assumption. +assumption. +intros 2. +apply (nat_case n). +intros.apply False_ind.apply (not_le_Sn_O O H3). +intros. +apply (inj_times_r m1).assumption. +qed. + +variant inj_exp_r: \forall p:nat. (S O) < p \to \forall n,m:nat. +p \sup n = p \sup m \to n = m \def +injective_exp_r. diff --git a/helm/software/matita/library/nat/factorial.ma b/helm/software/matita/library/nat/factorial.ma new file mode 100644 index 000000000..14217bbcb --- /dev/null +++ b/helm/software/matita/library/nat/factorial.ma @@ -0,0 +1,61 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/factorial". + +include "nat/le_arith.ma". + +let rec fact n \def + match n with + [ O \Rightarrow (S O) + | (S m) \Rightarrow (S m)*(fact m)]. + +interpretation "factorial" 'fact n = (cic:/matita/nat/factorial/fact.con n). + +theorem le_SO_fact : \forall n. (S O) \le n!. +intro.elim n.simplify.apply le_n. +change with ((S O) \le (S n1)*n1!). +apply (trans_le ? ((S n1)*(S O))).simplify. +apply le_S_S.apply le_O_n. +apply le_times_r.assumption. +qed. + +theorem le_SSO_fact : \forall n. (S O) < n \to (S(S O)) \le n!. +intro.apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S O) H). +intros.change with ((S (S O)) \le (S m)*m!). +apply (trans_le ? ((S(S O))*(S O))).apply le_n. +apply le_times.exact H.apply le_SO_fact. +qed. + +theorem le_n_fact_n: \forall n. n \le n!. +intro. elim n.apply le_O_n. +change with (S n1 \le (S n1)*n1!). +apply (trans_le ? ((S n1)*(S O))). +rewrite < times_n_SO.apply le_n. +apply le_times.apply le_n. +apply le_SO_fact. +qed. + +theorem lt_n_fact_n: \forall n. (S(S O)) < n \to n < n!. +intro.apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S(S O)) H). +intros.change with ((S m) < (S m)*m!). +apply (lt_to_le_to_lt ? ((S m)*(S (S O)))). +rewrite < sym_times. +simplify.unfold lt. +apply le_S_S.rewrite < plus_n_O. +apply le_plus_n. +apply le_times_r.apply le_SSO_fact. +simplify.unfold lt.apply le_S_S_to_le.exact H. +qed. + diff --git a/helm/software/matita/library/nat/factorization.ma b/helm/software/matita/library/nat/factorization.ma new file mode 100644 index 000000000..37b5ea1dd --- /dev/null +++ b/helm/software/matita/library/nat/factorization.ma @@ -0,0 +1,619 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/factorization". + +include "nat/ord.ma". +include "nat/gcd.ma". +include "nat/nth_prime.ma". + +(* the following factorization algorithm looks for the largest prime + factor. *) +definition max_prime_factor \def \lambda n:nat. +(max n (\lambda p:nat.eqb (n \mod (nth_prime p)) O)). + +(* max_prime_factor is indeed a factor *) +theorem divides_max_prime_factor_n: + \forall n:nat. (S O) < n + \to nth_prime (max_prime_factor n) \divides n. +intros; apply divides_b_true_to_divides; +[ apply lt_O_nth_prime_n; +| apply (f_max_true (\lambda p:nat.eqb (n \mod (nth_prime p)) O) n); + cut (\exists i. nth_prime i = smallest_factor n); + [ elim Hcut. + apply (ex_intro nat ? a); + split; + [ apply (trans_le a (nth_prime a)); + [ apply le_n_fn; + exact lt_nth_prime_n_nth_prime_Sn; + | rewrite > H1; + apply le_smallest_factor_n; ] + | rewrite > H1; + change with (divides_b (smallest_factor n) n = true); + apply divides_to_divides_b_true; + [ apply (trans_lt ? (S O)); + [ unfold lt; apply le_n; + | apply lt_SO_smallest_factor; assumption; ] + | apply divides_smallest_factor_n; + apply (trans_lt ? (S O)); + [ unfold lt; apply le_n; + | assumption; ] ] ] + | apply prime_to_nth_prime; + apply prime_smallest_factor_n; + assumption; ] ] +qed. + +theorem divides_to_max_prime_factor : \forall n,m. (S O) < n \to O < m \to n \divides m \to +max_prime_factor n \le max_prime_factor m. +intros.change with +((max n (\lambda p:nat.eqb (n \mod (nth_prime p)) O)) \le +(max m (\lambda p:nat.eqb (m \mod (nth_prime p)) O))). +apply f_m_to_le_max. +apply (trans_le ? n). +apply le_max_n.apply divides_to_le.assumption.assumption. +change with (divides_b (nth_prime (max_prime_factor n)) m = true). +apply divides_to_divides_b_true. +cut (prime (nth_prime (max_prime_factor n))). +apply lt_O_nth_prime_n.apply prime_nth_prime. +cut (nth_prime (max_prime_factor n) \divides n). +apply (transitive_divides ? n). +apply divides_max_prime_factor_n. +assumption.assumption. +apply divides_b_true_to_divides. +apply lt_O_nth_prime_n. +apply divides_to_divides_b_true. +apply lt_O_nth_prime_n. +apply divides_max_prime_factor_n. +assumption. +qed. + +theorem p_ord_to_lt_max_prime_factor: \forall n,p,q,r. O < n \to +p = max_prime_factor n \to +(pair nat nat q r) = p_ord n (nth_prime p) \to +(S O) < r \to max_prime_factor r < p. +intros. +rewrite > H1. +cut (max_prime_factor r \lt max_prime_factor n \lor + max_prime_factor r = max_prime_factor n). +elim Hcut.assumption. +absurd (nth_prime (max_prime_factor n) \divides r). +rewrite < H4. +apply divides_max_prime_factor_n. +assumption. +change with (nth_prime (max_prime_factor n) \divides r \to False). +intro. +cut (r \mod (nth_prime (max_prime_factor n)) \neq O). +apply Hcut1.apply divides_to_mod_O. +apply lt_O_nth_prime_n.assumption. +apply (p_ord_aux_to_not_mod_O n n ? q r). +apply lt_SO_nth_prime_n.assumption. +apply le_n. +rewrite < H1.assumption. +apply (le_to_or_lt_eq (max_prime_factor r) (max_prime_factor n)). +apply divides_to_max_prime_factor. +assumption.assumption. +apply (witness r n ((nth_prime p) \sup q)). +rewrite < sym_times. +apply (p_ord_aux_to_exp n n ? q r). +apply lt_O_nth_prime_n.assumption. +qed. + +theorem p_ord_to_lt_max_prime_factor1: \forall n,p,q,r. O < n \to +max_prime_factor n \le p \to +(pair nat nat q r) = p_ord n (nth_prime p) \to +(S O) < r \to max_prime_factor r < p. +intros. +cut (max_prime_factor n < p \lor max_prime_factor n = p). +elim Hcut.apply (le_to_lt_to_lt ? (max_prime_factor n)). +apply divides_to_max_prime_factor.assumption.assumption. +apply (witness r n ((nth_prime p) \sup q)). +rewrite > sym_times. +apply (p_ord_aux_to_exp n n). +apply lt_O_nth_prime_n. +assumption.assumption. +apply (p_ord_to_lt_max_prime_factor n ? q). +assumption.apply sym_eq.assumption.assumption.assumption. +apply (le_to_or_lt_eq ? p H1). +qed. + +(* datatypes and functions *) + +inductive nat_fact : Set \def + nf_last : nat \to nat_fact + | nf_cons : nat \to nat_fact \to nat_fact. + +inductive nat_fact_all : Set \def + nfa_zero : nat_fact_all + | nfa_one : nat_fact_all + | nfa_proper : nat_fact \to nat_fact_all. + +let rec factorize_aux p n acc \def + match p with + [ O \Rightarrow acc + | (S p1) \Rightarrow + match p_ord n (nth_prime p1) with + [ (pair q r) \Rightarrow + factorize_aux p1 r (nf_cons q acc)]]. + +definition factorize : nat \to nat_fact_all \def \lambda n:nat. + match n with + [ O \Rightarrow nfa_zero + | (S n1) \Rightarrow + match n1 with + [ O \Rightarrow nfa_one + | (S n2) \Rightarrow + let p \def (max (S(S n2)) (\lambda p:nat.eqb ((S(S n2)) \mod (nth_prime p)) O)) in + match p_ord (S(S n2)) (nth_prime p) with + [ (pair q r) \Rightarrow + nfa_proper (factorize_aux p r (nf_last (pred q)))]]]. + +let rec defactorize_aux f i \def + match f with + [ (nf_last n) \Rightarrow (nth_prime i) \sup (S n) + | (nf_cons n g) \Rightarrow + (nth_prime i) \sup n *(defactorize_aux g (S i))]. + +definition defactorize : nat_fact_all \to nat \def +\lambda f : nat_fact_all. +match f with +[ nfa_zero \Rightarrow O +| nfa_one \Rightarrow (S O) +| (nfa_proper g) \Rightarrow defactorize_aux g O]. + +theorem lt_O_defactorize_aux: \forall f:nat_fact.\forall i:nat. +O < defactorize_aux f i. +intro.elim f.simplify.unfold lt. +rewrite > times_n_SO. +apply le_times. +change with (O < nth_prime i). +apply lt_O_nth_prime_n. +change with (O < exp (nth_prime i) n). +apply lt_O_exp. +apply lt_O_nth_prime_n. +simplify.unfold lt. +rewrite > times_n_SO. +apply le_times. +change with (O < exp (nth_prime i) n). +apply lt_O_exp. +apply lt_O_nth_prime_n. +change with (O < defactorize_aux n1 (S i)). +apply H. +qed. + +theorem lt_SO_defactorize_aux: \forall f:nat_fact.\forall i:nat. +S O < defactorize_aux f i. +intro.elim f.simplify.unfold lt. +rewrite > times_n_SO. +apply le_times. +change with (S O < nth_prime i). +apply lt_SO_nth_prime_n. +change with (O < exp (nth_prime i) n). +apply lt_O_exp. +apply lt_O_nth_prime_n. +simplify.unfold lt. +rewrite > times_n_SO. +rewrite > sym_times. +apply le_times. +change with (O < exp (nth_prime i) n). +apply lt_O_exp. +apply lt_O_nth_prime_n. +change with (S O < defactorize_aux n1 (S i)). +apply H. +qed. + +theorem defactorize_aux_factorize_aux : +\forall p,n:nat.\forall acc:nat_fact.O < n \to +((n=(S O) \land p=O) \lor max_prime_factor n < p) \to +defactorize_aux (factorize_aux p n acc) O = n*(defactorize_aux acc p). +intro.elim p.simplify. +elim H1.elim H2.rewrite > H3. +rewrite > sym_times. apply times_n_SO. +apply False_ind.apply (not_le_Sn_O (max_prime_factor n) H2). +simplify. +(* generalizing the goal: I guess there exists a better way *) +cut (\forall q,r.(pair nat nat q r) = (p_ord_aux n1 n1 (nth_prime n)) \to +defactorize_aux match (p_ord_aux n1 n1 (nth_prime n)) with +[(pair q r) \Rightarrow (factorize_aux n r (nf_cons q acc))] O = +n1*defactorize_aux acc (S n)). +apply (Hcut (fst ? ? (p_ord_aux n1 n1 (nth_prime n))) +(snd ? ? (p_ord_aux n1 n1 (nth_prime n)))). +apply sym_eq.apply eq_pair_fst_snd. +intros. +rewrite < H3. +simplify. +cut (n1 = r * (nth_prime n) \sup q). +rewrite > H. +simplify.rewrite < assoc_times. +rewrite < Hcut.reflexivity. +cut (O < r \lor O = r). +elim Hcut1.assumption.absurd (n1 = O). +rewrite > Hcut.rewrite < H4.reflexivity. +unfold Not. intro.apply (not_le_Sn_O O). +rewrite < H5 in \vdash (? ? %).assumption. +apply le_to_or_lt_eq.apply le_O_n. +cut ((S O) < r \lor (S O) \nlt r). +elim Hcut1. +right. +apply (p_ord_to_lt_max_prime_factor1 n1 ? q r). +assumption.elim H2. +elim H5. +apply False_ind. +apply (not_eq_O_S n).apply sym_eq.assumption. +apply le_S_S_to_le. +exact H5. +assumption.assumption. +cut (r=(S O)). +apply (nat_case n). +left.split.assumption.reflexivity. +intro.right.rewrite > Hcut2. +simplify.unfold lt.apply le_S_S.apply le_O_n. +cut (r \lt (S O) \or r=(S O)). +elim Hcut2.absurd (O=r). +apply le_n_O_to_eq.apply le_S_S_to_le.exact H5. +unfold Not.intro. +cut (O=n1). +apply (not_le_Sn_O O). +rewrite > Hcut3 in \vdash (? ? %). +assumption.rewrite > Hcut. +rewrite < H6.reflexivity. +assumption. +apply (le_to_or_lt_eq r (S O)). +apply not_lt_to_le.assumption. +apply (decidable_lt (S O) r). +rewrite > sym_times. +apply (p_ord_aux_to_exp n1 n1). +apply lt_O_nth_prime_n.assumption. +qed. + +theorem defactorize_factorize: \forall n:nat.defactorize (factorize n) = n. +intro. +apply (nat_case n).reflexivity. +intro.apply (nat_case m).reflexivity. +intro.change with +(let p \def (max (S(S m1)) (\lambda p:nat.eqb ((S(S m1)) \mod (nth_prime p)) O)) in +defactorize (match p_ord (S(S m1)) (nth_prime p) with +[ (pair q r) \Rightarrow + nfa_proper (factorize_aux p r (nf_last (pred q)))])=(S(S m1))). +intro. +(* generalizing the goal; find a better way *) +cut (\forall q,r.(pair nat nat q r) = (p_ord (S(S m1)) (nth_prime p)) \to +defactorize (match p_ord (S(S m1)) (nth_prime p) with +[ (pair q r) \Rightarrow + nfa_proper (factorize_aux p r (nf_last (pred q)))])=(S(S m1))). +apply (Hcut (fst ? ? (p_ord (S(S m1)) (nth_prime p))) +(snd ? ? (p_ord (S(S m1)) (nth_prime p)))). +apply sym_eq.apply eq_pair_fst_snd. +intros. +rewrite < H. +change with +(defactorize_aux (factorize_aux p r (nf_last (pred q))) O = (S(S m1))). +cut ((S(S m1)) = (nth_prime p) \sup q *r). +cut (O defactorize_aux_factorize_aux. +change with (r*(nth_prime p) \sup (S (pred q)) = (S(S m1))). +cut ((S (pred q)) = q). +rewrite > Hcut2. +rewrite > sym_times. +apply sym_eq. +apply (p_ord_aux_to_exp (S(S m1))). +apply lt_O_nth_prime_n. +assumption. +(* O < q *) +apply sym_eq. apply S_pred. +cut (O < q \lor O = q). +elim Hcut2.assumption. +absurd (nth_prime p \divides S (S m1)). +apply (divides_max_prime_factor_n (S (S m1))). +unfold lt.apply le_S_S.apply le_S_S. apply le_O_n. +cut ((S(S m1)) = r). +rewrite > Hcut3 in \vdash (? (? ? %)). +change with (nth_prime p \divides r \to False). +intro. +apply (p_ord_aux_to_not_mod_O (S(S m1)) (S(S m1)) (nth_prime p) q r). +apply lt_SO_nth_prime_n. +unfold lt.apply le_S_S.apply le_O_n.apply le_n. +assumption. +apply divides_to_mod_O.apply lt_O_nth_prime_n.assumption. +rewrite > times_n_SO in \vdash (? ? ? %). +rewrite < sym_times. +rewrite > (exp_n_O (nth_prime p)). +rewrite > H1 in \vdash (? ? ? (? (? ? %) ?)). +assumption. +apply le_to_or_lt_eq.apply le_O_n.assumption. +(* e adesso l'ultimo goal. TASSI: che ora non e' piu' l'ultimo :P *) +cut ((S O) < r \lor S O \nlt r). +elim Hcut2. +right. +apply (p_ord_to_lt_max_prime_factor1 (S(S m1)) ? q r). +unfold lt.apply le_S_S. apply le_O_n. +apply le_n. +assumption.assumption. +cut (r=(S O)). +apply (nat_case p). +left.split.assumption.reflexivity. +intro.right.rewrite > Hcut3. +simplify.unfold lt.apply le_S_S.apply le_O_n. +cut (r \lt (S O) \or r=(S O)). +elim Hcut3.absurd (O=r). +apply le_n_O_to_eq.apply le_S_S_to_le.exact H2. +unfold Not.intro. +apply (not_le_Sn_O O). +rewrite > H3 in \vdash (? ? %).assumption.assumption. +apply (le_to_or_lt_eq r (S O)). +apply not_lt_to_le.assumption. +apply (decidable_lt (S O) r). +(* O < r *) +cut (O < r \lor O = r). +elim Hcut1.assumption. +apply False_ind. +apply (not_eq_O_S (S m1)). +rewrite > Hcut.rewrite < H1.rewrite < times_n_O.reflexivity. +apply le_to_or_lt_eq.apply le_O_n. +(* prova del cut *) +goal 20. +apply (p_ord_aux_to_exp (S(S m1))). +apply lt_O_nth_prime_n. +assumption. +(* fine prova cut *) +qed. + +let rec max_p f \def +match f with +[ (nf_last n) \Rightarrow O +| (nf_cons n g) \Rightarrow S (max_p g)]. + +let rec max_p_exponent f \def +match f with +[ (nf_last n) \Rightarrow n +| (nf_cons n g) \Rightarrow max_p_exponent g]. + +theorem divides_max_p_defactorize: \forall f:nat_fact.\forall i:nat. +nth_prime ((max_p f)+i) \divides defactorize_aux f i. +intro. +elim f.simplify.apply (witness ? ? ((nth_prime i) \sup n)). +reflexivity. +change with +(nth_prime (S(max_p n1)+i) \divides +(nth_prime i) \sup n *(defactorize_aux n1 (S i))). +elim (H (S i)). +rewrite > H1. +rewrite < sym_times. +rewrite > assoc_times. +rewrite < plus_n_Sm. +apply (witness ? ? (n2* (nth_prime i) \sup n)). +reflexivity. +qed. + +theorem divides_exp_to_divides: +\forall p,n,m:nat. prime p \to +p \divides n \sup m \to p \divides n. +intros 3.elim m.simplify in H1. +apply (transitive_divides p (S O)).assumption. +apply divides_SO_n. +cut (p \divides n \lor p \divides n \sup n1). +elim Hcut.assumption. +apply H.assumption.assumption. +apply divides_times_to_divides.assumption. +exact H2. +qed. + +theorem divides_exp_to_eq: +\forall p,q,m:nat. prime p \to prime q \to +p \divides q \sup m \to p = q. +intros. +unfold prime in H1. +elim H1.apply H4. +apply (divides_exp_to_divides p q m). +assumption.assumption. +unfold prime in H.elim H.assumption. +qed. + +theorem not_divides_defactorize_aux: \forall f:nat_fact. \forall i,j:nat. +i < j \to nth_prime i \ndivides defactorize_aux f j. +intro.elim f. +change with +(nth_prime i \divides (nth_prime j) \sup (S n) \to False). +intro.absurd ((nth_prime i) = (nth_prime j)). +apply (divides_exp_to_eq ? ? (S n)). +apply prime_nth_prime.apply prime_nth_prime. +assumption. +change with ((nth_prime i) = (nth_prime j) \to False). +intro.cut (i = j). +apply (not_le_Sn_n i).rewrite > Hcut in \vdash (? ? %).assumption. +apply (injective_nth_prime ? ? H2). +change with +(nth_prime i \divides (nth_prime j) \sup n *(defactorize_aux n1 (S j)) \to False). +intro. +cut (nth_prime i \divides (nth_prime j) \sup n +\lor nth_prime i \divides defactorize_aux n1 (S j)). +elim Hcut. +absurd ((nth_prime i) = (nth_prime j)). +apply (divides_exp_to_eq ? ? n). +apply prime_nth_prime.apply prime_nth_prime. +assumption. +change with ((nth_prime i) = (nth_prime j) \to False). +intro. +cut (i = j). +apply (not_le_Sn_n i).rewrite > Hcut1 in \vdash (? ? %).assumption. +apply (injective_nth_prime ? ? H4). +apply (H i (S j)). +apply (trans_lt ? j).assumption.unfold lt.apply le_n. +assumption. +apply divides_times_to_divides. +apply prime_nth_prime.assumption. +qed. + +lemma not_eq_nf_last_nf_cons: \forall g:nat_fact.\forall n,m,i:nat. +\lnot (defactorize_aux (nf_last n) i= defactorize_aux (nf_cons m g) i). +intros. +change with +(exp (nth_prime i) (S n) = defactorize_aux (nf_cons m g) i \to False). +intro. +cut (S(max_p g)+i= i). +apply (not_le_Sn_n i). +rewrite < Hcut in \vdash (? ? %). +simplify.apply le_S_S. +apply le_plus_n. +apply injective_nth_prime. +(* uffa, perche' semplifica ? *) +change with (nth_prime (S(max_p g)+i)= nth_prime i). +apply (divides_exp_to_eq ? ? (S n)). +apply prime_nth_prime.apply prime_nth_prime. +rewrite > H. +change with (divides (nth_prime ((max_p (nf_cons m g))+i)) +(defactorize_aux (nf_cons m g) i)). +apply divides_max_p_defactorize. +qed. + +lemma not_eq_nf_cons_O_nf_cons: \forall f,g:nat_fact.\forall n,i:nat. +\lnot (defactorize_aux (nf_cons O f) i= defactorize_aux (nf_cons (S n) g) i). +intros. +simplify.unfold Not.rewrite < plus_n_O. +intro. +apply (not_divides_defactorize_aux f i (S i) ?). +unfold lt.apply le_n. +rewrite > H. +rewrite > assoc_times. +apply (witness ? ? ((exp (nth_prime i) n)*(defactorize_aux g (S i)))). +reflexivity. +qed. + +theorem eq_defactorize_aux_to_eq: \forall f,g:nat_fact.\forall i:nat. +defactorize_aux f i = defactorize_aux g i \to f = g. +intro. +elim f. +generalize in match H. +elim g. +apply eq_f. +apply inj_S. apply (inj_exp_r (nth_prime i)). +apply lt_SO_nth_prime_n. +assumption. +apply False_ind. +apply (not_eq_nf_last_nf_cons n2 n n1 i H2). +generalize in match H1. +elim g. +apply False_ind. +apply (not_eq_nf_last_nf_cons n1 n2 n i). +apply sym_eq. assumption. +simplify in H3. +generalize in match H3. +apply (nat_elim2 (\lambda n,n2. +((nth_prime i) \sup n)*(defactorize_aux n1 (S i)) = +((nth_prime i) \sup n2)*(defactorize_aux n3 (S i)) \to +nf_cons n n1 = nf_cons n2 n3)). +intro. +elim n4. apply eq_f. +apply (H n3 (S i)). +simplify in H4. +rewrite > plus_n_O. +rewrite > (plus_n_O (defactorize_aux n3 (S i))).assumption. +apply False_ind. +apply (not_eq_nf_cons_O_nf_cons n1 n3 n5 i).assumption. +intros. +apply False_ind. +apply (not_eq_nf_cons_O_nf_cons n3 n1 n4 i). +apply sym_eq.assumption. +intros. +cut (nf_cons n4 n1 = nf_cons m n3). +cut (n4=m). +cut (n1=n3). +rewrite > Hcut1.rewrite > Hcut2.reflexivity. +change with +(match nf_cons n4 n1 with +[ (nf_last m) \Rightarrow n1 +| (nf_cons m g) \Rightarrow g ] = n3). +rewrite > Hcut.simplify.reflexivity. +change with +(match nf_cons n4 n1 with +[ (nf_last m) \Rightarrow m +| (nf_cons m g) \Rightarrow m ] = m). +rewrite > Hcut.simplify.reflexivity. +apply H4.simplify in H5. +apply (inj_times_r1 (nth_prime i)). +apply lt_O_nth_prime_n. +rewrite < assoc_times.rewrite < assoc_times.assumption. +qed. + +theorem injective_defactorize_aux: \forall i:nat. +injective nat_fact nat (\lambda f.defactorize_aux f i). +change with (\forall i:nat.\forall f,g:nat_fact. +defactorize_aux f i = defactorize_aux g i \to f = g). +intros. +apply (eq_defactorize_aux_to_eq f g i H). +qed. + +theorem injective_defactorize: +injective nat_fact_all nat defactorize. +change with (\forall f,g:nat_fact_all. +defactorize f = defactorize g \to f = g). +intro.elim f. +generalize in match H.elim g. +(* zero - zero *) +reflexivity. +(* zero - one *) +simplify in H1. +apply False_ind. +apply (not_eq_O_S O H1). +(* zero - proper *) +simplify in H1. +apply False_ind. +apply (not_le_Sn_n O). +rewrite > H1 in \vdash (? ? %). +change with (O < defactorize_aux n O). +apply lt_O_defactorize_aux. +generalize in match H. +elim g. +(* one - zero *) +simplify in H1. +apply False_ind. +apply (not_eq_O_S O).apply sym_eq. assumption. +(* one - one *) +reflexivity. +(* one - proper *) +simplify in H1. +apply False_ind. +apply (not_le_Sn_n (S O)). +rewrite > H1 in \vdash (? ? %). +change with ((S O) < defactorize_aux n O). +apply lt_SO_defactorize_aux. +generalize in match H.elim g. +(* proper - zero *) +simplify in H1. +apply False_ind. +apply (not_le_Sn_n O). +rewrite < H1 in \vdash (? ? %). +change with (O < defactorize_aux n O). +apply lt_O_defactorize_aux. +(* proper - one *) +simplify in H1. +apply False_ind. +apply (not_le_Sn_n (S O)). +rewrite < H1 in \vdash (? ? %). +change with ((S O) < defactorize_aux n O). +apply lt_SO_defactorize_aux. +(* proper - proper *) +apply eq_f. +apply (injective_defactorize_aux O). +exact H1. +qed. + +theorem factorize_defactorize: +\forall f,g: nat_fact_all. factorize (defactorize f) = f. +intros. +apply injective_defactorize. +(* uffa: perche' semplifica ??? *) +change with (defactorize(factorize (defactorize f)) = (defactorize f)). +apply defactorize_factorize. +qed. + diff --git a/helm/software/matita/library/nat/fermat_little_theorem.ma b/helm/software/matita/library/nat/fermat_little_theorem.ma new file mode 100644 index 000000000..cc18a8bb9 --- /dev/null +++ b/helm/software/matita/library/nat/fermat_little_theorem.ma @@ -0,0 +1,250 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/fermat_little_theorem". + +include "nat/exp.ma". +include "nat/gcd.ma". +include "nat/permutation.ma". +include "nat/congruence.ma". + +theorem permut_S_mod: \forall n:nat. permut (S_mod (S n)) n. +intro.unfold permut.split.intros. +unfold S_mod. +apply le_S_S_to_le. +change with ((S i) \mod (S n) < S n). +apply lt_mod_m_m. +unfold lt.apply le_S_S.apply le_O_n. +unfold injn.intros. +apply inj_S. +rewrite < (lt_to_eq_mod i (S n)). +rewrite < (lt_to_eq_mod j (S n)). +cut (i < n \lor i = n). +cut (j < n \lor j = n). +elim Hcut. +elim Hcut1. +(* i < n, j< n *) +rewrite < mod_S. +rewrite < mod_S. +apply H2.unfold lt.apply le_S_S.apply le_O_n. +rewrite > lt_to_eq_mod. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.apply le_O_n. +rewrite > lt_to_eq_mod. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.assumption. +(* i < n, j=n *) +unfold S_mod in H2. +simplify. +apply False_ind. +apply (not_eq_O_S (i \mod (S n))). +apply sym_eq. +rewrite < (mod_n_n (S n)). +rewrite < H4 in \vdash (? ? ? (? %?)). +rewrite < mod_S.assumption. +unfold lt.apply le_S_S.apply le_O_n. +rewrite > lt_to_eq_mod. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.apply le_O_n. +(* i = n, j < n *) +elim Hcut1. +apply False_ind. +apply (not_eq_O_S (j \mod (S n))). +rewrite < (mod_n_n (S n)). +rewrite < H3 in \vdash (? ? (? %?) ?). +rewrite < mod_S.assumption. +unfold lt.apply le_S_S.apply le_O_n. +rewrite > lt_to_eq_mod. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.apply le_O_n. +(* i = n, j= n*) +rewrite > H3. +rewrite > H4. +reflexivity. +apply le_to_or_lt_eq.assumption. +apply le_to_or_lt_eq.assumption. +unfold lt.apply le_S_S.assumption. +unfold lt.apply le_S_S.assumption. +qed. + +(* +theorem eq_fact_pi: \forall n,m:nat. n < m \to n! = pi n (S_mod m). +intro.elim n. +simplify.reflexivity. +change with (S n1)*n1!=(S_mod m n1)*(pi n1 (S_mod m)). +unfold S_mod in \vdash (? ? ? (? % ?)). +rewrite > lt_to_eq_mod. +apply eq_f.apply H.apply (trans_lt ? (S n1)). +simplify. apply le_n.assumption.assumption. +qed. +*) + +theorem prime_to_not_divides_fact: \forall p:nat. prime p \to \forall n:nat. +n \lt p \to \not divides p n!. +intros 3.elim n.unfold Not.intros. +apply (lt_to_not_le (S O) p). +unfold prime in H.elim H. +assumption.apply divides_to_le.unfold lt.apply le_n. +assumption. +change with (divides p ((S n1)*n1!) \to False). +intro. +cut (divides p (S n1) \lor divides p n1!). +elim Hcut.apply (lt_to_not_le (S n1) p). +assumption. +apply divides_to_le.unfold lt.apply le_S_S.apply le_O_n. +assumption.apply H1. +apply (trans_lt ? (S n1)).unfold lt. apply le_n. +assumption.assumption. +apply divides_times_to_divides. +assumption.assumption. +qed. + +theorem permut_mod: \forall p,a:nat. prime p \to +\lnot divides p a\to permut (\lambda n.(mod (a*n) p)) (pred p). +unfold permut.intros. +split.intros.apply le_S_S_to_le. +apply (trans_le ? p). +change with (mod (a*i) p < p). +apply lt_mod_m_m. +unfold prime in H.elim H. +unfold lt.apply (trans_le ? (S (S O))). +apply le_n_Sn.assumption. +rewrite < S_pred.apply le_n. +unfold prime in H. +elim H. +apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. +unfold injn.intros. +apply (nat_compare_elim i j). +(* i < j *) +intro. +absurd (j-i \lt p). +unfold lt. +rewrite > (S_pred p). +apply le_S_S. +apply le_plus_to_minus. +apply (trans_le ? (pred p)).assumption. +rewrite > sym_plus. +apply le_plus_n. +unfold prime in H. +elim H. +apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. +apply (le_to_not_lt p (j-i)). +apply divides_to_le.unfold lt. +apply le_SO_minus.assumption. +cut (divides p a \lor divides p (j-i)). +elim Hcut.apply False_ind.apply H1.assumption.assumption. +apply divides_times_to_divides.assumption. +rewrite > distr_times_minus. +apply eq_mod_to_divides. +unfold prime in H. +elim H. +apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. +apply sym_eq. +apply H4. +(* i = j *) +intro. assumption. +(* j < i *) +intro. +absurd (i-j \lt p). +unfold lt. +rewrite > (S_pred p). +apply le_S_S. +apply le_plus_to_minus. +apply (trans_le ? (pred p)).assumption. +rewrite > sym_plus. +apply le_plus_n. +unfold prime in H. +elim H. +apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. +apply (le_to_not_lt p (i-j)). +apply divides_to_le.unfold lt. +apply le_SO_minus.assumption. +cut (divides p a \lor divides p (i-j)). +elim Hcut.apply False_ind.apply H1.assumption.assumption. +apply divides_times_to_divides.assumption. +rewrite > distr_times_minus. +apply eq_mod_to_divides. +unfold prime in H. +elim H. +apply (trans_lt ? (S O)).unfold lt.apply le_n.assumption. +apply H4. +qed. + +theorem congruent_exp_pred_SO: \forall p,a:nat. prime p \to \lnot divides p a \to +congruent (exp a (pred p)) (S O) p. +intros. +cut (O < a). +cut (O < p). +cut (O < pred p). +apply divides_to_congruent. +assumption. +change with (O < exp a (pred p)). +apply lt_O_exp.assumption. +cut (divides p (exp a (pred p)-(S O)) \lor divides p (pred p)!). +elim Hcut3. +assumption. +apply False_ind. +apply (prime_to_not_divides_fact p H (pred p)). +change with (S (pred p) \le p). +rewrite < S_pred.apply le_n. +assumption.assumption. +apply divides_times_to_divides. +assumption. +rewrite > times_minus_l. +rewrite > (sym_times (S O)). +rewrite < times_n_SO. +rewrite > (S_pred (pred p)). +rewrite > eq_fact_pi. +(* in \vdash (? ? (? % ?)). *) +rewrite > exp_pi_l. +apply congruent_to_divides. +assumption. +apply (transitive_congruent p ? +(pi (pred (pred p)) (\lambda m. a*m \mod p) (S O))). +apply (congruent_pi (\lambda m. a*m)). +assumption. +cut (pi (pred(pred p)) (\lambda m.m) (S O) += pi (pred(pred p)) (\lambda m.a*m \mod p) (S O)). +rewrite > Hcut3.apply congruent_n_n. +rewrite < eq_map_iter_i_pi. +rewrite < eq_map_iter_i_pi. +apply permut_to_eq_map_iter_i. +apply assoc_times. +apply sym_times. +rewrite < plus_n_Sm.rewrite < plus_n_O. +rewrite < S_pred. +apply permut_mod.assumption. +assumption.assumption. +intros.cut (m=O). +rewrite > Hcut3.rewrite < times_n_O. +apply mod_O_n.apply sym_eq.apply le_n_O_to_eq. +apply le_S_S_to_le.assumption. +assumption. +change with ((S O) \le pred p). +apply le_S_S_to_le.rewrite < S_pred. +unfold prime in H.elim H.assumption.assumption. +unfold prime in H.elim H.apply (trans_lt ? (S O)). +unfold lt.apply le_n.assumption. +cut (O < a \lor O = a). +elim Hcut.assumption. +apply False_ind.apply H1. +rewrite < H2. +apply (witness ? ? O).apply times_n_O. +apply le_to_or_lt_eq. +apply le_O_n. +qed. + diff --git a/helm/software/matita/library/nat/gcd.ma b/helm/software/matita/library/nat/gcd.ma new file mode 100644 index 000000000..65f61b581 --- /dev/null +++ b/helm/software/matita/library/nat/gcd.ma @@ -0,0 +1,608 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/gcd". + +include "nat/primes.ma". + +let rec gcd_aux p m n: nat \def +match divides_b n m with +[ true \Rightarrow n +| false \Rightarrow + match p with + [O \Rightarrow n + |(S q) \Rightarrow gcd_aux q n (m \mod n)]]. + +definition gcd : nat \to nat \to nat \def +\lambda n,m:nat. + match leb n m with + [ true \Rightarrow + match n with + [ O \Rightarrow m + | (S p) \Rightarrow gcd_aux (S p) m (S p) ] + | false \Rightarrow + match m with + [ O \Rightarrow n + | (S p) \Rightarrow gcd_aux (S p) n (S p) ]]. + +theorem divides_mod: \forall p,m,n:nat. O < n \to p \divides m \to p \divides n \to +p \divides (m \mod n). +intros.elim H1.elim H2. +apply (witness ? ? (n2 - n1*(m / n))). +rewrite > distr_times_minus. +rewrite < H3. +rewrite < assoc_times. +rewrite < H4. +apply sym_eq. +apply plus_to_minus. +rewrite > sym_times. +apply div_mod. +assumption. +qed. + +theorem divides_mod_to_divides: \forall p,m,n:nat. O < n \to +p \divides (m \mod n) \to p \divides n \to p \divides m. +intros.elim H1.elim H2. +apply (witness p m ((n1*(m / n))+n2)). +rewrite > distr_times_plus. +rewrite < H3. +rewrite < assoc_times. +rewrite < H4.rewrite < sym_times. +apply div_mod.assumption. +qed. + +theorem divides_gcd_aux_mn: \forall p,m,n. O < n \to n \le m \to n \le p \to +gcd_aux p m n \divides m \land gcd_aux p m n \divides n. +intro.elim p. +absurd (O < n).assumption.apply le_to_not_lt.assumption. +cut ((n1 \divides m) \lor (n1 \ndivides m)). +change with +((match divides_b n1 m with +[ true \Rightarrow n1 +| false \Rightarrow gcd_aux n n1 (m \mod n1)]) \divides m \land +(match divides_b n1 m with +[ true \Rightarrow n1 +| false \Rightarrow gcd_aux n n1 (m \mod n1)]) \divides n1). +elim Hcut.rewrite > divides_to_divides_b_true. +simplify. +split.assumption.apply (witness n1 n1 (S O)).apply times_n_SO. +assumption.assumption. +rewrite > not_divides_to_divides_b_false. +change with +(gcd_aux n n1 (m \mod n1) \divides m \land +gcd_aux n n1 (m \mod n1) \divides n1). +cut (gcd_aux n n1 (m \mod n1) \divides n1 \land +gcd_aux n n1 (m \mod n1) \divides mod m n1). +elim Hcut1. +split.apply (divides_mod_to_divides ? ? n1). +assumption.assumption.assumption.assumption. +apply H. +cut (O \lt m \mod n1 \lor O = mod m n1). +elim Hcut1.assumption. +apply False_ind.apply H4.apply mod_O_to_divides. +assumption.apply sym_eq.assumption. +apply le_to_or_lt_eq.apply le_O_n. +apply lt_to_le. +apply lt_mod_m_m.assumption. +apply le_S_S_to_le. +apply (trans_le ? n1). +change with (m \mod n1 < n1). +apply lt_mod_m_m.assumption.assumption. +assumption.assumption. +apply (decidable_divides n1 m).assumption. +qed. + +theorem divides_gcd_nm: \forall n,m. +gcd n m \divides m \land gcd n m \divides n. +intros. +change with +(match leb n m with + [ true \Rightarrow + match n with + [ O \Rightarrow m + | (S p) \Rightarrow gcd_aux (S p) m (S p) ] + | false \Rightarrow + match m with + [ O \Rightarrow n + | (S p) \Rightarrow gcd_aux (S p) n (S p) ] ] \divides m +\land +match leb n m with + [ true \Rightarrow + match n with + [ O \Rightarrow m + | (S p) \Rightarrow gcd_aux (S p) m (S p) ] + | false \Rightarrow + match m with + [ O \Rightarrow n + | (S p) \Rightarrow gcd_aux (S p) n (S p) ] ] \divides n). +apply (leb_elim n m). +apply (nat_case1 n). +simplify.intros.split. +apply (witness m m (S O)).apply times_n_SO. +apply (witness m O O).apply times_n_O. +intros.change with +(gcd_aux (S m1) m (S m1) \divides m +\land +gcd_aux (S m1) m (S m1) \divides (S m1)). +apply divides_gcd_aux_mn. +unfold lt.apply le_S_S.apply le_O_n. +assumption.apply le_n. +simplify.intro. +apply (nat_case1 m). +simplify.intros.split. +apply (witness n O O).apply times_n_O. +apply (witness n n (S O)).apply times_n_SO. +intros.change with +(gcd_aux (S m1) n (S m1) \divides (S m1) +\land +gcd_aux (S m1) n (S m1) \divides n). +cut (gcd_aux (S m1) n (S m1) \divides n +\land +gcd_aux (S m1) n (S m1) \divides S m1). +elim Hcut.split.assumption.assumption. +apply divides_gcd_aux_mn. +unfold lt.apply le_S_S.apply le_O_n. +apply not_lt_to_le.unfold Not. unfold lt.intro.apply H. +rewrite > H1.apply (trans_le ? (S n)). +apply le_n_Sn.assumption.apply le_n. +qed. + +theorem divides_gcd_n: \forall n,m. gcd n m \divides n. +intros. +exact (proj2 ? ? (divides_gcd_nm n m)). +qed. + +theorem divides_gcd_m: \forall n,m. gcd n m \divides m. +intros. +exact (proj1 ? ? (divides_gcd_nm n m)). +qed. + +theorem divides_gcd_aux: \forall p,m,n,d. O < n \to n \le m \to n \le p \to +d \divides m \to d \divides n \to d \divides gcd_aux p m n. +intro.elim p. +absurd (O < n).assumption.apply le_to_not_lt.assumption. +change with +(d \divides +(match divides_b n1 m with +[ true \Rightarrow n1 +| false \Rightarrow gcd_aux n n1 (m \mod n1)])). +cut (n1 \divides m \lor n1 \ndivides m). +elim Hcut. +rewrite > divides_to_divides_b_true. +simplify.assumption. +assumption.assumption. +rewrite > not_divides_to_divides_b_false. +change with (d \divides gcd_aux n n1 (m \mod n1)). +apply H. +cut (O \lt m \mod n1 \lor O = m \mod n1). +elim Hcut1.assumption. +absurd (n1 \divides m).apply mod_O_to_divides. +assumption.apply sym_eq.assumption.assumption. +apply le_to_or_lt_eq.apply le_O_n. +apply lt_to_le. +apply lt_mod_m_m.assumption. +apply le_S_S_to_le. +apply (trans_le ? n1). +change with (m \mod n1 < n1). +apply lt_mod_m_m.assumption.assumption. +assumption. +apply divides_mod.assumption.assumption.assumption. +assumption.assumption. +apply (decidable_divides n1 m).assumption. +qed. + +theorem divides_d_gcd: \forall m,n,d. +d \divides m \to d \divides n \to d \divides gcd n m. +intros. +change with +(d \divides +match leb n m with + [ true \Rightarrow + match n with + [ O \Rightarrow m + | (S p) \Rightarrow gcd_aux (S p) m (S p) ] + | false \Rightarrow + match m with + [ O \Rightarrow n + | (S p) \Rightarrow gcd_aux (S p) n (S p) ]]). +apply (leb_elim n m). +apply (nat_case1 n).simplify.intros.assumption. +intros. +change with (d \divides gcd_aux (S m1) m (S m1)). +apply divides_gcd_aux. +unfold lt.apply le_S_S.apply le_O_n.assumption.apply le_n.assumption. +rewrite < H2.assumption. +apply (nat_case1 m).simplify.intros.assumption. +intros. +change with (d \divides gcd_aux (S m1) n (S m1)). +apply divides_gcd_aux. +unfold lt.apply le_S_S.apply le_O_n. +apply lt_to_le.apply not_le_to_lt.assumption.apply le_n.assumption. +rewrite < H2.assumption. +qed. + +theorem eq_minus_gcd_aux: \forall p,m,n.O < n \to n \le m \to n \le p \to +\exists a,b. a*n - b*m = gcd_aux p m n \lor b*m - a*n = gcd_aux p m n. +intro. +elim p. +absurd (O < n).assumption.apply le_to_not_lt.assumption. +cut (O < m). +cut (n1 \divides m \lor n1 \ndivides m). +change with +(\exists a,b. +a*n1 - b*m = match divides_b n1 m with +[ true \Rightarrow n1 +| false \Rightarrow gcd_aux n n1 (m \mod n1)] +\lor +b*m - a*n1 = match divides_b n1 m with +[ true \Rightarrow n1 +| false \Rightarrow gcd_aux n n1 (m \mod n1)]). +elim Hcut1. +rewrite > divides_to_divides_b_true. +simplify. +apply (ex_intro ? ? (S O)). +apply (ex_intro ? ? O). +left.simplify.rewrite < plus_n_O. +apply sym_eq.apply minus_n_O. +assumption.assumption. +rewrite > not_divides_to_divides_b_false. +change with +(\exists a,b. +a*n1 - b*m = gcd_aux n n1 (m \mod n1) +\lor +b*m - a*n1 = gcd_aux n n1 (m \mod n1)). +cut +(\exists a,b. +a*(m \mod n1) - b*n1= gcd_aux n n1 (m \mod n1) +\lor +b*n1 - a*(m \mod n1) = gcd_aux n n1 (m \mod n1)). +elim Hcut2.elim H5.elim H6. +(* first case *) +rewrite < H7. +apply (ex_intro ? ? (a1+a*(m / n1))). +apply (ex_intro ? ? a). +right. +rewrite < sym_plus. +rewrite < (sym_times n1). +rewrite > distr_times_plus. +rewrite > (sym_times n1). +rewrite > (sym_times n1). +rewrite > (div_mod m n1) in \vdash (? ? (? % ?) ?). +rewrite > assoc_times. +rewrite < sym_plus. +rewrite > distr_times_plus. +rewrite < eq_minus_minus_minus_plus. +rewrite < sym_plus. +rewrite < plus_minus. +rewrite < minus_n_n.reflexivity. +apply le_n. +assumption. +(* second case *) +rewrite < H7. +apply (ex_intro ? ? (a1+a*(m / n1))). +apply (ex_intro ? ? a). +left. +(* clear Hcut2.clear H5.clear H6.clear H. *) +rewrite > sym_times. +rewrite > distr_times_plus. +rewrite > sym_times. +rewrite > (sym_times n1). +rewrite > (div_mod m n1) in \vdash (? ? (? ? %) ?). +rewrite > distr_times_plus. +rewrite > assoc_times. +rewrite < eq_minus_minus_minus_plus. +rewrite < sym_plus. +rewrite < plus_minus. +rewrite < minus_n_n.reflexivity. +apply le_n. +assumption. +apply (H n1 (m \mod n1)). +cut (O \lt m \mod n1 \lor O = m \mod n1). +elim Hcut2.assumption. +absurd (n1 \divides m).apply mod_O_to_divides. +assumption. +symmetry.assumption.assumption. +apply le_to_or_lt_eq.apply le_O_n. +apply lt_to_le. +apply lt_mod_m_m.assumption. +apply le_S_S_to_le. +apply (trans_le ? n1). +change with (m \mod n1 < n1). +apply lt_mod_m_m. +assumption.assumption.assumption.assumption. +apply (decidable_divides n1 m).assumption. +apply (lt_to_le_to_lt ? n1).assumption.assumption. +qed. + +theorem eq_minus_gcd: + \forall m,n.\exists a,b.a*n - b*m = (gcd n m) \lor b*m - a*n = (gcd n m). +intros. +unfold gcd. +apply (leb_elim n m). +apply (nat_case1 n). +simplify.intros. +apply (ex_intro ? ? O). +apply (ex_intro ? ? (S O)). +right.simplify. +rewrite < plus_n_O. +apply sym_eq.apply minus_n_O. +intros. +change with +(\exists a,b. +a*(S m1) - b*m = (gcd_aux (S m1) m (S m1)) +\lor b*m - a*(S m1) = (gcd_aux (S m1) m (S m1))). +apply eq_minus_gcd_aux. +unfold lt. apply le_S_S.apply le_O_n. +assumption.apply le_n. +apply (nat_case1 m). +simplify.intros. +apply (ex_intro ? ? (S O)). +apply (ex_intro ? ? O). +left.simplify. +rewrite < plus_n_O. +apply sym_eq.apply minus_n_O. +intros. +change with +(\exists a,b. +a*n - b*(S m1) = (gcd_aux (S m1) n (S m1)) +\lor b*(S m1) - a*n = (gcd_aux (S m1) n (S m1))). +cut +(\exists a,b. +a*(S m1) - b*n = (gcd_aux (S m1) n (S m1)) +\lor +b*n - a*(S m1) = (gcd_aux (S m1) n (S m1))). +elim Hcut.elim H2.elim H3. +apply (ex_intro ? ? a1). +apply (ex_intro ? ? a). +right.assumption. +apply (ex_intro ? ? a1). +apply (ex_intro ? ? a). +left.assumption. +apply eq_minus_gcd_aux. +unfold lt. apply le_S_S.apply le_O_n. +apply lt_to_le.apply not_le_to_lt.assumption. +apply le_n. +qed. + +(* some properties of gcd *) + +theorem gcd_O_n: \forall n:nat. gcd O n = n. +intro.simplify.reflexivity. +qed. + +theorem gcd_O_to_eq_O:\forall m,n:nat. (gcd m n) = O \to +m = O \land n = O. +intros.cut (O \divides n \land O \divides m). +elim Hcut.elim H2.split. +assumption.elim H1.assumption. +rewrite < H. +apply divides_gcd_nm. +qed. + +theorem lt_O_gcd:\forall m,n:nat. O < n \to O < gcd m n. +intros. +apply (nat_case1 (gcd m n)). +intros. +generalize in match (gcd_O_to_eq_O m n H1). +intros.elim H2. +rewrite < H4 in \vdash (? ? %).assumption. +intros.unfold lt.apply le_S_S.apply le_O_n. +qed. + +theorem symmetric_gcd: symmetric nat gcd. +change with +(\forall n,m:nat. gcd n m = gcd m n). +intros. +cut (O < (gcd n m) \lor O = (gcd n m)). +elim Hcut. +cut (O < (gcd m n) \lor O = (gcd m n)). +elim Hcut1. +apply antisym_le. +apply divides_to_le.assumption. +apply divides_d_gcd.apply divides_gcd_n.apply divides_gcd_m. +apply divides_to_le.assumption. +apply divides_d_gcd.apply divides_gcd_n.apply divides_gcd_m. +rewrite < H1. +cut (m=O \land n=O). +elim Hcut2.rewrite > H2.rewrite > H3.reflexivity. +apply gcd_O_to_eq_O.apply sym_eq.assumption. +apply le_to_or_lt_eq.apply le_O_n. +rewrite < H. +cut (n=O \land m=O). +elim Hcut1.rewrite > H1.rewrite > H2.reflexivity. +apply gcd_O_to_eq_O.apply sym_eq.assumption. +apply le_to_or_lt_eq.apply le_O_n. +qed. + +variant sym_gcd: \forall n,m:nat. gcd n m = gcd m n \def +symmetric_gcd. + +theorem le_gcd_times: \forall m,n,p:nat. O< p \to gcd m n \le gcd m (n*p). +intros. +apply (nat_case n).reflexivity. +intro. +apply divides_to_le. +apply lt_O_gcd. +rewrite > (times_n_O O). +apply lt_times.unfold lt.apply le_S_S.apply le_O_n.assumption. +apply divides_d_gcd. +apply (transitive_divides ? (S m1)). +apply divides_gcd_m. +apply (witness ? ? p).reflexivity. +apply divides_gcd_n. +qed. + +theorem gcd_times_SO_to_gcd_SO: \forall m,n,p:nat. O < n \to O < p \to +gcd m (n*p) = (S O) \to gcd m n = (S O). +intros. +apply antisymmetric_le. +rewrite < H2. +apply le_gcd_times.assumption. +change with (O < gcd m n). +apply lt_O_gcd.assumption. +qed. + +(* for the "converse" of the previous result see the end of this development *) + +theorem gcd_SO_n: \forall n:nat. gcd (S O) n = (S O). +intro. +apply antisym_le.apply divides_to_le.unfold lt.apply le_n. +apply divides_gcd_n. +cut (O < gcd (S O) n \lor O = gcd (S O) n). +elim Hcut.assumption. +apply False_ind. +apply (not_eq_O_S O). +cut ((S O)=O \land n=O). +elim Hcut1.apply sym_eq.assumption. +apply gcd_O_to_eq_O.apply sym_eq.assumption. +apply le_to_or_lt_eq.apply le_O_n. +qed. + +theorem divides_gcd_mod: \forall m,n:nat. O < n \to +divides (gcd m n) (gcd n (m \mod n)). +intros. +apply divides_d_gcd. +apply divides_mod.assumption. +apply divides_gcd_n. +apply divides_gcd_m. +apply divides_gcd_m. +qed. + +theorem divides_mod_gcd: \forall m,n:nat. O < n \to +divides (gcd n (m \mod n)) (gcd m n) . +intros. +apply divides_d_gcd. +apply divides_gcd_n. +apply (divides_mod_to_divides ? ? n). +assumption. +apply divides_gcd_m. +apply divides_gcd_n. +qed. + +theorem gcd_mod: \forall m,n:nat. O < n \to +(gcd n (m \mod n)) = (gcd m n) . +intros. +apply antisymmetric_divides. +apply divides_mod_gcd.assumption. +apply divides_gcd_mod.assumption. +qed. + +(* gcd and primes *) + +theorem prime_to_gcd_SO: \forall n,m:nat. prime n \to n \ndivides m \to +gcd n m = (S O). +intros.unfold prime in H.change with (gcd n m = (S O)). +elim H. +apply antisym_le. +apply not_lt_to_le. +change with ((S (S O)) \le gcd n m \to False).intro. +apply H1.rewrite < (H3 (gcd n m)). +apply divides_gcd_m. +apply divides_gcd_n.assumption. +cut (O < gcd n m \lor O = gcd n m). +elim Hcut.assumption. +apply False_ind. +apply (not_le_Sn_O (S O)). +cut (n=O \land m=O). +elim Hcut1.rewrite < H5 in \vdash (? ? %).assumption. +apply gcd_O_to_eq_O.apply sym_eq.assumption. +apply le_to_or_lt_eq.apply le_O_n. +qed. + +theorem divides_times_to_divides: \forall n,p,q:nat.prime n \to n \divides p*q \to +n \divides p \lor n \divides q. +intros. +cut (n \divides p \lor n \ndivides p). +elim Hcut. +left.assumption. +right. +cut (\exists a,b. a*n - b*p = (S O) \lor b*p - a*n = (S O)). +elim Hcut1.elim H3.elim H4. +(* first case *) +rewrite > (times_n_SO q).rewrite < H5. +rewrite > distr_times_minus. +rewrite > (sym_times q (a1*p)). +rewrite > (assoc_times a1). +elim H1.rewrite > H6. +rewrite < (sym_times n).rewrite < assoc_times. +rewrite > (sym_times q).rewrite > assoc_times. +rewrite < (assoc_times a1).rewrite < (sym_times n). +rewrite > (assoc_times n). +rewrite < distr_times_minus. +apply (witness ? ? (q*a-a1*n2)).reflexivity. +(* second case *) +rewrite > (times_n_SO q).rewrite < H5. +rewrite > distr_times_minus. +rewrite > (sym_times q (a1*p)). +rewrite > (assoc_times a1). +elim H1.rewrite > H6. +rewrite < sym_times.rewrite > assoc_times. +rewrite < (assoc_times q). +rewrite < (sym_times n). +rewrite < distr_times_minus. +apply (witness ? ? (n2*a1-q*a)).reflexivity. +(* end second case *) +rewrite < (prime_to_gcd_SO n p). +apply eq_minus_gcd. +assumption.assumption. +apply (decidable_divides n p). +apply (trans_lt ? (S O)).unfold lt.apply le_n. +unfold prime in H.elim H. assumption. +qed. + +theorem eq_gcd_times_SO: \forall m,n,p:nat. O < n \to O < p \to +gcd m n = (S O) \to gcd m p = (S O) \to gcd m (n*p) = (S O). +intros. +apply antisymmetric_le. +apply not_lt_to_le. +unfold Not.intro. +cut (divides (smallest_factor (gcd m (n*p))) n \lor + divides (smallest_factor (gcd m (n*p))) p). +elim Hcut. +apply (not_le_Sn_n (S O)). +change with ((S O) < (S O)). +rewrite < H2 in \vdash (? ? %). +apply (lt_to_le_to_lt ? (smallest_factor (gcd m (n*p)))). +apply lt_SO_smallest_factor.assumption. +apply divides_to_le. +rewrite > H2.unfold lt.apply le_n. +apply divides_d_gcd.assumption. +apply (transitive_divides ? (gcd m (n*p))). +apply divides_smallest_factor_n. +apply (trans_lt ? (S O)). unfold lt. apply le_n. assumption. +apply divides_gcd_n. +apply (not_le_Sn_n (S O)). +change with ((S O) < (S O)). +rewrite < H3 in \vdash (? ? %). +apply (lt_to_le_to_lt ? (smallest_factor (gcd m (n*p)))). +apply lt_SO_smallest_factor.assumption. +apply divides_to_le. +rewrite > H3.unfold lt.apply le_n. +apply divides_d_gcd.assumption. +apply (transitive_divides ? (gcd m (n*p))). +apply divides_smallest_factor_n. +apply (trans_lt ? (S O)). unfold lt. apply le_n. assumption. +apply divides_gcd_n. +apply divides_times_to_divides. +apply prime_smallest_factor_n. +assumption. +apply (transitive_divides ? (gcd m (n*p))). +apply divides_smallest_factor_n. +apply (trans_lt ? (S O)).unfold lt. apply le_n. assumption. +apply divides_gcd_m. +change with (O < gcd m (n*p)). +apply lt_O_gcd. +rewrite > (times_n_O O). +apply lt_times.assumption.assumption. +qed. diff --git a/helm/software/matita/library/nat/le_arith.ma b/helm/software/matita/library/nat/le_arith.ma new file mode 100644 index 000000000..a76183063 --- /dev/null +++ b/helm/software/matita/library/nat/le_arith.ma @@ -0,0 +1,95 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/le_arith". + +include "nat/times.ma". +include "nat/orders.ma". + +(* plus *) +theorem monotonic_le_plus_r: +\forall n:nat.monotonic nat le (\lambda m.n + m). +simplify.intros.elim n. +simplify.assumption. +simplify.apply le_S_S.assumption. +qed. + +theorem le_plus_r: \forall p,n,m:nat. n \le m \to p + n \le p + m +\def monotonic_le_plus_r. + +theorem monotonic_le_plus_l: +\forall m:nat.monotonic nat le (\lambda n.n + m). +simplify.intros. +rewrite < sym_plus.rewrite < (sym_plus m). +apply le_plus_r.assumption. +qed. + +theorem le_plus_l: \forall p,n,m:nat. n \le m \to n + p \le m + p +\def monotonic_le_plus_l. + +theorem le_plus: \forall n1,n2,m1,m2:nat. n1 \le n2 \to m1 \le m2 +\to n1 + m1 \le n2 + m2. +intros. +apply (trans_le ? (n2 + m1)). +apply le_plus_l.assumption. +apply le_plus_r.assumption. +qed. + +theorem le_plus_n :\forall n,m:nat. m \le n + m. +intros.change with (O+m \le n+m). +apply le_plus_l.apply le_O_n. +qed. + +theorem eq_plus_to_le: \forall n,m,p:nat.n=m+p \to m \le n. +intros.rewrite > H. +rewrite < sym_plus. +apply le_plus_n. +qed. + +(* times *) +theorem monotonic_le_times_r: +\forall n:nat.monotonic nat le (\lambda m. n * m). +simplify.intros.elim n. +simplify.apply le_O_n. +simplify.apply le_plus. +assumption. +assumption. +qed. + +theorem le_times_r: \forall p,n,m:nat. n \le m \to p*n \le p*m +\def monotonic_le_times_r. + +theorem monotonic_le_times_l: +\forall m:nat.monotonic nat le (\lambda n.n*m). +simplify.intros. +rewrite < sym_times.rewrite < (sym_times m). +apply le_times_r.assumption. +qed. + +theorem le_times_l: \forall p,n,m:nat. n \le m \to n*p \le m*p +\def monotonic_le_times_l. + +theorem le_times: \forall n1,n2,m1,m2:nat. n1 \le n2 \to m1 \le m2 +\to n1*m1 \le n2*m2. +intros. +apply (trans_le ? (n2*m1)). +apply le_times_l.assumption. +apply le_times_r.assumption. +qed. + +theorem le_times_n: \forall n,m:nat.(S O) \le n \to m \le n*m. +intros.elim H.simplify. +elim (plus_n_O ?).apply le_n. +simplify.rewrite < sym_plus.apply le_plus_n. +qed. diff --git a/helm/software/matita/library/nat/lt_arith.ma b/helm/software/matita/library/nat/lt_arith.ma new file mode 100644 index 000000000..f60da5eba --- /dev/null +++ b/helm/software/matita/library/nat/lt_arith.ma @@ -0,0 +1,221 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/lt_arith". + +include "nat/div_and_mod.ma". + +(* plus *) +theorem monotonic_lt_plus_r: +\forall n:nat.monotonic nat lt (\lambda m.n+m). +simplify.intros. +elim n.simplify.assumption. +simplify.unfold lt. +apply le_S_S.assumption. +qed. + +variant lt_plus_r: \forall n,p,q:nat. p < q \to n + p < n + q \def +monotonic_lt_plus_r. + +theorem monotonic_lt_plus_l: +\forall n:nat.monotonic nat lt (\lambda m.m+n). +change with (\forall n,p,q:nat. p < q \to p + n < q + n). +intros. +rewrite < sym_plus. rewrite < (sym_plus n). +apply lt_plus_r.assumption. +qed. + +variant lt_plus_l: \forall n,p,q:nat. p < q \to p + n < q + n \def +monotonic_lt_plus_l. + +theorem lt_plus: \forall n,m,p,q:nat. n < m \to p < q \to n + p < m + q. +intros. +apply (trans_lt ? (n + q)). +apply lt_plus_r.assumption. +apply lt_plus_l.assumption. +qed. + +theorem lt_plus_to_lt_l :\forall n,p,q:nat. p+n < q+n \to p plus_n_O. +rewrite > (plus_n_O q).assumption. +apply H. +unfold lt.apply le_S_S_to_le. +rewrite > plus_n_Sm. +rewrite > (plus_n_Sm q). +exact H1. +qed. + +theorem lt_plus_to_lt_r :\forall n,p,q:nat. n+p < n+q \to p sym_plus. +rewrite > (sym_plus q).assumption. +qed. + +(* times and zero *) +theorem lt_O_times_S_S: \forall n,m:nat.O < (S n)*(S m). +intros.simplify.unfold lt.apply le_S_S.apply le_O_n. +qed. + +(* times *) +theorem monotonic_lt_times_r: +\forall n:nat.monotonic nat lt (\lambda m.(S n)*m). +change with (\forall n,p,q:nat. p < q \to (S n) * p < (S n) * q). +intros.elim n. +simplify.rewrite < plus_n_O.rewrite < plus_n_O.assumption. +change with (p + (S n1) * p < q + (S n1) * q). +apply lt_plus.assumption.assumption. +qed. + +theorem lt_times_r: \forall n,p,q:nat. p < q \to (S n) * p < (S n) * q +\def monotonic_lt_times_r. + +theorem monotonic_lt_times_l: +\forall m:nat.monotonic nat lt (\lambda n.n * (S m)). +change with +(\forall n,p,q:nat. p < q \to p*(S n) < q*(S n)). +intros. +rewrite < sym_times.rewrite < (sym_times (S n)). +apply lt_times_r.assumption. +qed. + +variant lt_times_l: \forall n,p,q:nat. p nat_compare_n_n.reflexivity. +intro.apply nat_compare_elim.intro. +absurd (p (plus_n_O ((S m1)*(n / (S m1)))). +rewrite < H2. +rewrite < sym_times. +rewrite < div_mod. +rewrite > H2. +assumption. +unfold lt.apply le_S_S.apply le_O_n. +qed. + +theorem lt_div_n_m_n: \forall n,m:nat. (S O) < m \to O < n \to n / m \lt n. +intros. +apply (nat_case1 (n / m)).intro. +assumption.intros.rewrite < H2. +rewrite > (div_mod n m) in \vdash (? ? %). +apply (lt_to_le_to_lt ? ((n / m)*m)). +apply (lt_to_le_to_lt ? ((n / m)*(S (S O)))). +rewrite < sym_times. +rewrite > H2. +simplify.unfold lt. +rewrite < plus_n_O. +rewrite < plus_n_Sm. +apply le_S_S. +apply le_S_S. +apply le_plus_n. +apply le_times_r. +assumption. +rewrite < sym_plus. +apply le_plus_n. +apply (trans_lt ? (S O)). +unfold lt. apply le_n.assumption. +qed. + +(* general properties of functions *) +theorem monotonic_to_injective: \forall f:nat\to nat. +monotonic nat lt f \to injective nat nat f. +unfold injective.intros. +apply (nat_compare_elim x y). +intro.apply False_ind.apply (not_le_Sn_n (f x)). +rewrite > H1 in \vdash (? ? %). +change with (f x < f y). +apply H.apply H2. +intros.assumption. +intro.apply False_ind.apply (not_le_Sn_n (f y)). +rewrite < H1 in \vdash (? ? %). +change with (f y < f x). +apply H.apply H2. +qed. + +theorem increasing_to_injective: \forall f:nat\to nat. +increasing f \to injective nat nat f. +intros.apply monotonic_to_injective. +apply increasing_to_monotonic.assumption. +qed. diff --git a/helm/software/matita/library/nat/minimization.ma b/helm/software/matita/library/nat/minimization.ma new file mode 100644 index 000000000..0abed5ad3 --- /dev/null +++ b/helm/software/matita/library/nat/minimization.ma @@ -0,0 +1,222 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/minimization". + +include "nat/minus.ma". + +let rec max i f \def + match (f i) with + [ true \Rightarrow i + | false \Rightarrow + match i with + [ O \Rightarrow O + | (S j) \Rightarrow max j f ]]. + +theorem max_O_f : \forall f: nat \to bool. max O f = O. +intro. simplify. +elim (f O). +simplify.reflexivity. +simplify.reflexivity. +qed. + +theorem max_S_max : \forall f: nat \to bool. \forall n:nat. +(f (S n) = true \land max (S n) f = (S n)) \lor +(f (S n) = false \land max (S n) f = max n f). +intros.simplify.elim (f (S n)). +simplify.left.split.reflexivity.reflexivity. +simplify.right.split.reflexivity.reflexivity. +qed. + +theorem le_max_n : \forall f: nat \to bool. \forall n:nat. +max n f \le n. +intros.elim n.rewrite > max_O_f.apply le_n. +simplify.elim (f (S n1)).simplify.apply le_n. +simplify.apply le_S.assumption. +qed. + +theorem le_to_le_max : \forall f: nat \to bool. \forall n,m:nat. +n\le m \to max n f \le max m f. +intros.elim H. +apply le_n. +apply (trans_le ? (max n1 f)).apply H2. +cut ((f (S n1) = true \land max (S n1) f = (S n1)) \lor +(f (S n1) = false \land max (S n1) f = max n1 f)). +elim Hcut.elim H3. +rewrite > H5. +apply le_S.apply le_max_n. +elim H3.rewrite > H5.apply le_n. +apply max_S_max. +qed. + +theorem f_m_to_le_max: \forall f: nat \to bool. \forall n,m:nat. +m\le n \to f m = true \to m \le max n f. +intros 3.elim n.apply (le_n_O_elim m H). +apply le_O_n. +apply (le_n_Sm_elim m n1 H1). +intro.apply (trans_le ? (max n1 f)). +apply H.apply le_S_S_to_le.assumption.assumption. +apply le_to_le_max.apply le_n_Sn. +intro.simplify.rewrite < H3. +rewrite > H2.simplify.apply le_n. +qed. + + +definition max_spec \def \lambda f:nat \to bool.\lambda n: nat. +\exists i. (le i n) \land (f i = true) \to +(f n) = true \land (\forall i. i < n \to (f i = false)). + +theorem f_max_true : \forall f:nat \to bool. \forall n:nat. +(\exists i:nat. le i n \land f i = true) \to f (max n f) = true. +intros 2. +elim n.elim H.elim H1.generalize in match H3. +apply (le_n_O_elim a H2).intro.simplify.rewrite > H4. +simplify.assumption. +simplify. +apply (bool_ind (\lambda b:bool. +(f (S n1) = b) \to (f (match b in bool with +[ true \Rightarrow (S n1) +| false \Rightarrow (max n1 f)])) = true)). +simplify.intro.assumption. +simplify.intro.apply H. +elim H1.elim H3.generalize in match H5. +apply (le_n_Sm_elim a n1 H4). +intros. +apply (ex_intro nat ? a). +split.apply le_S_S_to_le.assumption.assumption. +intros.apply False_ind.apply not_eq_true_false. +rewrite < H2.rewrite < H7.rewrite > H6. reflexivity. +reflexivity. +qed. + +theorem lt_max_to_false : \forall f:nat \to bool. +\forall n,m:nat. (max n f) < m \to m \leq n \to f m = false. +intros 2. +elim n.absurd (le m O).assumption. +cut (O < m).apply (lt_O_n_elim m Hcut).exact not_le_Sn_O. +rewrite < (max_O_f f).assumption. +generalize in match H1. +elim (max_S_max f n1). +elim H3. +absurd (m \le S n1).assumption. +apply lt_to_not_le.rewrite < H6.assumption. +elim H3. +apply (le_n_Sm_elim m n1 H2). +intro. +apply H.rewrite < H6.assumption. +apply le_S_S_to_le.assumption. +intro.rewrite > H7.assumption. +qed. + +let rec min_aux off n f \def + match f (n-off) with + [ true \Rightarrow (n-off) + | false \Rightarrow + match off with + [ O \Rightarrow n + | (S p) \Rightarrow min_aux p n f]]. + +definition min : nat \to (nat \to bool) \to nat \def +\lambda n.\lambda f. min_aux n n f. + +theorem min_aux_O_f: \forall f:nat \to bool. \forall i :nat. +min_aux O i f = i. +intros.simplify.rewrite < minus_n_O. +elim (f i).reflexivity. +simplify.reflexivity. +qed. + +theorem min_O_f : \forall f:nat \to bool. +min O f = O. +intro.apply (min_aux_O_f f O). +qed. + +theorem min_aux_S : \forall f: nat \to bool. \forall i,n:nat. +(f (n -(S i)) = true \land min_aux (S i) n f = (n - (S i))) \lor +(f (n -(S i)) = false \land min_aux (S i) n f = min_aux i n f). +intros.simplify.elim (f (n - (S i))). +simplify.left.split.reflexivity.reflexivity. +simplify.right.split.reflexivity.reflexivity. +qed. + +theorem f_min_aux_true: \forall f:nat \to bool. \forall off,m:nat. +(\exists i. le (m-off) i \land le i m \land f i = true) \to +f (min_aux off m f) = true. +intros 2. +elim off.elim H.elim H1.elim H2. +cut (a = m). +rewrite > (min_aux_O_f f).rewrite < Hcut.assumption. +apply (antisym_le a m).assumption.rewrite > (minus_n_O m).assumption. +simplify. +apply (bool_ind (\lambda b:bool. +(f (m-(S n)) = b) \to (f (match b in bool with +[ true \Rightarrow m-(S n) +| false \Rightarrow (min_aux n m f)])) = true)). +simplify.intro.assumption. +simplify.intro.apply H. +elim H1.elim H3.elim H4. +elim (le_to_or_lt_eq (m-(S n)) a H6). +apply (ex_intro nat ? a). +split.split. +apply lt_minus_S_n_to_le_minus_n.assumption. +assumption.assumption. +absurd (f a = false).rewrite < H8.assumption. +rewrite > H5. +apply not_eq_true_false. +reflexivity. +qed. + +theorem lt_min_aux_to_false : \forall f:nat \to bool. +\forall n,off,m:nat. (n-off) \leq m \to m < (min_aux off n f) \to f m = false. +intros 3. +elim off.absurd (le n m).rewrite > minus_n_O.assumption. +apply lt_to_not_le.rewrite < (min_aux_O_f f n).assumption. +generalize in match H1. +elim (min_aux_S f n1 n). +elim H3. +absurd (n - S n1 \le m).assumption. +apply lt_to_not_le.rewrite < H6.assumption. +elim H3. +elim (le_to_or_lt_eq (n -(S n1)) m). +apply H.apply lt_minus_S_n_to_le_minus_n.assumption. +rewrite < H6.assumption. +rewrite < H7.assumption. +assumption. +qed. + +theorem le_min_aux : \forall f:nat \to bool. +\forall n,off:nat. (n-off) \leq (min_aux off n f). +intros 3. +elim off.rewrite < minus_n_O. +rewrite > (min_aux_O_f f n).apply le_n. +elim (min_aux_S f n1 n). +elim H1.rewrite > H3.apply le_n. +elim H1.rewrite > H3. +apply (trans_le (n-(S n1)) (n-n1)). +apply monotonic_le_minus_r. +apply le_n_Sn. +assumption. +qed. + +theorem le_min_aux_r : \forall f:nat \to bool. +\forall n,off:nat. (min_aux off n f) \le n. +intros. +elim off.simplify.rewrite < minus_n_O. +elim (f n).simplify.apply le_n. +simplify.apply le_n. +simplify.elim (f (n -(S n1))). +simplify.apply le_plus_to_minus. +rewrite < sym_plus.apply le_plus_n. +simplify.assumption. +qed. diff --git a/helm/software/matita/library/nat/minus.ma b/helm/software/matita/library/nat/minus.ma new file mode 100644 index 000000000..710418d72 --- /dev/null +++ b/helm/software/matita/library/nat/minus.ma @@ -0,0 +1,300 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + + +set "baseuri" "cic:/matita/nat/minus". + +include "nat/le_arith.ma". +include "nat/compare.ma". + +let rec minus n m \def + match n with + [ O \Rightarrow O + | (S p) \Rightarrow + match m with + [O \Rightarrow (S p) + | (S q) \Rightarrow minus p q ]]. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural minus" 'minus x y = (cic:/matita/nat/minus/minus.con x y). + +theorem minus_n_O: \forall n:nat.n=n-O. +intros.elim n.simplify.reflexivity. +simplify.reflexivity. +qed. + +theorem minus_n_n: \forall n:nat.O=n-n. +intros.elim n.simplify. +reflexivity. +simplify.apply H. +qed. + +theorem minus_Sn_n: \forall n:nat. S O = (S n)-n. +intro.elim n. +simplify.reflexivity. +elim H.reflexivity. +qed. + +theorem minus_Sn_m: \forall n,m:nat. m \leq n \to (S n)-m = S (n-m). +intros 2. +apply (nat_elim2 +(\lambda n,m.m \leq n \to (S n)-m = S (n-m))). +intros.apply (le_n_O_elim n1 H). +simplify.reflexivity. +intros.simplify.reflexivity. +intros.rewrite < H.reflexivity. +apply le_S_S_to_le. assumption. +qed. + +theorem plus_minus: +\forall n,m,p:nat. m \leq n \to (n-m)+p = (n+p)-m. +intros 2. +apply (nat_elim2 +(\lambda n,m.\forall p:nat.m \leq n \to (n-m)+p = (n+p)-m)). +intros.apply (le_n_O_elim ? H). +simplify.rewrite < minus_n_O.reflexivity. +intros.simplify.reflexivity. +intros.simplify.apply H.apply le_S_S_to_le.assumption. +qed. + +theorem minus_plus_m_m: \forall n,m:nat.n = (n+m)-m. +intros 2. +generalize in match n. +elim m. +rewrite < minus_n_O.apply plus_n_O. +elim n2.simplify. +apply minus_n_n. +rewrite < plus_n_Sm. +change with (S n3 = (S n3 + n1)-n1). +apply H. +qed. + +theorem plus_minus_m_m: \forall n,m:nat. +m \leq n \to n = (n-m)+m. +intros 2. +apply (nat_elim2 (\lambda n,m.m \leq n \to n = (n-m)+m)). +intros.apply (le_n_O_elim n1 H). +reflexivity. +intros.simplify.rewrite < plus_n_O.reflexivity. +intros.simplify.rewrite < sym_plus.simplify. +apply eq_f.rewrite < sym_plus.apply H. +apply le_S_S_to_le.assumption. +qed. + +theorem minus_to_plus :\forall n,m,p:nat.m \leq n \to n-m = p \to +n = m+p. +intros.apply (trans_eq ? ? ((n-m)+m)). +apply plus_minus_m_m. +apply H.elim H1. +apply sym_plus. +qed. + +theorem plus_to_minus :\forall n,m,p:nat. +n = m+p \to n-m = p. +intros. +apply (inj_plus_r m). +rewrite < H. +rewrite < sym_plus. +symmetry. +apply plus_minus_m_m.rewrite > H. +rewrite > sym_plus. +apply le_plus_n. +qed. + +theorem minus_S_S : \forall n,m:nat. +eq nat (minus (S n) (S m)) (minus n m). +intros. +reflexivity. +qed. + +theorem minus_pred_pred : \forall n,m:nat. lt O n \to lt O m \to +eq nat (minus (pred n) (pred m)) (minus n m). +intros. +apply (lt_O_n_elim n H).intro. +apply (lt_O_n_elim m H1).intro. +simplify.reflexivity. +qed. + +theorem eq_minus_n_m_O: \forall n,m:nat. +n \leq m \to n-m = O. +intros 2. +apply (nat_elim2 (\lambda n,m.n \leq m \to n-m = O)). +intros.simplify.reflexivity. +intros.apply False_ind. +apply not_le_Sn_O. +goal 13.apply H. +intros. +simplify.apply H.apply le_S_S_to_le. apply H1. +qed. + +theorem le_SO_minus: \forall n,m:nat.S n \leq m \to S O \leq m-n. +intros.elim H.elim (minus_Sn_n n).apply le_n. +rewrite > minus_Sn_m. +apply le_S.assumption. +apply lt_to_le.assumption. +qed. + +theorem minus_le_S_minus_S: \forall n,m:nat. m-n \leq S (m-(S n)). +intros.apply (nat_elim2 (\lambda n,m.m-n \leq S (m-(S n)))). +intro.elim n1.simplify.apply le_n_Sn. +simplify.rewrite < minus_n_O.apply le_n. +intros.simplify.apply le_n_Sn. +intros.simplify.apply H. +qed. + +theorem lt_minus_S_n_to_le_minus_n : \forall n,m,p:nat. m-(S n) < p \to m-n \leq p. +intros 3.simplify.intro. +apply (trans_le (m-n) (S (m-(S n))) p). +apply minus_le_S_minus_S. +assumption. +qed. + +theorem le_minus_m: \forall n,m:nat. n-m \leq n. +intros.apply (nat_elim2 (\lambda m,n. n-m \leq n)). +intros.rewrite < minus_n_O.apply le_n. +intros.simplify.apply le_n. +intros.simplify.apply le_S.assumption. +qed. + +theorem lt_minus_m: \forall n,m:nat. O < n \to O < m \to n-m \lt n. +intros.apply (lt_O_n_elim n H).intro. +apply (lt_O_n_elim m H1).intro. +simplify.unfold lt.apply le_S_S.apply le_minus_m. +qed. + +theorem minus_le_O_to_le: \forall n,m:nat. n-m \leq O \to n \leq m. +intros 2. +apply (nat_elim2 (\lambda n,m:nat.n-m \leq O \to n \leq m)). +intros.apply le_O_n. +simplify.intros. assumption. +simplify.intros.apply le_S_S.apply H.assumption. +qed. + +(* galois *) +theorem monotonic_le_minus_r: +\forall p,q,n:nat. q \leq p \to n-p \le n-q. +simplify.intros 2.apply (nat_elim2 +(\lambda p,q.\forall a.q \leq p \to a-p \leq a-q)). +intros.apply (le_n_O_elim n H).apply le_n. +intros.rewrite < minus_n_O. +apply le_minus_m. +intros.elim a.simplify.apply le_n. +simplify.apply H.apply le_S_S_to_le.assumption. +qed. + +theorem le_minus_to_plus: \forall n,m,p. (le (n-m) p) \to (le n (p+m)). +intros 2.apply (nat_elim2 (\lambda n,m.\forall p.(le (n-m) p) \to (le n (p+m)))). +intros.apply le_O_n. +simplify.intros.rewrite < plus_n_O.assumption. +intros. +rewrite < plus_n_Sm. +apply le_S_S.apply H. +exact H1. +qed. + +theorem le_plus_to_minus: \forall n,m,p. (le n (p+m)) \to (le (n-m) p). +intros 2.apply (nat_elim2 (\lambda n,m.\forall p.(le n (p+m)) \to (le (n-m) p))). +intros.simplify.apply le_O_n. +intros 2.rewrite < plus_n_O.intro.simplify.assumption. +intros.simplify.apply H. +apply le_S_S_to_le.rewrite > plus_n_Sm.assumption. +qed. + +(* the converse of le_plus_to_minus does not hold *) +theorem le_plus_to_minus_r: \forall n,m,p. (le (n+m) p) \to (le n (p-m)). +intros 3.apply (nat_elim2 (\lambda m,p.(le (n+m) p) \to (le n (p-m)))). +intro.rewrite < plus_n_O.rewrite < minus_n_O.intro.assumption. +intro.intro.cut (n=O).rewrite > Hcut.apply le_O_n. +apply sym_eq. apply le_n_O_to_eq. +apply (trans_le ? (n+(S n1))). +rewrite < sym_plus. +apply le_plus_n.assumption. +intros.simplify. +apply H.apply le_S_S_to_le. +rewrite > plus_n_Sm.assumption. +qed. + +(* minus and lt - to be completed *) +theorem lt_minus_to_plus: \forall n,m,p. (lt n (p-m)) \to (lt (n+m) p). +intros 3.apply (nat_elim2 (\lambda m,p.(lt n (p-m)) \to (lt (n+m) p))). +intro.rewrite < plus_n_O.rewrite < minus_n_O.intro.assumption. +simplify.intros.apply False_ind.apply (not_le_Sn_O n H). +simplify.intros.unfold lt. +apply le_S_S. +rewrite < plus_n_Sm. +apply H.apply H1. +qed. + +theorem distributive_times_minus: distributive nat times minus. +unfold distributive. +intros. +apply ((leb_elim z y)). + intro.cut (x*(y-z)+x*z = (x*y-x*z)+x*z). + apply (inj_plus_l (x*z)).assumption. + apply (trans_eq nat ? (x*y)). + rewrite < distr_times_plus.rewrite < (plus_minus_m_m ? ? H).reflexivity. + rewrite < plus_minus_m_m. + reflexivity. + apply le_times_r.assumption. + intro.rewrite > eq_minus_n_m_O. + rewrite > (eq_minus_n_m_O (x*y)). + rewrite < sym_times.simplify.reflexivity. + apply le_times_r.apply lt_to_le.apply not_le_to_lt.assumption. + apply lt_to_le.apply not_le_to_lt.assumption. +qed. + +theorem distr_times_minus: \forall n,m,p:nat. n*(m-p) = n*m-n*p +\def distributive_times_minus. + +theorem eq_minus_plus_plus_minus: \forall n,m,p:nat. p \le m \to (n+m)-p = n+(m-p). +intros. +apply plus_to_minus. +rewrite > sym_plus in \vdash (? ? ? %). +rewrite > assoc_plus. +rewrite < plus_minus_m_m. +reflexivity.assumption. +qed. + +theorem eq_minus_minus_minus_plus: \forall n,m,p:nat. (n-m)-p = n-(m+p). +intros. +cut (m+p \le n \or m+p \nleq n). + elim Hcut. + symmetry.apply plus_to_minus. + rewrite > assoc_plus.rewrite > (sym_plus p).rewrite < plus_minus_m_m. + rewrite > sym_plus.rewrite < plus_minus_m_m. + reflexivity. + apply (trans_le ? (m+p)). + rewrite < sym_plus.apply le_plus_n. + assumption. + apply le_plus_to_minus_r.rewrite > sym_plus.assumption. + rewrite > (eq_minus_n_m_O n (m+p)). + rewrite > (eq_minus_n_m_O (n-m) p). + reflexivity. + apply le_plus_to_minus.apply lt_to_le. rewrite < sym_plus. + apply not_le_to_lt. assumption. + apply lt_to_le.apply not_le_to_lt.assumption. + apply (decidable_le (m+p) n). +qed. + +theorem eq_plus_minus_minus_minus: \forall n,m,p:nat. p \le m \to m \le n \to +p+(n-m) = n-(m-p). +intros. +apply sym_eq. +apply plus_to_minus. +rewrite < assoc_plus. +rewrite < plus_minus_m_m. +rewrite < sym_plus. +rewrite < plus_minus_m_m.reflexivity. +assumption.assumption. +qed. diff --git a/helm/software/matita/library/nat/nat.ma b/helm/software/matita/library/nat/nat.ma new file mode 100644 index 000000000..b600072c6 --- /dev/null +++ b/helm/software/matita/library/nat/nat.ma @@ -0,0 +1,107 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/nat". + +include "higher_order_defs/functions.ma". + +inductive nat : Set \def + | O : nat + | S : nat \to nat. + +definition pred: nat \to nat \def + \lambda n:nat. match n with + [ O \Rightarrow O + | (S p) \Rightarrow p ]. + +theorem pred_Sn : \forall n:nat.n=(pred (S n)). + intros. reflexivity. +qed. + +theorem injective_S : injective nat nat S. + unfold injective. + intros. + rewrite > pred_Sn. + rewrite > (pred_Sn y). + apply eq_f. assumption. +qed. + +theorem inj_S : \forall n,m:nat.(S n)=(S m) \to n=m \def + injective_S. + +theorem not_eq_S : \forall n,m:nat. + \lnot n=m \to S n \neq S m. + intros. unfold Not. intros. + apply H. apply injective_S. assumption. +qed. + +definition not_zero : nat \to Prop \def + \lambda n: nat. + match n with + [ O \Rightarrow False + | (S p) \Rightarrow True ]. + +theorem not_eq_O_S : \forall n:nat. O \neq S n. + intros. unfold Not. intros. + cut (not_zero O). + exact Hcut. + rewrite > H.exact I. +qed. + +theorem not_eq_n_Sn : \forall n:nat. n \neq S n. + intros.elim n. + apply not_eq_O_S. + apply not_eq_S.assumption. +qed. + +theorem nat_case: + \forall n:nat.\forall P:nat \to Prop. + P O \to (\forall m:nat. P (S m)) \to P n. +intros.elim n + [ assumption + | apply H1 ] +qed. + +theorem nat_case1: + \forall n:nat.\forall P:nat \to Prop. + (n=O \to P O) \to (\forall m:nat. (n=(S m) \to P (S m))) \to P n. +intros 2; elim n + [ apply H;reflexivity + | apply H2;reflexivity ] +qed. + +theorem nat_elim2 : + \forall R:nat \to nat \to Prop. + (\forall n:nat. R O n) + \to (\forall n:nat. R (S n) O) + \to (\forall n,m:nat. R n m \to R (S n) (S m)) + \to \forall n,m:nat. R n m. +intros 5;elim n + [ apply H + | apply (nat_case m) + [ apply H1 + | intro; apply H2; apply H3 ] ] +qed. + +theorem decidable_eq_nat : \forall n,m:nat.decidable (n=m). + intros.unfold decidable. + apply (nat_elim2 (\lambda n,m.(Or (n=m) ((n=m) \to False)))) + [ intro; elim n1 + [ left; reflexivity + | right; apply not_eq_O_S ] + | intro; right; intro; apply (not_eq_O_S n1); apply sym_eq; assumption + | intros; elim H + [ left; apply eq_f; assumption + | right; intro; apply H1; apply inj_S; assumption ] ] +qed. diff --git a/helm/software/matita/library/nat/nth_prime.ma b/helm/software/matita/library/nat/nth_prime.ma new file mode 100644 index 000000000..5330f52ad --- /dev/null +++ b/helm/software/matita/library/nat/nth_prime.ma @@ -0,0 +1,200 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/nth_prime". + +include "nat/primes.ma". +include "nat/lt_arith.ma". + +(* upper bound by Bertrand's conjecture. *) +(* Too difficult to prove. +let rec nth_prime n \def +match n with + [ O \Rightarrow (S(S O)) + | (S p) \Rightarrow + let previous_prime \def S (nth_prime p) in + min_aux previous_prime ((S(S O))*previous_prime) primeb]. + +theorem example8 : nth_prime (S(S O)) = (S(S(S(S(S O))))). +normalize.reflexivity. +qed. + +theorem example9 : nth_prime (S(S(S O))) = (S(S(S(S(S(S(S O))))))). +normalize.reflexivity. +qed. + +theorem example10 : nth_prime (S(S(S(S O)))) = (S(S(S(S(S(S(S(S(S(S(S O))))))))))). +normalize.reflexivity. +qed. *) + +theorem smallest_factor_fact: \forall n:nat. +n < smallest_factor (S n!). +intros. +apply not_le_to_lt. +change with (smallest_factor (S n!) \le n \to False).intro. +apply (not_divides_S_fact n (smallest_factor(S n!))). +apply lt_SO_smallest_factor. +unfold lt.apply le_S_S.apply le_SO_fact. +assumption. +apply divides_smallest_factor_n. +unfold lt.apply le_S_S.apply le_O_n. +qed. + +theorem ex_prime: \forall n. (S O) \le n \to \exists m. +n < m \land m \le S n! \land (prime m). +intros. +elim H. +apply (ex_intro nat ? (S(S O))). +split.split.apply (le_n (S(S O))). +apply (le_n (S(S O))).apply (primeb_to_Prop (S(S O))). +apply (ex_intro nat ? (smallest_factor (S (S n1)!))). +split.split. +apply smallest_factor_fact. +apply le_smallest_factor_n. +(* Andrea: ancora hint non lo trova *) +apply prime_smallest_factor_n. +change with ((S(S O)) \le S (S n1)!). +apply le_S.apply le_SSO_fact. +unfold lt.apply le_S_S.assumption. +qed. + +let rec nth_prime n \def +match n with + [ O \Rightarrow (S(S O)) + | (S p) \Rightarrow + let previous_prime \def (nth_prime p) in + let upper_bound \def S previous_prime! in + min_aux (upper_bound - (S previous_prime)) upper_bound primeb]. + +(* it works, but nth_prime 4 takes already a few minutes - +it must compute factorial of 7 ... + +theorem example11 : nth_prime (S(S O)) = (S(S(S(S(S O))))). +normalize.reflexivity. +qed. + +theorem example12: nth_prime (S(S(S O))) = (S(S(S(S(S(S(S O))))))). +normalize.reflexivity. +qed. + +theorem example13 : nth_prime (S(S(S(S O)))) = (S(S(S(S(S(S(S(S(S(S(S O))))))))))). +normalize.reflexivity. +*) + +theorem prime_nth_prime : \forall n:nat.prime (nth_prime n). +intro. +apply (nat_case n). +change with (prime (S(S O))). +apply (primeb_to_Prop (S(S O))). +intro. +change with +(let previous_prime \def (nth_prime m) in +let upper_bound \def S previous_prime! in +prime (min_aux (upper_bound - (S previous_prime)) upper_bound primeb)). +apply primeb_true_to_prime. +apply f_min_aux_true. +apply (ex_intro nat ? (smallest_factor (S (nth_prime m)!))). +split.split. +cut (S (nth_prime m)!-(S (nth_prime m)! - (S (nth_prime m))) = (S (nth_prime m))). +rewrite > Hcut.exact (smallest_factor_fact (nth_prime m)). +(* maybe we could factorize this proof *) +apply plus_to_minus. +apply plus_minus_m_m. +apply le_S_S. +apply le_n_fact_n. +apply le_smallest_factor_n. +apply prime_to_primeb_true. +apply prime_smallest_factor_n. +change with ((S(S O)) \le S (nth_prime m)!). +apply le_S_S.apply le_SO_fact. +qed. + +(* properties of nth_prime *) +theorem increasing_nth_prime: increasing nth_prime. +change with (\forall n:nat. (nth_prime n) < (nth_prime (S n))). +intros. +change with +(let previous_prime \def (nth_prime n) in +let upper_bound \def S previous_prime! in +(S previous_prime) \le min_aux (upper_bound - (S previous_prime)) upper_bound primeb). +intros. +cut (upper_bound - (upper_bound -(S previous_prime)) = (S previous_prime)). +rewrite < Hcut in \vdash (? % ?). +apply le_min_aux. +apply plus_to_minus. +apply plus_minus_m_m. +apply le_S_S. +apply le_n_fact_n. +qed. + +variant lt_nth_prime_n_nth_prime_Sn :\forall n:nat. +(nth_prime n) < (nth_prime (S n)) \def increasing_nth_prime. + +theorem injective_nth_prime: injective nat nat nth_prime. +apply increasing_to_injective. +apply increasing_nth_prime. +qed. + +theorem lt_SO_nth_prime_n : \forall n:nat. (S O) \lt nth_prime n. +intros. elim n.unfold lt.apply le_n. +apply (trans_lt ? (nth_prime n1)). +assumption.apply lt_nth_prime_n_nth_prime_Sn. +qed. + +theorem lt_O_nth_prime_n : \forall n:nat. O \lt nth_prime n. +intros.apply (trans_lt O (S O)). +unfold lt. apply le_n.apply lt_SO_nth_prime_n. +qed. + +theorem ex_m_le_n_nth_prime_m: +\forall n: nat. nth_prime O \le n \to +\exists m. nth_prime m \le n \land n < nth_prime (S m). +intros. +apply increasing_to_le2. +exact lt_nth_prime_n_nth_prime_Sn.assumption. +qed. + +theorem lt_nth_prime_to_not_prime: \forall n,m. nth_prime n < m \to m < nth_prime (S n) +\to \lnot (prime m). +intros. +apply primeb_false_to_not_prime. +letin previous_prime \def (nth_prime n). +letin upper_bound \def (S previous_prime!). +apply (lt_min_aux_to_false primeb upper_bound (upper_bound - (S previous_prime)) m). +cut (S (nth_prime n)!-(S (nth_prime n)! - (S (nth_prime n))) = (S (nth_prime n))). +rewrite > Hcut.assumption. +apply plus_to_minus. +apply plus_minus_m_m. +apply le_S_S. +apply le_n_fact_n. +assumption. +qed. + +(* nth_prime enumerates all primes *) +theorem prime_to_nth_prime : \forall p:nat. prime p \to +\exists i. nth_prime i = p. +intros. +cut (\exists m. nth_prime m \le p \land p < nth_prime (S m)). +elim Hcut.elim H1. +cut (nth_prime a < p \lor nth_prime a = p). +elim Hcut1. +absurd (prime p). +assumption. +apply (lt_nth_prime_to_not_prime a).assumption.assumption. +apply (ex_intro nat ? a).assumption. +apply le_to_or_lt_eq.assumption. +apply ex_m_le_n_nth_prime_m. +simplify.unfold prime in H.elim H.assumption. +qed. + diff --git a/helm/software/matita/library/nat/ord.ma b/helm/software/matita/library/nat/ord.ma new file mode 100644 index 000000000..24874c08a --- /dev/null +++ b/helm/software/matita/library/nat/ord.ma @@ -0,0 +1,193 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/log". + +include "datatypes/constructors.ma". +include "nat/exp.ma". +include "nat/lt_arith.ma". +include "nat/primes.ma". + +(* this definition of log is based on pairs, with a remainder *) + +let rec p_ord_aux p n m \def + match n \mod m with + [ O \Rightarrow + match p with + [ O \Rightarrow pair nat nat O n + | (S p) \Rightarrow + match (p_ord_aux p (n / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r] ] + | (S a) \Rightarrow pair nat nat O n]. + +(* p_ord n m = if m divides n q times, with remainder r *) +definition p_ord \def \lambda n,m:nat.p_ord_aux n n m. + +theorem p_ord_aux_to_Prop: \forall p,n,m. O < m \to + match p_ord_aux p n m with + [ (pair q r) \Rightarrow n = m \sup q *r ]. +intro. +elim p. +change with +match ( +match n \mod m with + [ O \Rightarrow pair nat nat O n + | (S a) \Rightarrow pair nat nat O n] ) +with + [ (pair q r) \Rightarrow n = m \sup q * r ]. +apply (nat_case (n \mod m)). +simplify.apply plus_n_O. +intros. +simplify.apply plus_n_O. +change with +match ( +match n1 \mod m with + [ O \Rightarrow + match (p_ord_aux n (n1 / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r] + | (S a) \Rightarrow pair nat nat O n1] ) +with + [ (pair q r) \Rightarrow n1 = m \sup q * r]. +apply (nat_case1 (n1 \mod m)).intro. +change with +match ( + match (p_ord_aux n (n1 / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r]) +with + [ (pair q r) \Rightarrow n1 = m \sup q * r]. +generalize in match (H (n1 / m) m). +elim (p_ord_aux n (n1 / m) m). +simplify. +rewrite > assoc_times. +rewrite < H3.rewrite > (plus_n_O (m*(n1 / m))). +rewrite < H2. +rewrite > sym_times. +rewrite < div_mod.reflexivity. +assumption.assumption. +intros.simplify.apply plus_n_O. +qed. + +theorem p_ord_aux_to_exp: \forall p,n,m,q,r. O < m \to + (pair nat nat q r) = p_ord_aux p n m \to n = m \sup q * r. +intros. +change with +match (pair nat nat q r) with + [ (pair q r) \Rightarrow n = m \sup q * r ]. +rewrite > H1. +apply p_ord_aux_to_Prop. +assumption. +qed. +(* questo va spostato in primes1.ma *) +theorem p_ord_exp: \forall n,m,i. O < m \to n \mod m \neq O \to +\forall p. i \le p \to p_ord_aux p (m \sup i * n) m = pair nat nat i n. +intros 5. +elim i. +simplify. +rewrite < plus_n_O. +apply (nat_case p). +change with + (match n \mod m with + [ O \Rightarrow pair nat nat O n + | (S a) \Rightarrow pair nat nat O n] + = pair nat nat O n). +elim (n \mod m).simplify.reflexivity.simplify.reflexivity. +intro. +change with + (match n \mod m with + [ O \Rightarrow + match (p_ord_aux m1 (n / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r] + | (S a) \Rightarrow pair nat nat O n] + = pair nat nat O n). +cut (O < n \mod m \lor O = n \mod m). +elim Hcut.apply (lt_O_n_elim (n \mod m) H3). +intros. simplify.reflexivity. +apply False_ind. +apply H1.apply sym_eq.assumption. +apply le_to_or_lt_eq.apply le_O_n. +generalize in match H3. +apply (nat_case p).intro.apply False_ind.apply (not_le_Sn_O n1 H4). +intros. +change with + (match ((m \sup (S n1) *n) \mod m) with + [ O \Rightarrow + match (p_ord_aux m1 ((m \sup (S n1) *n) / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r] + | (S a) \Rightarrow pair nat nat O (m \sup (S n1) *n)] + = pair nat nat (S n1) n). +cut (((m \sup (S n1)*n) \mod m) = O). +rewrite > Hcut. +change with +(match (p_ord_aux m1 ((m \sup (S n1)*n) / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r] + = pair nat nat (S n1) n). +cut ((m \sup (S n1) *n) / m = m \sup n1 *n). +rewrite > Hcut1. +rewrite > (H2 m1). simplify.reflexivity. +apply le_S_S_to_le.assumption. +(* div_exp *) +change with ((m* m \sup n1 *n) / m = m \sup n1 * n). +rewrite > assoc_times. +apply (lt_O_n_elim m H). +intro.apply div_times. +(* mod_exp = O *) +apply divides_to_mod_O. +assumption. +simplify.rewrite > assoc_times. +apply (witness ? ? (m \sup n1 *n)).reflexivity. +qed. + +theorem p_ord_aux_to_Prop1: \forall p,n,m. (S O) < m \to O < n \to n \le p \to + match p_ord_aux p n m with + [ (pair q r) \Rightarrow r \mod m \neq O]. +intro.elim p.absurd (O < n).assumption. +apply le_to_not_lt.assumption. +change with +match + (match n1 \mod m with + [ O \Rightarrow + match (p_ord_aux n(n1 / m) m) with + [ (pair q r) \Rightarrow pair nat nat (S q) r] + | (S a) \Rightarrow pair nat nat O n1]) +with + [ (pair q r) \Rightarrow r \mod m \neq O]. +apply (nat_case1 (n1 \mod m)).intro. +generalize in match (H (n1 / m) m). +elim (p_ord_aux n (n1 / m) m). +apply H5.assumption. +apply eq_mod_O_to_lt_O_div. +apply (trans_lt ? (S O)).unfold lt.apply le_n. +assumption.assumption.assumption. +apply le_S_S_to_le. +apply (trans_le ? n1).change with (n1 / m < n1). +apply lt_div_n_m_n.assumption.assumption.assumption. +intros. +change with (n1 \mod m \neq O). +rewrite > H4. +unfold Not.intro. +apply (not_eq_O_S m1). +rewrite > H5.reflexivity. +qed. + +theorem p_ord_aux_to_not_mod_O: \forall p,n,m,q,r. (S O) < m \to O < n \to n \le p \to + pair nat nat q r = p_ord_aux p n m \to r \mod m \neq O. +intros. +change with + match (pair nat nat q r) with + [ (pair q r) \Rightarrow r \mod m \neq O]. +rewrite > H3. +apply p_ord_aux_to_Prop1. +assumption.assumption.assumption. +qed. + diff --git a/helm/software/matita/library/nat/orders.ma b/helm/software/matita/library/nat/orders.ma new file mode 100644 index 000000000..6ec0c9992 --- /dev/null +++ b/helm/software/matita/library/nat/orders.ma @@ -0,0 +1,312 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/orders". + +include "nat/nat.ma". +include "higher_order_defs/ordering.ma". + +(* definitions *) +inductive le (n:nat) : nat \to Prop \def + | le_n : le n n + | le_S : \forall m:nat. le n m \to le n (S m). + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural 'less or equal to'" 'leq x y = (cic:/matita/nat/orders/le.ind#xpointer(1/1) x y). +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural 'neither less nor equal to'" 'nleq x y = + (cic:/matita/logic/connectives/Not.con + (cic:/matita/nat/orders/le.ind#xpointer(1/1) x y)). + +definition lt: nat \to nat \to Prop \def +\lambda n,m:nat.(S n) \leq m. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural 'less than'" 'lt x y = (cic:/matita/nat/orders/lt.con x y). +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural 'not less than'" 'nless x y = + (cic:/matita/logic/connectives/Not.con (cic:/matita/nat/orders/lt.con x y)). + +definition ge: nat \to nat \to Prop \def +\lambda n,m:nat.m \leq n. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural 'greater or equal to'" 'geq x y = (cic:/matita/nat/orders/ge.con x y). + +definition gt: nat \to nat \to Prop \def +\lambda n,m:nat.m H7. +apply H. +apply le_to_or_lt_eq.apply H6. +qed. diff --git a/helm/software/matita/library/nat/permutation.ma b/helm/software/matita/library/nat/permutation.ma new file mode 100644 index 000000000..d71f4fd27 --- /dev/null +++ b/helm/software/matita/library/nat/permutation.ma @@ -0,0 +1,738 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/permutation". + +include "nat/compare.ma". +include "nat/sigma_and_pi.ma". + +definition injn: (nat \to nat) \to nat \to Prop \def +\lambda f:nat \to nat.\lambda n:nat.\forall i,j:nat. +i \le n \to j \le n \to f i = f j \to i = j. + +theorem injn_Sn_n: \forall f:nat \to nat. \forall n:nat. +injn f (S n) \to injn f n.unfold injn. +intros.apply H. +apply le_S.assumption. +apply le_S.assumption. +assumption. +qed. + +theorem injective_to_injn: \forall f:nat \to nat. \forall n:nat. +injective nat nat f \to injn f n. +unfold injective.unfold injn.intros.apply H.assumption. +qed. + +definition permut : (nat \to nat) \to nat \to Prop +\def \lambda f:nat \to nat. \lambda m:nat. +(\forall i:nat. i \le m \to f i \le m )\land injn f m. + +theorem permut_O_to_eq_O: \forall h:nat \to nat. +permut h O \to (h O) = O. +intros.unfold permut in H. +elim H.apply sym_eq.apply le_n_O_to_eq. +apply H1.apply le_n. +qed. + +theorem permut_S_to_permut: \forall f:nat \to nat. \forall m:nat. +permut f (S m) \to f (S m) = (S m) \to permut f m. +unfold permut.intros. +elim H. +split.intros. +cut (f i < S m \lor f i = S m). +elim Hcut. +apply le_S_S_to_le.assumption. +apply False_ind. +apply (not_le_Sn_n m). +cut ((S m) = i). +rewrite > Hcut1.assumption. +apply H3.apply le_n.apply le_S.assumption. +rewrite > H5.assumption. +apply le_to_or_lt_eq.apply H2.apply le_S.assumption. +apply (injn_Sn_n f m H3). +qed. + +(* transpositions *) + +definition transpose : nat \to nat \to nat \to nat \def +\lambda i,j,n:nat. +match eqb n i with + [ true \Rightarrow j + | false \Rightarrow + match eqb n j with + [ true \Rightarrow i + | false \Rightarrow n]]. + +lemma transpose_i_j_i: \forall i,j:nat. transpose i j i = j. +intros.unfold transpose. +rewrite > (eqb_n_n i).simplify. reflexivity. +qed. + +lemma transpose_i_j_j: \forall i,j:nat. transpose i j j = i. +intros.unfold transpose. +apply (eqb_elim j i).simplify.intro.assumption. +rewrite > (eqb_n_n j).simplify. +intros. reflexivity. +qed. + +theorem transpose_i_i: \forall i,n:nat. (transpose i i n) = n. +intros.unfold transpose. +apply (eqb_elim n i). +intro.simplify.apply sym_eq. assumption. +intro.simplify.reflexivity. +qed. + +theorem transpose_i_j_j_i: \forall i,j,n:nat. +transpose i j n = transpose j i n. +intros.unfold transpose. +apply (eqb_elim n i). +apply (eqb_elim n j). +intros. simplify.rewrite < H. rewrite < H1. +reflexivity. +intros.simplify.reflexivity. +apply (eqb_elim n j). +intros.simplify.reflexivity. +intros.simplify.reflexivity. +qed. + +theorem transpose_transpose: \forall i,j,n:nat. +(transpose i j (transpose i j n)) = n. +intros.unfold transpose. unfold transpose. +apply (eqb_elim n i).simplify. +intro. +apply (eqb_elim j i). +simplify.intros.rewrite > H. rewrite > H1.reflexivity. +rewrite > (eqb_n_n j).simplify.intros. +apply sym_eq. +assumption. +apply (eqb_elim n j).simplify. +rewrite > (eqb_n_n i).intros.simplify. +apply sym_eq. assumption. +simplify.intros. +rewrite > (not_eq_to_eqb_false n i H1). +rewrite > (not_eq_to_eqb_false n j H). +simplify.reflexivity. +qed. + +theorem injective_transpose : \forall i,j:nat. +injective nat nat (transpose i j). +unfold injective. +intros. +rewrite < (transpose_transpose i j x). +rewrite < (transpose_transpose i j y). +apply eq_f.assumption. +qed. + +variant inj_transpose: \forall i,j,n,m:nat. +transpose i j n = transpose i j m \to n = m \def +injective_transpose. + +theorem permut_transpose: \forall i,j,n:nat. i \le n \to j \le n \to +permut (transpose i j) n. +unfold permut.intros. +split.unfold transpose. +intros. +elim (eqb i1 i).simplify.assumption. +elim (eqb i1 j).simplify.assumption. +simplify.assumption. +apply (injective_to_injn (transpose i j) n). +apply injective_transpose. +qed. + +theorem permut_fg: \forall f,g:nat \to nat. \forall n:nat. +permut f n \to permut g n \to permut (\lambda m.(f(g m))) n. +unfold permut. intros. +elim H.elim H1. +split.intros.simplify.apply H2. +apply H4.assumption. +simplify.intros. +apply H5.assumption.assumption. +apply H3.apply H4.assumption.apply H4.assumption. +assumption. +qed. + +theorem permut_transpose_l: +\forall f:nat \to nat. \forall m,i,j:nat. +i \le m \to j \le m \to permut f m \to permut (\lambda n.transpose i j (f n)) m. +intros.apply (permut_fg (transpose i j) f m ? ?). +apply permut_transpose.assumption.assumption. +assumption. +qed. + +theorem permut_transpose_r: +\forall f:nat \to nat. \forall m,i,j:nat. +i \le m \to j \le m \to permut f m \to permut (\lambda n.f (transpose i j n)) m. +intros.apply (permut_fg f (transpose i j) m ? ?). +assumption.apply permut_transpose.assumption.assumption. +qed. + +theorem eq_transpose : \forall i,j,k,n:nat. \lnot j=i \to + \lnot i=k \to \lnot j=k \to +transpose i j n = transpose i k (transpose k j (transpose i k n)). +(* uffa: triplo unfold? *) +intros.unfold transpose.unfold transpose.unfold transpose. +apply (eqb_elim n i).intro. +simplify.rewrite > (eqb_n_n k). +simplify.rewrite > (not_eq_to_eqb_false j i H). +rewrite > (not_eq_to_eqb_false j k H2). +reflexivity. +intro.apply (eqb_elim n j). +intro. +cut (\lnot n = k). +cut (\lnot n = i). +rewrite > (not_eq_to_eqb_false n k Hcut). +simplify. +rewrite > (not_eq_to_eqb_false n k Hcut). +rewrite > (eq_to_eqb_true n j H4). +simplify. +rewrite > (not_eq_to_eqb_false k i). +rewrite > (eqb_n_n k). +simplify.reflexivity. +unfold Not.intro.apply H1.apply sym_eq.assumption. +assumption. +unfold Not.intro.apply H2.apply (trans_eq ? ? n). +apply sym_eq.assumption.assumption. +intro.apply (eqb_elim n k).intro. +simplify. +rewrite > (not_eq_to_eqb_false i k H1). +rewrite > (not_eq_to_eqb_false i j). +simplify. +rewrite > (eqb_n_n i). +simplify.assumption. +unfold Not.intro.apply H.apply sym_eq.assumption. +intro.simplify. +rewrite > (not_eq_to_eqb_false n k H5). +rewrite > (not_eq_to_eqb_false n j H4). +simplify. +rewrite > (not_eq_to_eqb_false n i H3). +rewrite > (not_eq_to_eqb_false n k H5). +simplify.reflexivity. +qed. + +theorem permut_S_to_permut_transpose: \forall f:nat \to nat. +\forall m:nat. permut f (S m) \to permut (\lambda n.transpose (f (S m)) (S m) +(f n)) m. +unfold permut.intros. +elim H. +split.intros.simplify.unfold transpose. +apply (eqb_elim (f i) (f (S m))). +intro.apply False_ind. +cut (i = (S m)). +apply (not_le_Sn_n m). +rewrite < Hcut.assumption. +apply H2.apply le_S.assumption.apply le_n.assumption. +intro.simplify. +apply (eqb_elim (f i) (S m)). +intro. +cut (f (S m) \lt (S m) \lor f (S m) = (S m)). +elim Hcut.apply le_S_S_to_le.assumption. +apply False_ind.apply H4.rewrite > H6.assumption. +apply le_to_or_lt_eq.apply H1.apply le_n. +intro.simplify. +cut (f i \lt (S m) \lor f i = (S m)). +elim Hcut.apply le_S_S_to_le.assumption. +apply False_ind.apply H5.assumption. +apply le_to_or_lt_eq.apply H1.apply le_S.assumption. +unfold injn.intros. +apply H2.apply le_S.assumption.apply le_S.assumption. +apply (inj_transpose (f (S m)) (S m)). +apply H5. +qed. + +(* bounded bijectivity *) + +definition bijn : (nat \to nat) \to nat \to Prop \def +\lambda f:nat \to nat. \lambda n. \forall m:nat. m \le n \to +ex nat (\lambda p. p \le n \land f p = m). + +theorem eq_to_bijn: \forall f,g:nat\to nat. \forall n:nat. +(\forall i:nat. i \le n \to (f i) = (g i)) \to +bijn f n \to bijn g n. +intros 4.unfold bijn. +intros.elim (H1 m). +apply (ex_intro ? ? a). +rewrite < (H a).assumption. +elim H3.assumption.assumption. +qed. + +theorem bijn_Sn_n: \forall f:nat \to nat. \forall n:nat. +bijn f (S n) \to f (S n) = (S n) \to bijn f n. +unfold bijn.intros.elim (H m). +elim H3. +apply (ex_intro ? ? a).split. +cut (a < S n \lor a = S n). +elim Hcut.apply le_S_S_to_le.assumption. +apply False_ind. +apply (not_le_Sn_n n). +rewrite < H1.rewrite < H6.rewrite > H5.assumption. +apply le_to_or_lt_eq.assumption.assumption. +apply le_S.assumption. +qed. + +theorem bijn_n_Sn: \forall f:nat \to nat. \forall n:nat. +bijn f n \to f (S n) = (S n) \to bijn f (S n). +unfold bijn.intros. +cut (m < S n \lor m = S n). +elim Hcut. +elim (H m). +elim H4. +apply (ex_intro ? ? a).split. +apply le_S.assumption.assumption. +apply le_S_S_to_le.assumption. +apply (ex_intro ? ? (S n)). +split.apply le_n. +rewrite > H3.assumption. +apply le_to_or_lt_eq.assumption. +qed. + +theorem bijn_fg: \forall f,g:nat\to nat. \forall n:nat. +bijn f n \to bijn g n \to bijn (\lambda p.f(g p)) n. +unfold bijn. +intros.simplify. +elim (H m).elim H3. +elim (H1 a).elim H6. +apply (ex_intro ? ? a1). +split.assumption. +rewrite > H8.assumption. +assumption.assumption. +qed. + +theorem bijn_transpose : \forall n,i,j. i \le n \to j \le n \to +bijn (transpose i j) n. +intros.unfold bijn.unfold transpose.intros. +cut (m = i \lor \lnot m = i). +elim Hcut. +apply (ex_intro ? ? j). +split.assumption. +apply (eqb_elim j i). +intro.simplify.rewrite > H3.rewrite > H4.reflexivity. +rewrite > (eqb_n_n j).simplify. +intros. apply sym_eq.assumption. +cut (m = j \lor \lnot m = j). +elim Hcut1. +apply (ex_intro ? ? i). +split.assumption. +rewrite > (eqb_n_n i).simplify. +apply sym_eq. assumption. +apply (ex_intro ? ? m). +split.assumption. +rewrite > (not_eq_to_eqb_false m i). +rewrite > (not_eq_to_eqb_false m j). +simplify. reflexivity. +assumption. +assumption. +apply (decidable_eq_nat m j). +apply (decidable_eq_nat m i). +qed. + +theorem bijn_transpose_r: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to +bijn f n \to bijn (\lambda p.f (transpose i j p)) n. +intros. +apply (bijn_fg f ?).assumption. +apply (bijn_transpose n i j).assumption.assumption. +qed. + +theorem bijn_transpose_l: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to +bijn f n \to bijn (\lambda p.transpose i j (f p)) n. +intros. +apply (bijn_fg ? f). +apply (bijn_transpose n i j).assumption.assumption. +assumption. +qed. + +theorem permut_to_bijn: \forall n:nat.\forall f:nat\to nat. +permut f n \to bijn f n. +intro. +elim n.unfold bijn.intros. +apply (ex_intro ? ? m). +split.assumption. +apply (le_n_O_elim m ? (\lambda p. f p = p)). +assumption.unfold permut in H. +elim H.apply sym_eq. apply le_n_O_to_eq.apply H2.apply le_n. +apply (eq_to_bijn (\lambda p. +(transpose (f (S n1)) (S n1)) (transpose (f (S n1)) (S n1) (f p))) f). +intros.apply transpose_transpose. +apply (bijn_fg (transpose (f (S n1)) (S n1))). +apply bijn_transpose. +unfold permut in H1. +elim H1.apply H2.apply le_n.apply le_n. +apply bijn_n_Sn. +apply H. +apply permut_S_to_permut_transpose. +assumption.unfold transpose. +rewrite > (eqb_n_n (f (S n1))).simplify.reflexivity. +qed. + +let rec invert_permut n f m \def + match eqb m (f n) with + [true \Rightarrow n + |false \Rightarrow + match n with + [O \Rightarrow O + |(S p) \Rightarrow invert_permut p f m]]. + +theorem invert_permut_f: \forall f:nat \to nat. \forall n,m:nat. +m \le n \to injn f n\to invert_permut n f (f m) = m. +intros 4. +elim H. +apply (nat_case1 m). +intro.simplify. +rewrite > (eqb_n_n (f O)).simplify.reflexivity. +intros.simplify. +rewrite > (eqb_n_n (f (S m1))).simplify.reflexivity. +simplify. +rewrite > (not_eq_to_eqb_false (f m) (f (S n1))). +simplify.apply H2. +apply injn_Sn_n. assumption. +unfold Not.intro.absurd (m = S n1). +apply H3.apply le_S.assumption.apply le_n.assumption. +unfold Not.intro. +apply (not_le_Sn_n n1).rewrite < H5.assumption. +qed. + +theorem injective_invert_permut: \forall f:nat \to nat. \forall n:nat. +permut f n \to injn (invert_permut n f) n. +intros. +unfold injn.intros. +cut (bijn f n). +unfold bijn in Hcut. +generalize in match (Hcut i H1).intro. +generalize in match (Hcut j H2).intro. +elim H4.elim H6. +elim H5.elim H9. +rewrite < H8. +rewrite < H11. +apply eq_f. +rewrite < (invert_permut_f f n a). +rewrite < (invert_permut_f f n a1). +rewrite > H8. +rewrite > H11. +assumption.assumption. +unfold permut in H.elim H. assumption. +assumption. +unfold permut in H.elim H. assumption. +apply permut_to_bijn.assumption. +qed. + +theorem permut_invert_permut: \forall f:nat \to nat. \forall n:nat. +permut f n \to permut (invert_permut n f) n. +intros.unfold permut.split. +intros.simplify.elim n. +simplify.elim (eqb i (f O)).simplify.apply le_n.simplify.apply le_n. +simplify.elim (eqb i (f (S n1))).simplify.apply le_n. +simplify.apply le_S. assumption. +apply injective_invert_permut.assumption. +qed. + +theorem f_invert_permut: \forall f:nat \to nat. \forall n,m:nat. +m \le n \to permut f n\to f (invert_permut n f m) = m. +intros. +apply (injective_invert_permut f n H1). +unfold permut in H1.elim H1. +apply H2. +cut (permut (invert_permut n f) n).unfold permut in Hcut. +elim Hcut.apply H4.assumption. +apply permut_invert_permut.assumption.assumption. +apply invert_permut_f. +cut (permut (invert_permut n f) n).unfold permut in Hcut. +elim Hcut.apply H2.assumption. +apply permut_invert_permut.assumption. +unfold permut in H1.elim H1.assumption. +qed. + +theorem permut_n_to_eq_n: \forall h:nat \to nat.\forall n:nat. +permut h n \to (\forall m:nat. m < n \to h m = m) \to h n = n. +intros.unfold permut in H.elim H. +cut (invert_permut n h n < n \lor invert_permut n h n = n). +elim Hcut. +rewrite < (f_invert_permut h n n) in \vdash (? ? ? %). +apply eq_f. +rewrite < (f_invert_permut h n n) in \vdash (? ? % ?). +apply H1.assumption.apply le_n.assumption.apply le_n.assumption. +rewrite < H4 in \vdash (? ? % ?). +apply (f_invert_permut h).apply le_n.assumption. +apply le_to_or_lt_eq. +cut (permut (invert_permut n h) n). +unfold permut in Hcut.elim Hcut. +apply H4.apply le_n. +apply permut_invert_permut.assumption. +qed. + +theorem permut_n_to_le: \forall h:nat \to nat.\forall k,n:nat. +k \le n \to permut h n \to (\forall m:nat. m < k \to h m = m) \to +\forall j. k \le j \to j \le n \to k \le h j. +intros.unfold permut in H1.elim H1. +cut (h j < k \lor \not(h j < k)). +elim Hcut.absurd (k \le j).assumption. +apply lt_to_not_le. +cut (h j = j).rewrite < Hcut1.assumption. +apply H6.apply H5.assumption.assumption. +apply H2.assumption. +apply not_lt_to_le.assumption. +apply (decidable_lt (h j) k). +qed. + +(* applications *) + +let rec map_iter_i k (g:nat \to nat) f (i:nat) \def + match k with + [ O \Rightarrow g i + | (S k) \Rightarrow f (g (S (k+i))) (map_iter_i k g f i)]. + +theorem eq_map_iter_i: \forall g1,g2:nat \to nat. +\forall f:nat \to nat \to nat. \forall n,i:nat. +(\forall m:nat. i\le m \to m \le n+i \to g1 m = g2 m) \to +map_iter_i n g1 f i = map_iter_i n g2 f i. +intros 5.elim n.simplify.apply H.apply le_n. +apply le_n.simplify.apply eq_f2.apply H1.simplify. +apply le_S.apply le_plus_n.simplify.apply le_n. +apply H.intros.apply H1.assumption.simplify.apply le_S.assumption. +qed. + +(* map_iter examples *) + +theorem eq_map_iter_i_sigma: \forall g:nat \to nat. \forall n,m:nat. +map_iter_i n g plus m = sigma n g m. +intros.elim n.simplify.reflexivity. +simplify. +apply eq_f.assumption. +qed. + +theorem eq_map_iter_i_pi: \forall g:nat \to nat. \forall n,m:nat. +map_iter_i n g times m = pi n g m. +intros.elim n.simplify.reflexivity. +simplify. +apply eq_f.assumption. +qed. + +theorem eq_map_iter_i_fact: \forall n:nat. +map_iter_i n (\lambda m.m) times (S O) = (S n)!. +intros.elim n. +simplify.reflexivity. +change with +(((S n1)+(S O))*(map_iter_i n1 (\lambda m.m) times (S O)) = (S(S n1))*(S n1)!). +rewrite < plus_n_Sm.rewrite < plus_n_O. +apply eq_f.assumption. +qed. + +theorem eq_map_iter_i_transpose_l : \forall f:nat\to nat \to nat.associative nat f \to +symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k:nat. +map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose (k+n) (S k+n) m)) f n. +intros.apply (nat_case1 k). +intros.simplify. +change with +(f (g (S n)) (g n) = +f (g (transpose n (S n) (S n))) (g (transpose n (S n) n))). +rewrite > transpose_i_j_i. +rewrite > transpose_i_j_j. +apply H1. +intros. +change with +(f (g (S (S (m+n)))) (f (g (S (m+n))) (map_iter_i m g f n)) = +f (g (transpose (S m + n) (S (S m) + n) (S (S m)+n))) +(f (g (transpose (S m + n) (S (S m) + n) (S m+n))) +(map_iter_i m (\lambda m1. g (transpose (S m+n) (S (S m)+n) m1)) f n))). +rewrite > transpose_i_j_i. +rewrite > transpose_i_j_j. +rewrite < H. +rewrite < H. +rewrite < (H1 (g (S m + n))). +apply eq_f. +apply eq_map_iter_i. +intros.simplify.unfold transpose. +rewrite > (not_eq_to_eqb_false m1 (S m+n)). +rewrite > (not_eq_to_eqb_false m1 (S (S m)+n)). +simplify. +reflexivity. +apply (lt_to_not_eq m1 (S ((S m)+n))). +unfold lt.apply le_S_S.change with (m1 \leq S (m+n)).apply le_S.assumption. +apply (lt_to_not_eq m1 (S m+n)). +simplify.unfold lt.apply le_S_S.assumption. +qed. + +theorem eq_map_iter_i_transpose_i_Si : \forall f:nat\to nat \to nat.associative nat f \to +symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k,i:nat. n \le i \to i \le k+n \to +map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S i) m)) f n. +intros 6.elim k.cut (i=n). +rewrite > Hcut. +apply (eq_map_iter_i_transpose_l f H H1 g n O). +apply antisymmetric_le.assumption.assumption. +cut (i < S n1 + n \lor i = S n1 + n). +elim Hcut. +change with +(f (g (S (S n1)+n)) (map_iter_i (S n1) g f n) = +f (g (transpose i (S i) (S (S n1)+n))) (map_iter_i (S n1) (\lambda m. g (transpose i (S i) m)) f n)). +apply eq_f2.unfold transpose. +rewrite > (not_eq_to_eqb_false (S (S n1)+n) i). +rewrite > (not_eq_to_eqb_false (S (S n1)+n) (S i)). +simplify.reflexivity. +simplify.unfold Not.intro. +apply (lt_to_not_eq i (S n1+n)).assumption. +apply inj_S.apply sym_eq. assumption. +simplify.unfold Not.intro. +apply (lt_to_not_eq i (S (S n1+n))).simplify.unfold lt. +apply le_S_S.assumption. +apply sym_eq. assumption. +apply H2.assumption.apply le_S_S_to_le. +assumption. +rewrite > H5. +apply (eq_map_iter_i_transpose_l f H H1 g n (S n1)). +apply le_to_or_lt_eq.assumption. +qed. + +theorem eq_map_iter_i_transpose: +\forall f:nat\to nat \to nat. +associative nat f \to symmetric2 nat nat f \to \forall n,k,o:nat. +\forall g:nat \to nat. \forall i:nat. n \le i \to S (o + i) \le S k+n \to +map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S(o + i)) m)) f n. +intros 6. +apply (nat_elim1 o). +intro. +apply (nat_case m ?). +intros. +apply (eq_map_iter_i_transpose_i_Si ? H H1). +exact H3.apply le_S_S_to_le.assumption. +intros. +apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g (transpose i (S(m1 + i)) m)) f n)). +apply H2. +unfold lt. apply le_n.assumption. +apply (trans_le ? (S(S (m1+i)))). +apply le_S.apply le_n.assumption. +apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g +(transpose i (S(m1 + i)) (transpose (S(m1 + i)) (S(S(m1 + i))) m))) f n)). +apply (H2 O ? ? (S(m1+i))). +unfold lt.apply le_S_S.apply le_O_n. +apply (trans_le ? i).assumption. +change with (i \le (S m1)+i).apply le_plus_n. +exact H4. +apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g +(transpose i (S(m1 + i)) +(transpose (S(m1 + i)) (S(S(m1 + i))) +(transpose i (S(m1 + i)) m)))) f n)). +apply (H2 m1). +unfold lt. apply le_n.assumption. +apply (trans_le ? (S(S (m1+i)))). +apply le_S.apply le_n.assumption. +apply eq_map_iter_i. +intros.apply eq_f. +apply sym_eq. apply eq_transpose. +unfold Not. intro. +apply (not_le_Sn_n i). +rewrite < H7 in \vdash (? ? %). +apply le_S_S.apply le_S. +apply le_plus_n. +unfold Not. intro. +apply (not_le_Sn_n i). +rewrite > H7 in \vdash (? ? %). +apply le_S_S. +apply le_plus_n. +unfold Not. intro. +apply (not_eq_n_Sn (S m1+i)). +apply sym_eq.assumption. +qed. + +theorem eq_map_iter_i_transpose1: \forall f:nat\to nat \to nat.associative nat f \to +symmetric2 nat nat f \to \forall n,k,i,j:nat. +\forall g:nat \to nat. n \le i \to i < j \to j \le S k+n \to +map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n. +intros. +simplify in H3. +cut ((S i) < j \lor (S i) = j). +elim Hcut. +cut (j = S ((j - (S i)) + i)). +rewrite > Hcut1. +apply (eq_map_iter_i_transpose f H H1 n k (j - (S i)) g i). +assumption. +rewrite < Hcut1.assumption. +rewrite > plus_n_Sm. +apply plus_minus_m_m.apply lt_to_le.assumption. +rewrite < H5. +apply (eq_map_iter_i_transpose_i_Si f H H1 g). +simplify. +assumption.apply le_S_S_to_le. +apply (trans_le ? j).assumption.assumption. +apply le_to_or_lt_eq.assumption. +qed. + +theorem eq_map_iter_i_transpose2: \forall f:nat\to nat \to nat.associative nat f \to +symmetric2 nat nat f \to \forall n,k,i,j:nat. +\forall g:nat \to nat. n \le i \to i \le (S k+n) \to n \le j \to j \le (S k+n) \to +map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n. +intros. +apply (nat_compare_elim i j). +intro.apply (eq_map_iter_i_transpose1 f H H1 n k i j g H2 H6 H5). +intro.rewrite > H6. +apply eq_map_iter_i.intros. +rewrite > (transpose_i_i j).reflexivity. +intro. +apply (trans_eq ? ? (map_iter_i (S k) (\lambda m:nat.g (transpose j i m)) f n)). +apply (eq_map_iter_i_transpose1 f H H1 n k j i g H4 H6 H3). +apply eq_map_iter_i. +intros.apply eq_f.apply transpose_i_j_j_i. +qed. + +theorem permut_to_eq_map_iter_i:\forall f:nat\to nat \to nat.associative nat f \to +symmetric2 nat nat f \to \forall k,n:nat.\forall g,h:nat \to nat. +permut h (k+n) \to (\forall m:nat. m \lt n \to h m = m) \to +map_iter_i k g f n = map_iter_i k (\lambda m.g(h m)) f n. +intros 4.elim k. +simplify.rewrite > (permut_n_to_eq_n h).reflexivity.assumption.assumption. +apply (trans_eq ? ? (map_iter_i (S n) (\lambda m.g ((transpose (h (S n+n1)) (S n+n1)) m)) f n1)). +unfold permut in H3. +elim H3. +apply (eq_map_iter_i_transpose2 f H H1 n1 n ? ? g). +apply (permut_n_to_le h n1 (S n+n1)). +apply le_plus_n.assumption.assumption.apply le_plus_n.apply le_n. +apply H5.apply le_n.apply le_plus_n.apply le_n. +apply (trans_eq ? ? (map_iter_i (S n) (\lambda m. +(g(transpose (h (S n+n1)) (S n+n1) +(transpose (h (S n+n1)) (S n+n1) (h m)))) )f n1)). +change with +(f (g (transpose (h (S n+n1)) (S n+n1) (S n+n1))) +(map_iter_i n (\lambda m. +g (transpose (h (S n+n1)) (S n+n1) m)) f n1) += +f +(g(transpose (h (S n+n1)) (S n+n1) +(transpose (h (S n+n1)) (S n+n1) (h (S n+n1))))) +(map_iter_i n +(\lambda m. +(g(transpose (h (S n+n1)) (S n+n1) +(transpose (h (S n+n1)) (S n+n1) (h m))))) f n1)). +apply eq_f2.apply eq_f. +rewrite > transpose_i_j_j. +rewrite > transpose_i_j_i. +rewrite > transpose_i_j_j.reflexivity. +apply (H2 n1 (\lambda m.(g(transpose (h (S n+n1)) (S n+n1) m)))). +apply permut_S_to_permut_transpose. +assumption. +intros. +unfold transpose. +rewrite > (not_eq_to_eqb_false (h m) (h (S n+n1))). +rewrite > (not_eq_to_eqb_false (h m) (S n+n1)). +simplify.apply H4.assumption. +rewrite > H4. +apply lt_to_not_eq.apply (trans_lt ? n1).assumption. +simplify.unfold lt.apply le_S_S.apply le_plus_n.assumption. +unfold permut in H3.elim H3. +simplify.unfold Not.intro. +apply (lt_to_not_eq m (S n+n1)).apply (trans_lt ? n1).assumption. +simplify.unfold lt.apply le_S_S.apply le_plus_n. +unfold injn in H7. +apply (H7 m (S n+n1)).apply (trans_le ? n1). +apply lt_to_le.assumption.apply le_plus_n.apply le_n. +assumption. +apply eq_map_iter_i.intros. +rewrite > transpose_transpose.reflexivity. +qed. \ No newline at end of file diff --git a/helm/software/matita/library/nat/plus.ma b/helm/software/matita/library/nat/plus.ma new file mode 100644 index 000000000..d595dad19 --- /dev/null +++ b/helm/software/matita/library/nat/plus.ma @@ -0,0 +1,72 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/plus". + +include "nat/nat.ma". + +let rec plus n m \def + match n with + [ O \Rightarrow m + | (S p) \Rightarrow S (plus p m) ]. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural plus" 'plus x y = (cic:/matita/nat/plus/plus.con x y). + +theorem plus_n_O: \forall n:nat. n = n+O. +intros.elim n. +simplify.reflexivity. +simplify.apply eq_f.assumption. +qed. + +theorem plus_n_Sm : \forall n,m:nat. S (n+m) = n+(S m). +intros.elim n. +simplify.reflexivity. +simplify.apply eq_f.assumption. +qed. + +theorem sym_plus: \forall n,m:nat. n+m = m+n. +intros.elim n. +simplify.apply plus_n_O. +simplify.rewrite > H.apply plus_n_Sm. +qed. + +theorem associative_plus : associative nat plus. +unfold associative.intros.elim x. +simplify.reflexivity. +simplify.apply eq_f.assumption. +qed. + +theorem assoc_plus : \forall n,m,p:nat. (n+m)+p = n+(m+p) +\def associative_plus. + +theorem injective_plus_r: \forall n:nat.injective nat nat (\lambda m.n+m). +intro.simplify.intros 2.elim n. +exact H. +apply H.apply inj_S.apply H1. +qed. + +theorem inj_plus_r: \forall p,n,m:nat. p+n = p+m \to n=m +\def injective_plus_r. + +theorem injective_plus_l: \forall m:nat.injective nat nat (\lambda n.n+m). +intro.simplify.intros. +apply (injective_plus_r m). +rewrite < sym_plus. +rewrite < (sym_plus y). +assumption. +qed. + +theorem inj_plus_l: \forall p,n,m:nat. n+p = m+p \to n=m +\def injective_plus_l. diff --git a/helm/software/matita/library/nat/primes.ma b/helm/software/matita/library/nat/primes.ma new file mode 100644 index 000000000..50b7d1221 --- /dev/null +++ b/helm/software/matita/library/nat/primes.ma @@ -0,0 +1,591 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/primes". + +include "nat/div_and_mod.ma". +include "nat/minimization.ma". +include "nat/sigma_and_pi.ma". +include "nat/factorial.ma". + +inductive divides (n,m:nat) : Prop \def +witness : \forall p:nat.m = times n p \to divides n m. + +interpretation "divides" 'divides n m = (cic:/matita/nat/primes/divides.ind#xpointer(1/1) n m). +interpretation "not divides" 'ndivides n m = + (cic:/matita/logic/connectives/Not.con (cic:/matita/nat/primes/divides.ind#xpointer(1/1) n m)). + +theorem reflexive_divides : reflexive nat divides. +unfold reflexive. +intros. +exact (witness x x (S O) (times_n_SO x)). +qed. + +theorem divides_to_div_mod_spec : +\forall n,m. O < n \to n \divides m \to div_mod_spec m n (m / n) O. +intros.elim H1.rewrite > H2. +constructor 1.assumption. +apply (lt_O_n_elim n H).intros. +rewrite < plus_n_O. +rewrite > div_times.apply sym_times. +qed. + +theorem div_mod_spec_to_divides : +\forall n,m,p. div_mod_spec m n p O \to n \divides m. +intros.elim H. +apply (witness n m p). +rewrite < sym_times. +rewrite > (plus_n_O (p*n)).assumption. +qed. + +theorem divides_to_mod_O: +\forall n,m. O < n \to n \divides m \to (m \mod n) = O. +intros.apply (div_mod_spec_to_eq2 m n (m / n) (m \mod n) (m / n) O). +apply div_mod_spec_div_mod.assumption. +apply divides_to_div_mod_spec.assumption.assumption. +qed. + +theorem mod_O_to_divides: +\forall n,m. O< n \to (m \mod n) = O \to n \divides m. +intros. +apply (witness n m (m / n)). +rewrite > (plus_n_O (n * (m / n))). +rewrite < H1. +rewrite < sym_times. +(* Andrea: perche' hint non lo trova ?*) +apply div_mod. +assumption. +qed. + +theorem divides_n_O: \forall n:nat. n \divides O. +intro. apply (witness n O O).apply times_n_O. +qed. + +theorem divides_n_n: \forall n:nat. n \divides n. +intro. apply (witness n n (S O)).apply times_n_SO. +qed. + +theorem divides_SO_n: \forall n:nat. (S O) \divides n. +intro. apply (witness (S O) n n). simplify.apply plus_n_O. +qed. + +theorem divides_plus: \forall n,p,q:nat. +n \divides p \to n \divides q \to n \divides p+q. +intros. +elim H.elim H1. apply (witness n (p+q) (n2+n1)). +rewrite > H2.rewrite > H3.apply sym_eq.apply distr_times_plus. +qed. + +theorem divides_minus: \forall n,p,q:nat. +divides n p \to divides n q \to divides n (p-q). +intros. +elim H.elim H1. apply (witness n (p-q) (n2-n1)). +rewrite > H2.rewrite > H3.apply sym_eq.apply distr_times_minus. +qed. + +theorem divides_times: \forall n,m,p,q:nat. +n \divides p \to m \divides q \to n*m \divides p*q. +intros. +elim H.elim H1. apply (witness (n*m) (p*q) (n2*n1)). +rewrite > H2.rewrite > H3. +apply (trans_eq nat ? (n*(m*(n2*n1)))). +apply (trans_eq nat ? (n*(n2*(m*n1)))). +apply assoc_times. +apply eq_f. +apply (trans_eq nat ? ((n2*m)*n1)). +apply sym_eq. apply assoc_times. +rewrite > (sym_times n2 m).apply assoc_times. +apply sym_eq. apply assoc_times. +qed. + +theorem transitive_divides: transitive ? divides. +unfold. +intros. +elim H.elim H1. apply (witness x z (n2*n)). +rewrite > H3.rewrite > H2. +apply assoc_times. +qed. + +variant trans_divides: \forall n,m,p. + n \divides m \to m \divides p \to n \divides p \def transitive_divides. + +theorem eq_mod_to_divides:\forall n,m,p. O< p \to +mod n p = mod m p \to divides p (n-m). +intros. +cut (n \le m \or \not n \le m). +elim Hcut. +cut (n-m=O). +rewrite > Hcut1. +apply (witness p O O). +apply times_n_O. +apply eq_minus_n_m_O. +assumption. +apply (witness p (n-m) ((div n p)-(div m p))). +rewrite > distr_times_minus. +rewrite > sym_times. +rewrite > (sym_times p). +cut ((div n p)*p = n - (mod n p)). +rewrite > Hcut1. +rewrite > eq_minus_minus_minus_plus. +rewrite > sym_plus. +rewrite > H1. +rewrite < div_mod.reflexivity. +assumption. +apply sym_eq. +apply plus_to_minus. +rewrite > sym_plus. +apply div_mod. +assumption. +apply (decidable_le n m). +qed. + +theorem antisymmetric_divides: antisymmetric nat divides. +unfold antisymmetric.intros.elim H. elim H1. +apply (nat_case1 n2).intro. +rewrite > H3.rewrite > H2.rewrite > H4. +rewrite < times_n_O.reflexivity. +intros. +apply (nat_case1 n).intro. +rewrite > H2.rewrite > H3.rewrite > H5. +rewrite < times_n_O.reflexivity. +intros. +apply antisymmetric_le. +rewrite > H2.rewrite > times_n_SO in \vdash (? % ?). +apply le_times_r.rewrite > H4.apply le_S_S.apply le_O_n. +rewrite > H3.rewrite > times_n_SO in \vdash (? % ?). +apply le_times_r.rewrite > H5.apply le_S_S.apply le_O_n. +qed. + +(* divides le *) +theorem divides_to_le : \forall n,m. O < m \to n \divides m \to n \le m. +intros. elim H1.rewrite > H2.cut (O < n2). +apply (lt_O_n_elim n2 Hcut).intro.rewrite < sym_times. +simplify.rewrite < sym_plus. +apply le_plus_n. +elim (le_to_or_lt_eq O n2). +assumption. +absurd (O H2.rewrite < H3.rewrite < times_n_O. +apply (not_le_Sn_n O). +apply le_O_n. +qed. + +theorem divides_to_lt_O : \forall n,m. O < m \to n \divides m \to O < n. +intros.elim H1. +elim (le_to_or_lt_eq O n (le_O_n n)). +assumption. +rewrite < H3.absurd (O < m).assumption. +rewrite > H2.rewrite < H3. +simplify.exact (not_le_Sn_n O). +qed. + +(* boolean divides *) +definition divides_b : nat \to nat \to bool \def +\lambda n,m :nat. (eqb (m \mod n) O). + +theorem divides_b_to_Prop : +\forall n,m:nat. O < n \to +match divides_b n m with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m]. +intros. +change with +match eqb (m \mod n) O with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m]. +apply eqb_elim. +intro.simplify.apply mod_O_to_divides.assumption.assumption. +intro.simplify.unfold Not.intro.apply H1.apply divides_to_mod_O.assumption.assumption. +qed. + +theorem divides_b_true_to_divides : +\forall n,m:nat. O < n \to +(divides_b n m = true ) \to n \divides m. +intros. +change with +match true with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m]. +rewrite < H1.apply divides_b_to_Prop. +assumption. +qed. + +theorem divides_b_false_to_not_divides : +\forall n,m:nat. O < n \to +(divides_b n m = false ) \to n \ndivides m. +intros. +change with +match false with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m]. +rewrite < H1.apply divides_b_to_Prop. +assumption. +qed. + +theorem decidable_divides: \forall n,m:nat.O < n \to +decidable (n \divides m). +intros.change with ((n \divides m) \lor n \ndivides m). +cut +(match divides_b n m with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m] \to n \divides m \lor n \ndivides m). +apply Hcut.apply divides_b_to_Prop.assumption. +elim (divides_b n m).left.apply H1.right.apply H1. +qed. + +theorem divides_to_divides_b_true : \forall n,m:nat. O < n \to +n \divides m \to divides_b n m = true. +intros. +cut (match (divides_b n m) with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m] \to ((divides_b n m) = true)). +apply Hcut.apply divides_b_to_Prop.assumption. +elim (divides_b n m).reflexivity. +absurd (n \divides m).assumption.assumption. +qed. + +theorem not_divides_to_divides_b_false: \forall n,m:nat. O < n \to +\lnot(n \divides m) \to (divides_b n m) = false. +intros. +cut (match (divides_b n m) with +[ true \Rightarrow n \divides m +| false \Rightarrow n \ndivides m] \to ((divides_b n m) = false)). +apply Hcut.apply divides_b_to_Prop.assumption. +elim (divides_b n m). +absurd (n \divides m).assumption.assumption. +reflexivity. +qed. + +(* divides and pi *) +theorem divides_f_pi_f : \forall f:nat \to nat.\forall n,m,i:nat. +m \le i \to i \le n+m \to f i \divides pi n f m. +intros 5.elim n.simplify. +cut (i = m).rewrite < Hcut.apply divides_n_n. +apply antisymmetric_le.assumption.assumption. +simplify. +cut (i < S n1+m \lor i = S n1 + m). +elim Hcut. +apply (transitive_divides ? (pi n1 f m)). +apply H1.apply le_S_S_to_le. assumption. +apply (witness ? ? (f (S n1+m))).apply sym_times. +rewrite > H3. +apply (witness ? ? (pi n1 f m)).reflexivity. +apply le_to_or_lt_eq.assumption. +qed. + +(* +theorem mod_S_pi: \forall f:nat \to nat.\forall n,i:nat. +i < n \to (S O) < (f i) \to (S (pi n f)) \mod (f i) = (S O). +intros.cut (pi n f) \mod (f i) = O. +rewrite < Hcut. +apply mod_S.apply trans_lt O (S O).apply le_n (S O).assumption. +rewrite > Hcut.assumption. +apply divides_to_mod_O.apply trans_lt O (S O).apply le_n (S O).assumption. +apply divides_f_pi_f.assumption. +qed. +*) + +(* divides and fact *) +theorem divides_fact : \forall n,i:nat. +O < i \to i \le n \to i \divides n!. +intros 3.elim n.absurd (O H3. +apply (witness ? ? n1!).reflexivity. +qed. + +theorem mod_S_fact: \forall n,i:nat. +(S O) < i \to i \le n \to (S n!) \mod i = (S O). +intros.cut (n! \mod i = O). +rewrite < Hcut. +apply mod_S.apply (trans_lt O (S O)).apply (le_n (S O)).assumption. +rewrite > Hcut.assumption. +apply divides_to_mod_O.apply (trans_lt O (S O)).apply (le_n (S O)).assumption. +apply divides_fact.apply (trans_lt O (S O)).apply (le_n (S O)).assumption. +assumption. +qed. + +theorem not_divides_S_fact: \forall n,i:nat. +(S O) < i \to i \le n \to i \ndivides S n!. +intros. +apply divides_b_false_to_not_divides. +apply (trans_lt O (S O)).apply (le_n (S O)).assumption. +change with ((eqb ((S n!) \mod i) O) = false). +rewrite > mod_S_fact.simplify.reflexivity. +assumption.assumption. +qed. + +(* prime *) +definition prime : nat \to Prop \def +\lambda n:nat. (S O) < n \land +(\forall m:nat. m \divides n \to (S O) < m \to m = n). + +theorem not_prime_O: \lnot (prime O). +unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_O (S O) H1). +qed. + +theorem not_prime_SO: \lnot (prime (S O)). +unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_n (S O) H1). +qed. + +(* smallest factor *) +definition smallest_factor : nat \to nat \def +\lambda n:nat. +match n with +[ O \Rightarrow O +| (S p) \Rightarrow + match p with + [ O \Rightarrow (S O) + | (S q) \Rightarrow min_aux q (S(S q)) (\lambda m.(eqb ((S(S q)) \mod m) O))]]. + +(* it works ! +theorem example1 : smallest_prime_factor (S(S(S O))) = (S(S(S O))). +normalize.reflexivity. +qed. + +theorem example2: smallest_prime_factor (S(S(S(S O)))) = (S(S O)). +normalize.reflexivity. +qed. + +theorem example3 : smallest_prime_factor (S(S(S(S(S(S(S O))))))) = (S(S(S(S(S(S(S O))))))). +simplify.reflexivity. +qed. *) + +theorem lt_SO_smallest_factor: +\forall n:nat. (S O) < n \to (S O) < (smallest_factor n). +intro. +apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S O) H). +intro.apply (nat_case m).intro. apply False_ind.apply (not_le_Sn_n (S O) H). +intros. +change with +(S O < min_aux m1 (S(S m1)) (\lambda m.(eqb ((S(S m1)) \mod m) O))). +apply (lt_to_le_to_lt ? (S (S O))). +apply (le_n (S(S O))). +cut ((S(S O)) = (S(S m1)) - m1). +rewrite > Hcut. +apply le_min_aux. +apply sym_eq.apply plus_to_minus. +rewrite < sym_plus.simplify.reflexivity. +qed. + +theorem lt_O_smallest_factor: \forall n:nat. O < n \to O < (smallest_factor n). +intro. +apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_n O H). +intro.apply (nat_case m).intro. +simplify.unfold lt.apply le_n. +intros.apply (trans_lt ? (S O)). +unfold lt.apply le_n. +apply lt_SO_smallest_factor.unfold lt. apply le_S_S. +apply le_S_S.apply le_O_n. +qed. + +theorem divides_smallest_factor_n : +\forall n:nat. O < n \to smallest_factor n \divides n. +intro. +apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O O H). +intro.apply (nat_case m).intro. simplify. +apply (witness ? ? (S O)). simplify.reflexivity. +intros. +apply divides_b_true_to_divides. +apply (lt_O_smallest_factor ? H). +change with +(eqb ((S(S m1)) \mod (min_aux m1 (S(S m1)) + (\lambda m.(eqb ((S(S m1)) \mod m) O)))) O = true). +apply f_min_aux_true. +apply (ex_intro nat ? (S(S m1))). +split.split. +apply le_minus_m.apply le_n. +rewrite > mod_n_n.reflexivity. +apply (trans_lt ? (S O)).apply (le_n (S O)).unfold lt. +apply le_S_S.apply le_S_S.apply le_O_n. +qed. + +theorem le_smallest_factor_n : +\forall n:nat. smallest_factor n \le n. +intro.apply (nat_case n).simplify.reflexivity. +intro.apply (nat_case m).simplify.reflexivity. +intro.apply divides_to_le. +unfold lt.apply le_S_S.apply le_O_n. +apply divides_smallest_factor_n. +unfold lt.apply le_S_S.apply le_O_n. +qed. + +theorem lt_smallest_factor_to_not_divides: \forall n,i:nat. +(S O) < n \to (S O) < i \to i < (smallest_factor n) \to i \ndivides n. +intros 2. +apply (nat_case n).intro.apply False_ind.apply (not_le_Sn_O (S O) H). +intro.apply (nat_case m).intro. apply False_ind.apply (not_le_Sn_n (S O) H). +intros. +apply divides_b_false_to_not_divides. +apply (trans_lt O (S O)).apply (le_n (S O)).assumption. +change with ((eqb ((S(S m1)) \mod i) O) = false). +apply (lt_min_aux_to_false +(\lambda i:nat.eqb ((S(S m1)) \mod i) O) (S(S m1)) m1 i). +cut ((S(S O)) = (S(S m1)-m1)). +rewrite < Hcut.exact H1. +apply sym_eq. apply plus_to_minus. +rewrite < sym_plus.simplify.reflexivity. +exact H2. +qed. + +theorem prime_smallest_factor_n : +\forall n:nat. (S O) < n \to prime (smallest_factor n). +intro. change with ((S(S O)) \le n \to (S O) < (smallest_factor n) \land +(\forall m:nat. m \divides smallest_factor n \to (S O) < m \to m = (smallest_factor n))). +intro.split. +apply lt_SO_smallest_factor.assumption. +intros. +cut (le m (smallest_factor n)). +elim (le_to_or_lt_eq m (smallest_factor n) Hcut). +absurd (m \divides n). +apply (transitive_divides m (smallest_factor n)). +assumption. +apply divides_smallest_factor_n. +apply (trans_lt ? (S O)). unfold lt. apply le_n. exact H. +apply lt_smallest_factor_to_not_divides. +exact H.assumption.assumption.assumption. +apply divides_to_le. +apply (trans_lt O (S O)). +apply (le_n (S O)). +apply lt_SO_smallest_factor. +exact H. +assumption. +qed. + +theorem prime_to_smallest_factor: \forall n. prime n \to +smallest_factor n = n. +intro.apply (nat_case n).intro.apply False_ind.apply (not_prime_O H). +intro.apply (nat_case m).intro.apply False_ind.apply (not_prime_SO H). +intro. +change with +((S O) < (S(S m1)) \land +(\forall m:nat. m \divides S(S m1) \to (S O) < m \to m = (S(S m1))) \to +smallest_factor (S(S m1)) = (S(S m1))). +intro.elim H.apply H2. +apply divides_smallest_factor_n. +apply (trans_lt ? (S O)).unfold lt. apply le_n.assumption. +apply lt_SO_smallest_factor. +assumption. +qed. + +(* a number n > O is prime iff its smallest factor is n *) +definition primeb \def \lambda n:nat. +match n with +[ O \Rightarrow false +| (S p) \Rightarrow + match p with + [ O \Rightarrow false + | (S q) \Rightarrow eqb (smallest_factor (S(S q))) (S(S q))]]. + +(* it works! +theorem example4 : primeb (S(S(S O))) = true. +normalize.reflexivity. +qed. + +theorem example5 : primeb (S(S(S(S(S(S O)))))) = false. +normalize.reflexivity. +qed. + +theorem example6 : primeb (S(S(S(S((S(S(S(S(S(S(S O)))))))))))) = true. +normalize.reflexivity. +qed. + +theorem example7 : primeb (S(S(S(S(S(S((S(S(S(S((S(S(S(S(S(S(S O))))))))))))))))))) = true. +normalize.reflexivity. +qed. *) + +theorem primeb_to_Prop: \forall n. +match primeb n with +[ true \Rightarrow prime n +| false \Rightarrow \lnot (prime n)]. +intro. +apply (nat_case n).simplify.unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_O (S O) H1). +intro.apply (nat_case m).simplify.unfold Not.unfold prime.intro.elim H.apply (not_le_Sn_n (S O) H1). +intro. +change with +match eqb (smallest_factor (S(S m1))) (S(S m1)) with +[ true \Rightarrow prime (S(S m1)) +| false \Rightarrow \lnot (prime (S(S m1)))]. +apply (eqb_elim (smallest_factor (S(S m1))) (S(S m1))). +intro.change with (prime (S(S m1))). +rewrite < H. +apply prime_smallest_factor_n. +unfold lt.apply le_S_S.apply le_S_S.apply le_O_n. +intro.change with (\lnot (prime (S(S m1)))). +change with (prime (S(S m1)) \to False). +intro.apply H. +apply prime_to_smallest_factor. +assumption. +qed. + +theorem primeb_true_to_prime : \forall n:nat. +primeb n = true \to prime n. +intros.change with +match true with +[ true \Rightarrow prime n +| false \Rightarrow \lnot (prime n)]. +rewrite < H. +apply primeb_to_Prop. +qed. + +theorem primeb_false_to_not_prime : \forall n:nat. +primeb n = false \to \lnot (prime n). +intros.change with +match false with +[ true \Rightarrow prime n +| false \Rightarrow \lnot (prime n)]. +rewrite < H. +apply primeb_to_Prop. +qed. + +theorem decidable_prime : \forall n:nat.decidable (prime n). +intro.change with ((prime n) \lor \lnot (prime n)). +cut +(match primeb n with +[ true \Rightarrow prime n +| false \Rightarrow \lnot (prime n)] \to (prime n) \lor \lnot (prime n)). +apply Hcut.apply primeb_to_Prop. +elim (primeb n).left.apply H.right.apply H. +qed. + +theorem prime_to_primeb_true: \forall n:nat. +prime n \to primeb n = true. +intros. +cut (match (primeb n) with +[ true \Rightarrow prime n +| false \Rightarrow \lnot (prime n)] \to ((primeb n) = true)). +apply Hcut.apply primeb_to_Prop. +elim (primeb n).reflexivity. +absurd (prime n).assumption.assumption. +qed. + +theorem not_prime_to_primeb_false: \forall n:nat. +\lnot(prime n) \to primeb n = false. +intros. +cut (match (primeb n) with +[ true \Rightarrow prime n +| false \Rightarrow \lnot (prime n)] \to ((primeb n) = false)). +apply Hcut.apply primeb_to_Prop. +elim (primeb n). +absurd (prime n).assumption.assumption. +reflexivity. +qed. + diff --git a/helm/software/matita/library/nat/primes1.ma b/helm/software/matita/library/nat/primes1.ma new file mode 100644 index 000000000..3ec61ee4a --- /dev/null +++ b/helm/software/matita/library/nat/primes1.ma @@ -0,0 +1,38 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/primes1". + +include "datatypes/constructors.ma". +include "nat/primes.ma". + +(* p is just an upper bound, acc is an accumulator *) +let rec n_divides_aux p n m acc \def + match n \mod m with + [ O \Rightarrow + match p with + [ O \Rightarrow pair nat nat acc n + | (S p) \Rightarrow n_divides_aux p (n / m) m (S acc)] + | (S a) \Rightarrow pair nat nat acc n]. + +(* n_divides n m = if m divides n q times, with remainder r *) +definition n_divides \def \lambda n,m:nat.n_divides_aux n n m O. + +(* +theorem n_divides_to_Prop: \forall n,m,p,a. + match n_divides_aux p n m a with + [ (pair q r) \Rightarrow n = m \sup a *r]. +intros. +apply nat_case (n \mod m). *) + diff --git a/helm/software/matita/library/nat/relevant_equations.ma b/helm/software/matita/library/nat/relevant_equations.ma new file mode 100644 index 000000000..f4cf43775 --- /dev/null +++ b/helm/software/matita/library/nat/relevant_equations.ma @@ -0,0 +1,50 @@ +(**************************************************************************) +(* __ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/relevant_equations.ma". + +include "nat/times.ma". +include "nat/minus.ma". + +theorem times_plus_l: \forall n,m,p:nat. (n+m)*p = n*p + m*p. +intros. +apply (trans_eq ? ? (p*(n+m))). +apply sym_times. +apply (trans_eq ? ? (p*n+p*m)). +apply distr_times_plus. +apply eq_f2. +apply sym_times. +apply sym_times. +qed. + +theorem times_minus_l: \forall n,m,p:nat. (n-m)*p = n*p - m*p. +intros. +apply (trans_eq ? ? (p*(n-m))). +apply sym_times. +apply (trans_eq ? ? (p*n-p*m)). +apply distr_times_minus. +apply eq_f2. +apply sym_times. +apply sym_times. +qed. + +theorem times_plus_plus: \forall n,m,p,q:nat. (n + m)*(p + q) = +n*p + n*q + m*p + m*q. +intros. +apply (trans_eq nat ? ((n*(p+q) + m*(p+q)))). +apply times_plus_l. +rewrite > distr_times_plus. +rewrite > distr_times_plus. +rewrite < assoc_plus.reflexivity. +qed. diff --git a/helm/software/matita/library/nat/sigma_and_pi.ma b/helm/software/matita/library/nat/sigma_and_pi.ma new file mode 100644 index 000000000..4f5f6cba0 --- /dev/null +++ b/helm/software/matita/library/nat/sigma_and_pi.ma @@ -0,0 +1,79 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / Matita is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/sigma_and_pi". + +include "nat/factorial.ma". +include "nat/lt_arith.ma". +include "nat/exp.ma". + +let rec sigma n f m \def + match n with + [ O \Rightarrow (f m) + | (S p) \Rightarrow (f (S p+m))+(sigma p f m)]. + +let rec pi n f m \def + match n with + [ O \Rightarrow f m + | (S p) \Rightarrow (f (S p+m))*(pi p f m)]. + +theorem eq_sigma: \forall f,g:nat \to nat. +\forall n,m:nat. +(\forall i:nat. m \le i \to i \le m+n \to f i = g i) \to +(sigma n f m) = (sigma n g m). +intros 3.elim n. +simplify.apply H.apply le_n.rewrite < plus_n_O.apply le_n. +simplify. +apply eq_f2.apply H1. +change with (m \le (S n1)+m).apply le_plus_n. +rewrite > (sym_plus m).apply le_n. +apply H.intros.apply H1.assumption. +rewrite < plus_n_Sm. +apply le_S.assumption. +qed. + +theorem eq_pi: \forall f,g:nat \to nat. +\forall n,m:nat. +(\forall i:nat. m \le i \to i \le m+n \to f i = g i) \to +(pi n f m) = (pi n g m). +intros 3.elim n. +simplify.apply H.apply le_n.rewrite < plus_n_O.apply le_n. +simplify. +apply eq_f2.apply H1. +change with (m \le (S n1)+m).apply le_plus_n. +rewrite > (sym_plus m).apply le_n. +apply H.intros.apply H1.assumption. +rewrite < plus_n_Sm. +apply le_S.assumption. +qed. + +theorem eq_fact_pi: \forall n. (S n)! = pi n (\lambda m.m) (S O). +intro.elim n. +simplify.reflexivity. +change with ((S(S n1))*(S n1)! = ((S n1)+(S O))*(pi n1 (\lambda m.m) (S O))). +rewrite < plus_n_Sm.rewrite < plus_n_O. +apply eq_f.assumption. +qed. + +theorem exp_pi_l: \forall f:nat\to nat.\forall n,m,a:nat. +(exp a (S n))*pi n f m= pi n (\lambda p.a*(f p)) m. +intros.elim n.simplify.rewrite < times_n_SO.reflexivity. +simplify. +rewrite < H. +rewrite > assoc_times. +rewrite > assoc_times in\vdash (? ? ? %). +apply eq_f.rewrite < assoc_times. +rewrite < assoc_times. +apply eq_f2.apply sym_times.reflexivity. +qed. diff --git a/helm/software/matita/library/nat/times.ma b/helm/software/matita/library/nat/times.ma new file mode 100644 index 000000000..2ae5ffd74 --- /dev/null +++ b/helm/software/matita/library/nat/times.ma @@ -0,0 +1,87 @@ +(**************************************************************************) +(* __ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/times". + +include "nat/plus.ma". + +let rec times n m \def + match n with + [ O \Rightarrow O + | (S p) \Rightarrow m+(times p m) ]. + +(*CSC: the URI must disappear: there is a bug now *) +interpretation "natural times" 'times x y = (cic:/matita/nat/times/times.con x y). + +theorem times_n_O: \forall n:nat. O = n*O. +intros.elim n. +simplify.reflexivity. +simplify.assumption. +qed. + +theorem times_n_Sm : +\forall n,m:nat. n+(n*m) = n*(S m). +intros.elim n. +simplify.reflexivity. +simplify.apply eq_f.rewrite < H. +transitivity ((n1+m)+n1*m).symmetry.apply assoc_plus. +transitivity ((m+n1)+n1*m). +apply eq_f2. +apply sym_plus. +reflexivity. +apply assoc_plus. +qed. + +theorem times_n_SO : \forall n:nat. n = n * S O. +intros. +rewrite < times_n_Sm. +rewrite < times_n_O. +rewrite < plus_n_O. +reflexivity. +qed. + +theorem symmetric_times : symmetric nat times. +unfold symmetric. +intros.elim x. +simplify.apply times_n_O. +simplify.rewrite > H.apply times_n_Sm. +qed. + +variant sym_times : \forall n,m:nat. n*m = m*n \def +symmetric_times. + +theorem distributive_times_plus : distributive nat times plus. +unfold distributive. +intros.elim x. +simplify.reflexivity. +simplify.rewrite > H. rewrite > assoc_plus.rewrite > assoc_plus. +apply eq_f.rewrite < assoc_plus. rewrite < (sym_plus ? z). +rewrite > assoc_plus.reflexivity. +qed. + +variant distr_times_plus: \forall n,m,p:nat. n*(m+p) = n*m + n*p +\def distributive_times_plus. + +theorem associative_times: associative nat times. +unfold associative.intros. +elim x.simplify.apply refl_eq. +simplify.rewrite < sym_times. +rewrite > distr_times_plus. +rewrite < sym_times. +rewrite < (sym_times (times n y) z). +rewrite < H.apply refl_eq. +qed. + +variant assoc_times: \forall n,m,p:nat. (n*m)*p = n*(m*p) \def +associative_times. diff --git a/helm/software/matita/library/nat/totient.ma b/helm/software/matita/library/nat/totient.ma new file mode 100644 index 000000000..24c3920ed --- /dev/null +++ b/helm/software/matita/library/nat/totient.ma @@ -0,0 +1,102 @@ +(**************************************************************************) +(* __ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| A.Asperti, C.Sacerdoti Coen, *) +(* ||A|| E.Tassi, S.Zacchiroli *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU Lesser General Public License Version 2.1 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/nat/totient". + +include "nat/count.ma". +include "nat/chinese_reminder.ma". + +definition totient : nat \to nat \def +\lambda n. count n (\lambda m. eqb (gcd m n) (S O)). + +theorem totient3: totient (S(S(S O))) = (S(S O)). +reflexivity. +qed. + +theorem totient6: totient (S(S(S(S(S(S O)))))) = (S(S O)). +reflexivity. +qed. + +theorem totient_times: \forall n,m:nat. (gcd m n) = (S O) \to +totient (n*m) = (totient n)*(totient m). +intro. +apply (nat_case n). +intro.simplify.intro.reflexivity. +intros 2.apply (nat_case m1). +rewrite < sym_times. +rewrite < (sym_times (totient O)). +simplify.intro.reflexivity. +intros. +unfold totient. +apply (count_times m m2 ? ? ? +(\lambda b,a. cr_pair (S m) (S m2) a b) (\lambda x. x \mod (S m)) (\lambda x. x \mod (S m2))). +intros.unfold cr_pair. +apply (le_to_lt_to_lt ? (pred ((S m)*(S m2)))). +unfold min. +apply le_min_aux_r. +change with ((S (pred ((S m)*(S m2)))) \le ((S m)*(S m2))). +apply (nat_case ((S m)*(S m2))).apply le_n. +intro.apply le_n. +intros. +generalize in match (mod_cr_pair (S m) (S m2) a b H1 H2 H). +intro.elim H3. +apply H4. +intros. +generalize in match (mod_cr_pair (S m) (S m2) a b H1 H2 H). +intro.elim H3. +apply H5. +intros. +generalize in match (mod_cr_pair (S m) (S m2) a b H1 H2 H). +intro.elim H3. +apply eqb_elim. +intro. +rewrite > eq_to_eqb_true. +rewrite > eq_to_eqb_true. +reflexivity. +rewrite < H4. +rewrite > sym_gcd. +rewrite > gcd_mod. +apply (gcd_times_SO_to_gcd_SO ? ? (S m2)). +unfold lt.apply le_S_S.apply le_O_n. +unfold lt.apply le_S_S.apply le_O_n. +assumption. +unfold lt.apply le_S_S.apply le_O_n. +rewrite < H5. +rewrite > sym_gcd. +rewrite > gcd_mod. +apply (gcd_times_SO_to_gcd_SO ? ? (S m)). +unfold lt.apply le_S_S.apply le_O_n. +unfold lt.apply le_S_S.apply le_O_n. +rewrite > sym_times. +assumption. +unfold lt.apply le_S_S.apply le_O_n. +intro. +apply eqb_elim. +intro.apply eqb_elim. +intro.apply False_ind. +apply H6. +apply eq_gcd_times_SO. +unfold lt.apply le_S_S.apply le_O_n. +unfold lt.apply le_S_S.apply le_O_n. +rewrite < gcd_mod. +rewrite > H4. +rewrite > sym_gcd.assumption. +unfold lt.apply le_S_S.apply le_O_n. +rewrite < gcd_mod. +rewrite > H5. +rewrite > sym_gcd.assumption. +unfold lt.apply le_S_S.apply le_O_n. +intro.reflexivity. +intro.reflexivity. +qed. \ No newline at end of file diff --git a/helm/software/matita/matita.conf.xml b/helm/software/matita/matita.conf.xml new file mode 120000 index 000000000..7f7b7b8e1 --- /dev/null +++ b/helm/software/matita/matita.conf.xml @@ -0,0 +1 @@ +matita.conf.xml.devel \ No newline at end of file diff --git a/helm/software/matita/matita.conf.xml.build.in b/helm/software/matita/matita.conf.xml.build.in new file mode 100644 index 000000000..0ee624540 --- /dev/null +++ b/helm/software/matita/matita.conf.xml.build.in @@ -0,0 +1,27 @@ + + +

    + $(HOME) +
    +
    + .matita + nobody +
    +
    + @DBHOST@ + helm + matita +
    +
    + .matita/getter/cache + + cic:/matita/ + file://.matita/xml/matita/ + + + cic:/ + file:///does_not_exists/ + legacy + +
    + diff --git a/helm/software/matita/matita.conf.xml.devel.in b/helm/software/matita/matita.conf.xml.devel.in new file mode 100644 index 000000000..3a4e7bb70 --- /dev/null +++ b/helm/software/matita/matita.conf.xml.devel.in @@ -0,0 +1,68 @@ + + +
    + + $(HOME) + + +
    +
    + + + + + $(user.home)/.matita + + $(user.name) + + +
    +
    + + @DBHOST@ + helm + matita +
    +
    + + $(user.home)/.matita/getter/cache + + + cic:/matita/ + file://$(user.home)/.matita/xml/matita/ + + + cic:/ + file:///projects/helm/library/coq_contribs/ + legacy + +
    +     diff --git a/helm/software/matita/matita.conf.xml.user.in b/helm/software/matita/matita.conf.xml.user.in new file mode 100644 index 000000000..ff4be401e --- /dev/null +++ b/helm/software/matita/matita.conf.xml.user.in @@ -0,0 +1,73 @@ + + +
    + + $(HOME) + + +
    +
    + + + + + $(user.home)/.matita + + $(user.name) + + +
    +
    + + @DBHOST@ + helm + matita +
    +
    + + $(user.home)/.matita/getter/cache + + + cic:/matita/ + file://@RT_BASE_DIR@/library/ + ro + + + cic:/matita/$(user.name)/ + file://$(user.home)/.matita/xml/matita/ + + + cic:/ + file://@RT_BASE_DIR@/legacy/coq/ + legacy + +
    +     diff --git a/helm/software/matita/matita.glade b/helm/software/matita/matita.glade new file mode 100644 index 000000000..436dd7b26 --- /dev/null +++ b/helm/software/matita/matita.glade @@ -0,0 +1,3952 @@ + + + + + + + True + Cic browser + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER_ON_PARENT + False + 500 + 500 + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + + + + True + True + False + + + + True + False + 0 + + + + True + 0 + 0 + GTK_SHADOW_NONE + + + + True + False + 0 + + + + True + True + GTK_RELIEF_NONE + True + + + + True + gtk-new + 4 + 0.5 + 0.5 + 0 + 0 + + + + + 0 + False + False + + + + + + True + True + GTK_RELIEF_NONE + True + + + + True + gtk-go-back + 4 + 0.5 + 0.5 + 0 + 0 + + + + + 0 + False + False + + + + + + True + True + GTK_RELIEF_NONE + True + + + + True + gtk-go-forward + 4 + 0.5 + 0.5 + 0 + 0 + + + + + 0 + False + False + + + + + + True + refresh + True + True + GTK_RELIEF_NONE + True + + + + True + gtk-refresh + 4 + 0.5 + 0.5 + 0 + 0 + + + + + 0 + False + False + + + + + + True + home + True + True + GTK_RELIEF_NONE + True + + + + True + gtk-home + 4 + 0.5 + 0.5 + 0 + 0 + + + + + 0 + False + False + + + + + + True + gtk-jump-to + 2 + 0.5 + 0.5 + 0 + 0 + + + 3 + False + False + + + + + + True + False + 0 + + + + + + + 0 + True + True + + + + + + + 0 + False + True + + + + + + 3 + True + False + 6 + + + + True + 0.5 + 0.5 + 0 + 0 + + + 0 + False + True + + + + + + True + True + True + True + 0 + + True + * + False + + + 0 + True + True + + + + + + True + False + 0 + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + False + False + + + + + 0 + False + True + + + + + 0 + False + True + + + + + + True + True + True + True + GTK_POS_TOP + False + False + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + + + + False + True + + + + + + True + MathView + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + False + False + False + True + False + False + False + + + + + False + True + + + + + + True + WhelpResults + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + 0.5 + 0.5 + 0 + 0 + + + False + True + + + + + + True + WhelpEasterEgg + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + 0 + True + True + + + + + + + + + + DUMMY + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER + True + False + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + True + + + + True + False + 0 + + + + True + GTK_BUTTONBOX_END + + + + True + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + -6 + + + + + + True + True + True + gtk-ok + True + GTK_RELIEF_NORMAL + True + -5 + + + + + 0 + False + True + GTK_PACK_END + + + + + + True + DUMMY + False + False + GTK_JUSTIFY_CENTER + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + True + DUMMY + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + True + + + + True + False + 0 + + + + True + GTK_BUTTONBOX_END + + + + True + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + -6 + + + + + + True + True + True + gtk-ok + True + GTK_RELIEF_NORMAL + True + -5 + + + + + 0 + False + True + GTK_PACK_END + + + + + + True + DUMMY + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + + + + 10 + Select File + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER + True + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + True + + + + True + True + True + GTK_RELIEF_NORMAL + True + + + + + + True + True + True + GTK_RELIEF_NORMAL + True + + + + + + 350 + 250 + title + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + True + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + True + + + + True + False + 0 + + + + True + GTK_BUTTONBOX_END + + + + True + True + True + gtk-help + True + GTK_RELIEF_NORMAL + True + -11 + + + + + + True + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + -6 + + + + + + True + True + True + gtk-ok + True + GTK_RELIEF_NORMAL + True + -5 + + + + + 0 + False + True + GTK_PACK_END + + + + + + True + False + 0 + + + + True + some informative message here ... + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + False + False + False + True + False + False + False + + + + + 0 + True + True + + + + + 0 + True + True + + + + + + + + Matita + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + + + + True + True + False + + + + True + False + 0 + + + + True + GTK_SHADOW_OUT + GTK_POS_LEFT + GTK_POS_TOP + + + + True + + + + True + _File + True + + + + + + + True + _New + True + + + + + True + gtk-new + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Open... + True + + + + + True + gtk-open + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Save + True + + + + + True + gtk-save + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Save _As ... + True + + + + + True + gtk-save-as + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Developments... + True + + + + + True + gtk-execute + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + + + + + + True + _Quit + True + + + + + True + gtk-quit + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + _Edit + True + + + + + + + True + False + _Undo + True + + + + + True + gtk-undo + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + False + _Redo + True + + + + + True + gtk-redo + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + + + + + + True + Cu_t + True + + + + + True + gtk-cut + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Copy + True + + + + + True + gtk-copy + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Paste + True + + + + + True + gtk-paste + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Paste as pattern + True + + + + + + True + _Delete + True + + + + True + gtk-delete + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + + + + + + True + Select _All + True + + + + + + True + + + + + + True + _Find & Replace ... + True + + + + + True + gtk-find-and-replace + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + + + + + + True + Next ligature + True + + + + + + + True + Edit with E_xternal Editor + True + + + + + + + + + + True + _Script + True + + + + + + + True + Execute 1 phrase + True + + + + + + + True + Retract 1 phrase + True + + + + + + + True + + + + + + True + Execute all + True + + + + + + + True + Restart + True + + + + + + + True + + + + + + True + Execute until cursor + True + + + + + + + + + + + True + _View + True + + + + + + + True + Show _Tactics Bar + True + True + + + + + + + True + New Cic _Browser + True + + + + + + + True + + + + + + True + _Fullscreen + True + False + + + + + + + True + + + + + + True + Zoom _In + True + + + + + + True + gtk-zoom-in + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + Zoom _Out + True + + + + + + True + gtk-zoom-out + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + True + _Normal Size + True + + + + + True + gtk-zoom-100 + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + True + _Debug + True + + + + + + + True + + + + + + + + + + True + _Help + True + + + + + + + True + _About + True + + + + True + gtk-about + 1 + 0.5 + 0.5 + 0 + 0 + + + + + + + + + + + + + 0 + False + False + + + + + + True + False + 0 + + + + True + True + + + + True + False + 0 + + + + True + GTK_SHADOW_OUT + GTK_POS_TOP + GTK_POS_TOP + + + + True + 17 + 2 + False + 4 + 0 + + + + True + Apply + True + apply + True + GTK_RELIEF_NORMAL + True + + + 1 + 2 + 0 + 1 + fill + + + + + + + True + Intros + True + intro + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + Exact + True + exact + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 2 + 3 + fill + + + + + + + True + Elim + True + elim + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 4 + 5 + fill + + + + + + + True + Reflexivity + True + refl + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 8 + 9 + fill + + + + + + + True + Symmetry + True + sym + True + GTK_RELIEF_NORMAL + True + + + 1 + 2 + 8 + 9 + fill + + + + + + + True + Transitivity + True + trans + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 9 + 10 + fill + + + + + + + True + Simplify + True + simpl + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 11 + 12 + fill + + + + + + + True + Reduce + True + red + True + GTK_RELIEF_NORMAL + True + + + 1 + 2 + 11 + 12 + fill + + + + + + + True + Whd + True + whd + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 12 + 13 + fill + + + + + + + True + Assumption + True + assum + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 14 + 15 + fill + + + + + + + True + Auto + True + auto + True + GTK_RELIEF_NORMAL + True + + + 1 + 2 + 14 + 15 + fill + + + + + + + True + Cut + True + cut + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 16 + 17 + fill + + + + + + + True + Replace + True + repl + True + GTK_RELIEF_NORMAL + True + + + 1 + 2 + 16 + 17 + fill + + + + + + + True + ElimType + True + elimTy + True + GTK_RELIEF_NORMAL + True + + + 1 + 2 + 4 + 5 + fill + + + + + + + True + True + 0 + + + + True + Right + True + R + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + + True + Exists + True + ∃ + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + 1 + 2 + 6 + 7 + fill + fill + + + + + + True + True + 0 + + + + True + Split + True + ∧ + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + + True + Left + True + L + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + 0 + 1 + 6 + 7 + fill + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 1 + 2 + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 3 + 4 + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 5 + 6 + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 7 + 8 + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 10 + 11 + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 13 + 14 + fill + + + + + + True + 0.5 + 0.5 + 1 + 1 + 0 + 0 + 0 + 0 + + + + + + + 0 + 1 + 15 + 16 + fill + + + + + + + 0 + False + True + + + + + + 400 + True + False + 0 + + + + True + GTK_ORIENTATION_HORIZONTAL + GTK_TOOLBAR_BOTH + True + True + + + + True + True + True + False + + + + True + Restart + True + GTK_RELIEF_NONE + True + + + + True + gtk-goto-top + 4 + 0.5 + 0.5 + 0 + 0 + + + + + + + False + False + + + + + + True + True + True + False + + + + True + Retract 1 phrase + True + GTK_RELIEF_NONE + True + + + + True + gtk-go-up + 4 + 0.5 + 0.5 + 0 + 0 + + + + + + + False + False + + + + + + True + True + True + False + + + + True + Execute until point + True + GTK_RELIEF_NONE + True + + + + True + gtk-jump-to + 4 + 0.5 + 0.5 + 0 + 0 + + + + + + + False + False + + + + + + True + True + True + False + + + + True + Execute 1 phrase + True + GTK_RELIEF_NONE + True + + + + True + gtk-go-down + 4 + 0.5 + 0.5 + 0 + 0 + + + + + + + False + False + + + + + + True + True + True + False + + + + True + Execute all + True + GTK_RELIEF_NONE + True + + + + True + gtk-goto-bottom + 4 + 0.5 + 0.5 + 0 + 0 + + + + + + + False + False + + + + + 0 + False + False + + + + + + True + True + True + True + GTK_POS_BOTTOM + False + False + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + + + + False + True + + + + + + True + script + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + True + True + False + False + False + True + False + False + False + + + + + False + True + + + + + + True + outline + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + 0 + True + True + + + + + 0 + True + True + + + + + True + False + + + + + + 250 + 500 + True + True + 380 + + + + True + True + True + True + GTK_POS_TOP + False + False + + + True + False + + + + + + True + False + 0 + + + + True + True + GTK_POLICY_NEVER + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + False + False + True + GTK_JUSTIFY_LEFT + GTK_WRAP_CHAR + False + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + 0 + True + True + + + + + True + True + + + + + True + True + + + + + 0 + True + True + + + + + 0 + True + True + + + + + + True + False + 0 + + + + True + False + + + 0 + True + True + + + + + + True + False + True + GTK_POS_TOP + False + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + False + True + + + + + + True + label14 + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + 0.5 + 0.5 + 0 + 0 + + + False + True + + + + + + True + label15 + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + + True + 0.5 + 0.5 + 0 + 0 + + + False + True + + + + + + True + label16 + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + tab + + + + + 0 + False + True + + + + + 0 + False + False + + + + + + + + + + DUMMY + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + True + + + + True + False + 0 + + + + True + GTK_BUTTONBOX_END + + + + True + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + -6 + + + + + + True + True + True + gtk-ok + True + GTK_RELIEF_NORMAL + True + -5 + + + + + 0 + False + True + GTK_PACK_END + + + + + + True + DUMMY + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + True + GTK_JUSTIFY_LEFT + GTK_WRAP_NONE + True + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + 0 + True + True + + + + + + + + 280 + Uri choice + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER + True + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + True + + + + True + False + 4 + + + + True + GTK_BUTTONBOX_END + + + + True + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + -6 + + + + + + True + True + True + GTK_RELIEF_NORMAL + True + 0 + + + + True + 0.5 + 0.5 + 0 + 0 + 0 + 0 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-index + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Try _Selected + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + + + + True + False + True + True + Try Constants + True + GTK_RELIEF_NORMAL + True + 0 + + + + + + True + True + gtk-copy + True + GTK_RELIEF_NORMAL + True + 0 + + + + + + True + True + True + GTK_RELIEF_NORMAL + True + 0 + + + + True + 0.5 + 0.5 + 0 + 0 + 0 + 0 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-ok + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + bla bla bla + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + + + 0 + False + True + GTK_PACK_END + + + + + + True + False + 3 + + + + True + some informative message here ... + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + 400 + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + True + True + False + False + False + True + False + False + False + + + + + 0 + True + True + + + + + + True + False + 0 + + + + True + URI: + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + True + True + True + 0 + + True + * + False + + + 0 + True + True + + + + + 0 + False + True + + + + + 0 + True + True + + + + + + + + 5 + Find & Replace + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_MOUSE + False + False + False + True + False + False + GDK_WINDOW_TYPE_HINT_DIALOG + GDK_GRAVITY_NORTH_WEST + True + + + + True + 3 + 2 + False + 5 + 0 + + + + True + Find: + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + Replace with: + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + True + True + True + True + True + True + 0 + + True + * + False + + + 1 + 2 + 0 + 1 + + + + + + + True + True + True + True + 0 + + True + * + False + + + 1 + 2 + 1 + 2 + + + + + + + True + False + 5 + + + + True + False + 0 + + + + + + + + + + + 0 + True + True + + + + + + True + True + gtk-find + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + True + GTK_RELIEF_NORMAL + True + + + + True + 0.5 + 0.5 + 0 + 0 + 0 + 0 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-find-and-replace + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + _Replace + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + 0 + False + False + + + + + + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + 0 + 2 + 2 + 3 + 5 + + + + + + + + Create development + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER_ALWAYS + True + False + False + True + False + False + GDK_WINDOW_TYPE_HINT_UTILITY + GDK_GRAVITY_NORTH_WEST + True + + + + True + False + 0 + + + + 3 + True + 2 + 3 + False + 5 + 5 + + + + True + Name + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + Root directory + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + True + True + True + 0 + + True + * + False + + + 1 + 2 + 0 + 1 + + + + + + + True + True + True + True + 0 + + True + * + False + + + 1 + 2 + 1 + 2 + + + + + + + True + True + ... + True + GTK_RELIEF_NORMAL + True + + + 2 + 3 + 1 + 2 + fill + + + + + + 0 + False + True + + + + + + True + + + 2 + False + True + + + + + + 3 + True + False + 5 + + + + True + False + 0 + + + + + + + + + + + 0 + True + True + + + + + + True + True + gtk-add + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + True + gtk-cancel + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + 0 + False + True + + + + + + + + Developments + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + + + + True + False + 0 + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + False + False + False + True + False + False + False + + + + + 0 + True + True + + + + + + True + + + 2 + False + True + + + + + + 3 + True + False + 4 + + + + True + False + 0 + + + + + + + + + + + 0 + True + True + + + + + + True + True + gtk-new + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + True + gtk-delete + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + True + GTK_RELIEF_NORMAL + True + + + + True + 0.5 + 0.5 + 0 + 0 + 0 + 0 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-execute + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + _Build + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + 0 + False + False + + + + + + True + True + GTK_RELIEF_NORMAL + True + + + + True + 0.5 + 0.5 + 0 + 0 + 0 + 0 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-clear + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + C_lean + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + 0 + False + False + + + + + + True + True + gtk-close + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + 0 + False + True + + + + + + + diff --git a/helm/software/matita/matita.gtkrc b/helm/software/matita/matita.gtkrc new file mode 100644 index 000000000..91081c311 --- /dev/null +++ b/helm/software/matita/matita.gtkrc @@ -0,0 +1,80 @@ +# Based on /usr/share/themes/Emacs/gtk-2.0-key/, +# modified by Zack for matita + +# +# A keybinding set implementing emacs-like keybindings +# + +# +# Bindings for GtkTextView and GtkEntry +# +binding "gtk-emacs-text-entry" +{ + bind "b" { "move-cursor" (logical-positions, -1, 0) } + bind "b" { "move-cursor" (logical-positions, -1, 1) } + bind "f" { "move-cursor" (logical-positions, 1, 0) } + bind "f" { "move-cursor" (logical-positions, 1, 1) } + + bind "b" { "move-cursor" (words, -1, 0) } + bind "b" { "move-cursor" (words, -1, 1) } + bind "f" { "move-cursor" (words, 1, 0) } + bind "f" { "move-cursor" (words, 1, 1) } + + bind "a" { "move-cursor" (paragraph-ends, -1, 0) } + bind "a" { "move-cursor" (paragraph-ends, -1, 1) } + bind "e" { "move-cursor" (paragraph-ends, 1, 0) } + bind "e" { "move-cursor" (paragraph-ends, 1, 1) } + + bind "w" { "cut-clipboard" () } + bind "y" { "paste-clipboard" () } + + bind "d" { "delete-from-cursor" (chars, 1) } + bind "d" { "delete-from-cursor" (word-ends, 1) } + bind "k" { "delete-from-cursor" (paragraph-ends, 1) } + bind "backslash" { "delete-from-cursor" (whitespace, 1) } + + bind "space" { "delete-from-cursor" (whitespace, 1) + "insert-at-cursor" (" ") } + bind "KP_Space" { "delete-from-cursor" (whitespace, 1) + "insert-at-cursor" (" ") } + + # + # Some non-Emacs keybindings people are attached to + # + bind "u" { + "move-cursor" (paragraph-ends, -1, 0) + "delete-from-cursor" (paragraph-ends, 1) + } + bind "h" { "delete-from-cursor" (chars, -1) } + bind "w" { "delete-from-cursor" (word-ends, -1) } +} + +# +# Bindings for GtkTextView +# +binding "gtk-emacs-text-view" +{ +# bind "p" { "move-cursor" (display-lines, -1, 0) } + bind "p" { "move-cursor" (display-lines, -1, 1) } +# bind "n" { "move-cursor" (display-lines, 1, 0) } + bind "n" { "move-cursor" (display-lines, 1, 1) } + + bind "space" { "set-anchor" () } + bind "KP_Space" { "set-anchor" () } +} + +# +# Bindings for GtkTreeView +# +binding "gtk-emacs-tree-view" +{ + bind "s" { "start-interactive-search" () } + bind "f" { "move-cursor" (logical-positions, 1) } + bind "b" { "move-cursor" (logical-positions, -1) } +} + +class "GtkEntry" binding "gtk-emacs-text-entry" +class "GtkTextView" binding "gtk-emacs-text-entry" +class "GtkTextView" binding "gtk-emacs-text-view" +class "GtkTreeView" binding "gtk-emacs-tree-view" + diff --git a/helm/software/matita/matita.lang b/helm/software/matita/matita.lang new file mode 100644 index 000000000..0c181ee44 --- /dev/null +++ b/helm/software/matita/matita.lang @@ -0,0 +1,186 @@ + + + + + \ + + + \(\* + \*\) + + + + \(\*\* + \*\*\) + + + + theorem + definition + lemma + fact + remark + variant + + + + alias + and + as + coercion + coinductive + corec + default + for + include + inductive + in + interpretation + let + match + names + notation + on + qed + rec + record + return + to + using + with + + + + \[ + + + \| + + + \] + + + \{ + + + \} + + + @ + + + \$ + + + + Set + Prop + Type + + + + absurd + apply + assumption + auto + paramodulation + clear + clearbody + change + compare + constructor + contradiction + cut + decide equality + decompose + discriminate + elim + elimType + exact + exists + fail + fold + fourier + fwd + generalize + goal + id + injection + intro + intros + lapply + left + letin + normalize + reduce + reflexivity + replace + rewrite + ring + right + symmetry + simplify + split + to + transitivity + unfold + whd + + + + try + solve + do + repeat + first + + + + + print + check + hint + quit + set + + + + elim + hint + instance + locate + match + + + + def + forall + lambda + to + exists + Rightarrow + Assign + land + lor + lnot + liff + subst + vdash + iforall + iexists + + + + " + " + + + diff --git a/helm/software/matita/matita.ma.templ b/helm/software/matita/matita.ma.templ new file mode 100644 index 000000000..ec1bc8006 --- /dev/null +++ b/helm/software/matita/matita.ma.templ @@ -0,0 +1,16 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/test/". + diff --git a/helm/software/matita/matita.ml b/helm/software/matita/matita.ml new file mode 100644 index 000000000..07f7f900a --- /dev/null +++ b/helm/software/matita/matita.ml @@ -0,0 +1,216 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open MatitaGtkMisc +open GrafiteTypes + +(** {2 Initialization} *) + +let _ = MatitaInit.initialize_all () +(* let _ = Saturation.init () (* ALB to link paramodulation *) *) + +(** {2 GUI callbacks} *) + +let gui = MatitaGui.instance () + +let script = + let s = + MatitaScript.script + ~source_view:gui#sourceView + ~mathviewer:(MatitaMathView.mathViewer ()) + ~urichooser:(fun uris -> + try + MatitaGui.interactive_uri_choice ~selection_mode:`SINGLE + ~title:"Matita: URI chooser" + ~msg:"Select the URI" ~hide_uri_entry:true + ~hide_try:true ~ok_label:"_Apply" ~ok_action:`SELECT + ~copy_cb:(fun s -> gui#sourceView#buffer#insert ("\n"^s^"\n")) + () ~id:"boh?" uris + with MatitaTypes.Cancel -> []) + ~set_star:gui#setStar + ~ask_confirmation: + (fun ~title ~message -> + MatitaGtkMisc.ask_confirmation ~title ~message + ~parent:gui#main#toplevel ()) + ~develcreator:gui#createDevelopment + () + in + gui#sourceView#source_buffer#begin_not_undoable_action (); + s#reset (); + s#template (); + gui#sourceView#source_buffer#end_not_undoable_action (); + s + + (* math viewers *) +let _ = + let cic_math_view = MatitaMathView.cicMathView_instance () in + let sequents_viewer = MatitaMathView.sequentsViewer_instance () in + sequents_viewer#load_logo; + cic_math_view#set_href_callback + (Some (fun uri -> (MatitaMathView.cicBrowser ())#load + (`Uri (UriManager.uri_of_string uri)))); + let browser_observer _ _ = MatitaMathView.refresh_all_browsers () in + let sequents_observer _ grafite_status = + sequents_viewer#reset; + match grafite_status.proof_status with + | Incomplete_proof ({ stack = stack } as incomplete_proof) -> + sequents_viewer#load_sequents incomplete_proof; + (try + script#setGoal (Some (Continuationals.Stack.find_goal stack)); + let goal = + match script#goal with + None -> assert false + | Some n -> n + in + sequents_viewer#goto_sequent goal + with Failure _ -> script#setGoal None); + | Proof proof -> sequents_viewer#load_logo_with_qed + | No_proof -> sequents_viewer#load_logo + | Intermediate _ -> assert false (* only the engine may be in this state *) + in + script#addObserver sequents_observer; + script#addObserver browser_observer + + (** {{{ Debugging *) +let _ = + if BuildTimeConf.debug then begin + gui#main#debugMenu#misc#show (); + let addDebugItem ~label callback = + let item = + GMenu.menu_item ~packing:gui#main#debugMenu_menu#append ~label () + in + ignore (item#connect#activate callback) + in + addDebugItem "dump environment to \"env.dump\"" (fun _ -> + let oc = open_out "env.dump" in + CicEnvironment.dump_to_channel oc; + close_out oc); + addDebugItem "load environment from \"env.dump\"" (fun _ -> + let ic = open_in "env.dump" in + CicEnvironment.restore_from_channel ic; + close_in ic); + addDebugItem "dump universes" (fun _ -> + List.iter (fun (u,_,g) -> + prerr_endline (UriManager.string_of_uri u); + CicUniv.print_ugraph g) (CicEnvironment.list_obj ()) + ); + addDebugItem "dump environment content" (fun _ -> + List.iter (fun (u,_,_) -> + prerr_endline (UriManager.string_of_uri u)) + (CicEnvironment.list_obj ())); +(* addDebugItem "print selections" (fun () -> + let cicMathView = MatitaMathView.cicMathView_instance () in + List.iter HLog.debug (cicMathView#string_of_selections)); *) + addDebugItem "dump script status" script#dump; + addDebugItem "dump configuration file to ./foo.conf.xml" (fun _ -> + Helm_registry.save_to "./foo.conf.xml"); + addDebugItem "dump metasenv" + (fun _ -> + if script#onGoingProof () then + HLog.debug (CicMetaSubst.ppmetasenv [] script#proofMetasenv)); + addDebugItem "dump coercions Db" (fun _ -> + List.iter + (fun (s,t,u) -> + HLog.debug + (UriManager.name_of_uri u ^ ":" + ^ CoercDb.name_of_carr s ^ " -> " ^ CoercDb.name_of_carr t)) + (CoercDb.to_list ())); + addDebugItem "print top-level grammar entries" + CicNotationParser.print_l2_pattern; + addDebugItem "dump moo to stderr" (fun _ -> + let grafite_status = (MatitaScript.current ())#grafite_status in + let moo = grafite_status.moo_content_rev in + List.iter + (fun cmd -> + prerr_endline (GrafiteAstPp.pp_command ~obj_pp:(fun _ -> assert false) + cmd)) + (List.rev moo)); + addDebugItem "print metasenv goals and stack to stderr" + (fun _ -> + prerr_endline ("metasenv goals: " ^ String.concat " " + (List.map (fun (g, _, _) -> string_of_int g) + (MatitaScript.current ())#proofMetasenv)); + prerr_endline ("stack: " ^ Continuationals.Stack.pp + (GrafiteTypes.get_stack (MatitaScript.current ())#grafite_status))); +(* addDebugItem "ask record choice" + (fun _ -> + HLog.debug (string_of_int + (MatitaGtkMisc.ask_record_choice ~gui ~title:"title" ~message:"msg" + ~fields:["a"; "b"; "c"] + ~records:[ + ["0"; "0"; "0"]; ["0"; "0"; "1"]; ["0"; "1"; "0"]; ["0"; "1"; "1"]; + ["1"; "0"; "0"]; ["1"; "0"; "1"]; ["1"; "1"; "0"]; ["1"; "1"; "1"]] + ()))); *) + addDebugItem "rotate light bulbs" + (fun _ -> + let nb = gui#main#hintNotebook in + nb#goto_page ((nb#current_page + 1) mod 3)); + addDebugItem "print runtime dir" + (fun _ -> + prerr_endline BuildTimeConf.runtime_base_dir); + addDebugItem "disable all (pretty printing) notations" + (fun _ -> CicNotation.set_active_notations []); + addDebugItem "enable all (pretty printing) notations" + (fun _ -> + CicNotation.set_active_notations + (List.map fst (CicNotation.get_all_notations ()))); + end + (** Debugging }}} *) + + (** {2 Command line parsing} *) + +let set_matita_mode () = + let matita_mode = + if Filename.basename Sys.argv.(0) = "cicbrowser" || + Filename.basename Sys.argv.(0) = "cicbrowser.opt" + then "cicbrowser" + else "matita" + in + Helm_registry.set "matita.mode" matita_mode + + (** {2 Main} *) + +let _ = + set_matita_mode (); + at_exit (fun () -> print_endline "\nThanks for using Matita!\n"); + Sys.catch_break true; + let args = Helm_registry.get_list Helm_registry.string "matita.args" in + if Helm_registry.get "matita.mode" = "cicbrowser" then (* cicbrowser *) + let browser = MatitaMathView.cicBrowser () in + let uri = match args with [] -> "cic:/" | _ -> String.concat " " args in + browser#loadInput uri + else begin (* matita *) + (try gui#loadScript (List.hd args) with Failure _ -> ()); + gui#main#mainWin#show (); + end; + try + GtkThread.main () + with Sys.Break -> () + +(* vim:set foldmethod=marker: *) diff --git a/helm/software/matita/matita.txt b/helm/software/matita/matita.txt new file mode 100644 index 000000000..ce34e404c --- /dev/null +++ b/helm/software/matita/matita.txt @@ -0,0 +1,426 @@ + Ferruccio ha cambiato matita.lang: + > iforall + > iexists + +TODO + NUCLEO + - http://mowgli.cs.unibo.it:58084/proofCheck?uri=cic:/Coq/Reals/Rtopology/interior_P3.con + - i files di coq non hanno gli universi e hanno Type senza l'id numerico + per ora vengono considerati come con grafo vuoto... + - limit_mul non compila (usare test_library per testare l'intera libreria) + (15:06:07) Zack: http://www.cs.unibo.it/cgi-bin/viewcvs.cgi/helm/gTopLevel/testlibrary.ml?rev=1.20&hideattic=0&content-type=text/vnd.viewcvs-markup + - PREOCCUPANTE: per + inductive i : Prop := K : True (*-> i*) -> i. + noi generiamo i_rec e i_rect con e senza il commento qui sopra; Coq NON + genera i_rec e i_rect quando c'e' un argomento ricorsivo. + (CSC: manca vincolo aggiuntivo non dipendente dalla sorta per il caso in + questione) -> CSC, parzialmente risolto, da finire + - Set predicativo + - bug universi e tipi induttivi (anche in cicElim.ml!!!) + + TATTICHE + - coercions verso sorte: + 1. coercere a una sorta in posizione controvariante: andare verso Prop, + altrimenti verso {Type,Set,CProp} (indifferentemente?) + 2. coercere a una sorta in posizione covariante: la scelta piu' safe e' + andare verso Type, poi verso CProp, poi verso Set, poi verso Prop. + Unico problema: la scelta piu' safe e' anche quella pessima dal punto + di vista dell'estrazione di codice :-( + - fare normalize_pattern : pattern -> goal -> pattern e usarla per + abilitare fase 2 in fold e rewrite + - apply puo' generare termini non ben tipati. + Esempio: p = q e fare apply eq_ind' di p! + - generazione di principi di co-induzione per co-induttivi + - ARGOMENTI IMPLICIT: li vogliamo? come? come disabilitarli localmente? + - file elim.ma: vengono creati lambda dummy e referenziati nell'outtype di + un case + - tattiche e fallimenti: una tattica che non progredisce dovrebbe fallire + - comportamento di tutte le tattiche nei confronti dei let-in + - elim con pattern + - assiomi (manca sintassi concreta e AST). + - Dare errore significativo al posto di NotWellTypedInterpreation -> CSC + - elim_intros_simpl e rewrite_simpl: ora non viene usata dal + ^^^^^^ ^^^^^^ + toplevel la variante che semplifica. Capire quali sono i problemi + e/o cosa fare delle varianti con semplificazione. + (con sintassi concreta alla \section*, analogamente cut e similia che fanno + intros... ) -> CSC + - eta_expand non usata da nessuno? (ask Andrea?) + - eliminare eta_fix? (aspettare notazione) (correlato con sopra?) + - bug di ferruccio: fare un refresh dei nomi dopo l'applicazione + di una tattica. Di quali nomi fare refresh? (Andrea) di quelli + veramente ambigui, ovvero dell'ultimo binder tale che sotto di + esso un nome viene usato in maniera ambigua. Esempio: + \lambda x. \lambda x. (x x) (dove una x e' -2) ==> fare refresh + \lambda x. \lambda x. (x x) (dove entrambe sono -1) ==> non fare refresh + Capita quando un tipo dall'environment (e.g. \lambda x.T) + viene inserito in un contesto (e.g. x:nat) dove le variabili + sono gia' state legate in precedenza. + + GUI GRAFICA + - cut & paste di pattern profondi nelle ipotesi + - cut & paste di inner-types non chiusi non funzionanti + - cut & paste di congetture nello script delle prove non funzionante + - keybinding globali: CTRL-{su,giu,...} devono fungere anche quando altre + finestre hanno il focus (e.g. cicBrowser). C'e' gia' da qualche parte il + codice che aggiunge i keybinding a tutte le eventBox, e' da ripristinare + - la finestrella per i development ha i pulsanti non sensitive. + - l'entry "Save" da menu non e' context sensitive (ti fa salvare anche + quando il file non e' stato modificato) + - non semplificherebbe le cose fare in modo che matitaScript sia un widget + (cosi' come lo e' matitaMathView) che eredita da GtkSourceView e mantiene + internamente lo status di matita etc. Appositi segnali permetterebbero di + evitare tutte le chiamate al singleton #instance di matitaScript, che + verrebbe creato dentro a matitaGui (o forse meglio dentro a matita e passato + a matitaGui). Si semplificherebbe forse anche la gestione di script + multipli? Forse no, perche' comunque ci puo' essere sempre solamente uno + ed un solo matitaScript (da spostare da un tab a un altro). + - la barra di stato: c'e' ma non funziona? + + - feedback su hyperlink nei sequenti e nel browser: rendere visibili gli + hyperlink (cursore a "manina"? hyperlink evidenziati?). La maction che + collassa la prova e' fastidiosa: la prova si chiude se non si clicca + correttamente su un hyperlink (anche tooltip sui bottoni) + + - che farne della palette delle tattiche? + - script outline, o meglio: modulo per la gestione del testo dello script + -> Zack + - riattaccare hbugs (brrr...) -> Zack + + - supportare l'apertura di piu' script contemporaneamente in tab/finestre + diversi/e + + GUI LOGICA + - -nodb non usato da disambiguazione: dopo il primo errore si ottiene + un errore di identificatore non trovato (dalla locate?) + - generazione di dipendenze verso .moo di Coq (non esistenti!) -> Zack + - proposta di Zack: NON calcolare (ed esportare) per default gli inner-types; + aggiungere un'opzione per questo a matitac (riduce drasticamente il tempo + di qed) + - la funzione alias_diff e' lentissima (anche se CSC l'ha accellerata di + un fattore 3x) e puo' essere evitata: chi vuole aggiungere alias (la + disambiguazione, il comando "alias" e l'add_obj) deve indicare + esplicitamente quali sono i nuovi alias, evitando cosi' la diff per + scoprirlo + - matitac deve fallire quando matita vuole aggiungere un alias! + - default equality e famiglia non e' undo-aware + - le coercion non sono undo-aware + - nuovo pretty-printer testuale: non stampa usando la notazione + (e.g. guardare output di matitac) + - matitamake foo/a.ma non funziona; bisogna chiamarlo con + matitamake /x/y/z/foo/a.ma + - notazione per i numeri -> Luca e Zack + - non chiudere transitivamente i moo ?? + + DEMONI E ALTRO + - compilare Whelp + +DONE +- in MatitaEngine unificare/rimuovere eval_string, eval_from_stream e + eval_from_stream_greedy -> CSC +- menu contestuale (tasto dx) nel sequent viewer -> Zack +- in generale: invece di spiegare gli errori nel momento in cui si sollevano + le eccezioni, farlo quando vengono presentate all'utente. Motivo: il calcolo + del messaggio di errore puo' essere estremamente costoso (e' gia' successo!) + quando poi il messaggio non serve!!! -> CSC +- matitaclean all (non troglie i moo?) -> Gares +- matitaclean (e famiglia) non cancellano le directory vuote + (e per giunta il cicbrowser le mostra :-) -> Gares +- missing feature unification: applicazione di teoremi (~A) quando il goal + e' False o di teoremi $symmetric R P$ quando il goal e' $P(x,y)$. + Fare un passo di delta[-beta?][-iota-etc.] quando da una parte c'e' una + testa rigida (che si espande in una freccia)? Ma il punto e' che il bug + non e' di unificazione, bensi' nella fase di preparazione del goal per + la apply -> CSC, Gares +- Guardare il commento + (*CSC: this code is suspect and/or bugged: we try first without reduction + and then using whd. However, the saturate_term always tries with full + reduction without delta. *) + in primitiveTactics.ml. Potrebbe essere causa di rallentamento della apply + oltre che di bug! -> CSC, Gares +- codice di inizializzazione di matita, matitac, matitatop replicato e non + in sync -> Gares +- tutte gli script che parsano (e.g. matitaclean, matitadep) debbono + processare la notazione per evitare errori di parsing (visibili ora + che e' stata committata la contrib list)! -> Gares +- E' possibile fare "Build" senza selezionare nulla, ottenendo un + assert false -> Gares +- disambiguazione: attualmente io (CSC) ho committato la versione di + disambiguate.ml che NON ricorda gli alias in caso di disambiguazione + univoca (senza scelte per l'utente). [ cercare commento "Experimental" ] + Il problema di questa soluzione e' che rallenta in maniera significativa + l'esecuzione degli script. DOMANDA: quanto costano le fasi di + fetch/decode/execute delle linee dello script? + Una possibile alternativa e' avere alias "soft": se la disambiguazione + fallisce gli alias soft vengono ripuliti e si riprova. + Altra soluzione (Gares): avere alias multipli e provare tutti gli alias + multipli. Da combinare con il "ritenta con istanze multiple in caso di + fallimento". + SOLUZIONE PENSATA CON ANDREA: 1. la interpretate aggiunge un alias + implicito; 2. gli alias vengono ricordati come nella soluzione originale + (e veloce); 3. se la disambiguazione fallisce, allora gli alias vengono + dimenticati (quali? tutti? tutti tranne quelli chiesti all'utente?) + e si ritenta; se fallisce ancora si generano + istanze differenti e si ritenta; 4. ritentare anche senza e poi con + coercions? oppure ordinare preferendo la soluzione che non ha introdotto + coercions?; 5. che fare se alla fine restano piu' scelte? se si mettono + gli alias nello script viene un paciugo, credo! in particolare quando + vengono usate n istanze -> Zack, CSC +- theorem t: True. elim O. ==> BOOM! unificazione di una testa flessibile con + True -> Gares +- parsing contestuale (tattiche replace, change e forse altre) + capire dove fare la select per avere i contesti in cui disambiguare gli + altri argomenti. -> Zack +- tattica unfold su rel a let-in bound variables: c'e' ancora un bug + aperto: "unfold x in H:..." la x passata alla unfold vive nel contesto + del goal e non in quello del pattern. Pertanto invece di cercare di + fare unfolding di x viene fatto unfolding di altro. + Soluzione: la funzione ProofEngineHelpers.select deve tornare una + funzione per rilocare i termini nel contesto giusto. + Esempio: + theorem t: let uno \def S O in uno + uno = S uno \to uno=uno. + intros. unfold uno in H. + NOTA: questo bug e' legato a quello di parsing in presenza di tattiche + con pattern, visto che in tal caso e' l'intero parsing a dover essere + fatto in un contesto differente. Risolvendo quel bug si risolve + automaticamente anche questo. + -> Zack +- Usare il cicbrowser per fare "Whelp instance": lui riscrive la barra + con la notazione alla Coq V7.0 che non riesce piu' a riparsare! -> Zack +- implementare inclusione file di configurazione (perche' ora tutti + i demoni scopiazzano venti righe per via del getter embedded :-( -> Zack +- simplify non debbono zeta-espandere i let-in -> CSC, Gares +- integrare nuova contrib ferruccio nel bench notturno e rilocarla in + contribs o qualcosa del genere -> CSC +- CRITICO: quando l'environment non e' trusted non compila la library di + matita!!! -> Gares, CSC +- bug di unsharing -> CSC +- CRITICO (trovato anche da Ferruccio): typechecking di + cic:/Coq/ring/Quote/index_eq_prop.con + asserzione del nucleo (applicazione senza argomenti). -> CSC +- verificare se tutte le query sono ora ottimizzate (usando il comando + explain) e usano gli indici in maniera ottimale; inoltre migliorare gli + indici sulle tabelle hits and count -> CSC +- ???????????? Perche'? + mowgli:~# du -s /var/lib/mysql/mowgli/ + 250696 /var/lib/mysql/mowgli/ + mowgli:~# du -s /var/lib/mysql/matita/ + 455096 /var/lib/mysql/matita/ -> CSC +- library/nat/primes.ma: ex_prime ci mette un secolo il db (binding) a fare + la Mysql.exec che ritorna una lista vuota di risultati. Investigare. + Anche peggio in library/nat/minimization/f_max_true. -> CSC +- integrare il famoso logo mancante (anche nell'About dialog) -> CSC +- invertibilita' dell'inserimento automatico di alias: quando si torna + su bisognerebbe tornare su di un passo e non fare undo degli alias + (Zack: nella history ci sono anche gli offset per sapere a che pezzo di + script uno stato appartiene) -> CSC +- bug di refresh del widget quando si avanza ("swap" tra la finestra dei + sequenti e la finestra dello script) -> CSC +- sensitiveness per goto begin/end/etc. (???) -> Gares +- cut&paste stile "X": rimane la parte blu e lockata! -> CSC +- highlight degli errori di parsing nello script -> CSC +- quando si fa una locate nel cicbrowser viene mangiato un pezzo di testo + dalla finestra principale!!! -> CSC +- sensitiveness per copy/paste/cut/delete nel menu Edit -> CSC +- fare "matita foo" (dove foo non esiste), cambiare qualcosa e uscire senza + salvare. In verita' foo e' stato scritto lo stesso! -> CSC +- matitaclean deve rimuovere anche i .moo; in alternativa il makefile + non deve basarsi sui .moo per decidere se qualcosa e' stato compilato o meno + -> CSC, Gares +- matitaclean all (o matitamake cleanall) dovrebbe radere al suolo la + directory .matita -> CSC, Gares +- icone standard per zoom-in/out/= e piu' aderenza alle Gnome Interface + Guidelines (e.g. about dialog) -> CSC +- salvare la parte di testo lockata dagli effetti di undo/redo con + (shift-)ctrl-Z e anche usando il menu che si apre con il tasto destro -> CSC +- fare in modo che il testo caricato inizialmente da matita non sia + undoable (usando i metodi begin/end_not_undoable_action di gtk_source_view) + -> Gares +- Implementare menu edit: cut/copy/undo/etc. -> CSC +- gestione dei path per include: il path deve essere assoluto? da decidere ... + ( -I ?? o chiedere a matitamake la root e farci una find? ) -> Gares +- freeze durante avanzamento -> Gares, CSC +- tornare indietro (verso il cursore) in matita dovrebbe essere O(1) e non un + Undo passo passo (sembra che il collo di bottiglia sia fare iterare su ogni + uri da togliere (accorpare almeno il lavoro sul db magari aiuta) -> Gares, CSC +- quando si sposta il punto di esecuzione dello script cambiare la parte di + script visibile nella finestra dello script -> Gares, CSC +- find & replace -> Gares +- Bug di cut&paste: se si fa cut&paste di testo lockato si ottiene testo + lockato! -> Gares +- Bug: non disambigua + inductive i (x:nat) : bool \to Prop \def K : bool \to (i x true) \to (i x false). + perche' non inserisce nat nel domain di disambiguazione. Deve esserci un bug + stupido da qualche parte -> CSC +- Bug vari nella generazione dei principi di eliminazione: + 1. generazione nomi (usa ref incrementata localmente) -> Andrea + 2. prodotti dipendenti come non-dipendenti (visibili eseguendo passo + passo il test inversion.ma) -> CSC, Gares + 3. usato trucco outtype non dipendenti per il case -> CSC, Gares +- controllo per script modificato o meno prima di uscire -> Gares +- LApply deve prendere in input gli identificatori che va a generare; + lascio a Ferruccio la scelta della sintassi concreta -> Ferruccio +- fare tornare a matitac -1 quando lo stato finale e' + diverso da No_proof, non eseguire comandi quando lo + stato e' diverso da No_proof -> CSC +- uri_of_term and term_of_uri: cambiare il tipo per far + tornare delle uri!!! -> CSC +- intro = intros 1 -> Gares +- timetravel (urimanager) -> Gares +- implementare macro in matitaScript.ml -> Gares +- history deve aggiornare anche la whelp bar -> Gares +- commenti exeguibili (forse devono essere una lista e non + un singolo executable e forse devono contenere anche Note + e non solo Executable) -> Gares +- spostare il codice di creazione delle tabelle da + MatitaDb, al momento quelle create da matita possono + andare out of sync con quelle create dai file .sql -> Gares +- tree update in background -> Gares +- update del getter in background -> Zack +- agganciare href_callback del sequent_viewer -> Zack +- shortcut varie per script handling -> Zack +- operazioni rimanenti su script (top, bottom, jump) -> Zack +- lighting-ls-getter in matita -> Gares +- riagganciare toolbar -> Zack +- evitare che n-mila tattiche Goal siano nello script + (una per ogni cambio di tab) -> Zack +- implementazione comandi rimanenti in matitaEngine.ml -> Gares +- sintassi per gli alias -> Gares +- implementazione script handling (sopra engine) -> Zack +- matitaSync all'indietro -> Gares +- riagganciare GUI -> Zack + +(**********************************************************************) + +comandi: + - interattivi (solo da gui) + - Macro/Comandi (check, print, hint, undo, locate, match) + potrebbero anche non avere sintassi concreta, del tipo che + check e' solo un bottone che apre una finetra in cui puoi + scrivere un termine o selezionarlo dalla prova corrente + - batch (sono gli unici che stanno nel .ma) + - Tattiche, theorem, alias (cambiano la prova) + + + MOUSE +-------------------------------------------+ + gui (macro: hint) | SHELL + (disambiguatore) | + +-----------------+---------------+----------------------------------- + | matita (status) | | matitac + | (log) (sync) | but2log | fold ( fun s l -> engine l s) file + +-----------------+---------------+----------------------------------- + | lingua:/sintassi concreta non ambigua delle tattiche+Qed,Thm,alias/ + +---------------------------------------------------------- + | engine: TacticAst (cic) -> status -> status + | ma non usa il campo alias dello status +---------+---------------------------------------------------------- + ocaml +-------------------------------------------------------------------- + + +engine: + - accetta solo linee non ambigue + - alias: + alias ident nat = "cic:/matita/gares/nat.ind#(1/1)". + alias number = (natural|real|positive|integer). + + + +matita: + - mantiene uno stack di stati + - mantiene un log sync con gli stati + - offre delle api per generare la sintassi concreta che puo' servire + alla gui (la gui fa una chiamata a funzione e matita genera "auto." + cosi' la sintassi la gui non la vede mai e la tratta al massimo come un + testo semplice e basta (insomma, metterei in matita il generatore di + sintassi concreta) but2log + - ha il controllo... ovvero anche la gui viene usata da matita, o per sapere + la prossima azione o per chidere di scegliere il termine tra una lista + + (stato :: tl) (log , (start,end) :: tl) + + +----------+ + | | + +----------+ + +gui: + - step + - choose + +stato: + - alias + - proof status option + - metadati relativi allo script per il sync + - settings "baseuri/url/" eccc + - + +alias + - sintassi concreta + +engine prende in input + - AST di Cic (tactic ast) + +sync: + - presi 2 stati fa il diff e lo somma/sottrae al DB + +(**********************************************************************) + +script handling +- ad ogni script sul quale l'utente sta lavorando corrispondono + - un modello (vedi sotto) + - un buffer di testo gtk + attributi (usati principalmente per distinguere la + parte di testo immodificabile da quella modificabile) + - una lista di observer che vengono notificati ad ogni cambiamento di stato +- un modello di script e' composto da: + - una lista di stringhe (inizialmente vuota) detta "statement list". Ogni + elemento della lista corrisponde ad uno statement (nel senso di + TacticAst.statement) gia' valutato dall'engine. La parte immodificabile del + buffer di testo corrisponde con le stringhe contenute nella lista + - una lista di stati (inizialmente contenente lo stato vuoto) detta "state + list". Si ha l'invariante che la lunghezza di tale lista e' uguale alla + lunghezza della statements list + 1. Lo stato i-esimo della lista di stati + e' lo stato di matita _prima_ dell'esecuzione dell i-esimo statement + - una stringa, detta "future text", corrispondente alla parte di testo dello + script non ancora valutata. L'ultimo stato della state list e' lo stato + corrente di matita +- relazione tra modello e buffer di testo gtk + - le modifiche al testo del buffer sono possibili solo nella parta non ancora + valutata. Ognuna di esse viene apportata _anche_ al future text + - invariante: e' sempre possibile riscrivere ("redraw") l'intero contenuto del + buffer di testo a partire dal modello, attributi compresi +- oggetto script + - metodi + - new: gtk_text_buffer -> script + - redraw: unit (* ridisegna il contenuto del buffer di testo *) + - advance: ?statement:string -> unit -> unit + (* valuta il primo statement del future text (usando eval_statement + (puo' fallire con una eccezione)), rimuove il testo corrispondente dal + future text, aggiunge alla statement list una entry per ogni statement + ritornato da eval_statement, aggiunge il nuovo stato alla state list, + invoka tutti gli observer + Se c'e' l'argomento opzionale statement, quello e' il testo che viene + passato ad eval_statement, se ha successo nessuna rimozione dal future + text viene effettuata *) + - retract: unit -> unit + (* sposta l'ultimo statement della statement list al future text, toglie + l'ultimo stato della state list, MatitaSync.time_travel + ~present:ultimo_stato ~past:stato_precedente *) + - private eval_statement: string -> MatitaTypes.status * string list + (* parsa lo statement + - se e' un Command o un Tactical (vedi TacticAst) invoca MatitaEngine + passando lo stato corrente + - se e' una Macro la gestisce (= tutte le Macro sono implementate qua) + Ritorna una lista di coppie . La proiezione sulla + prima componente rappresenta gli stati da aggiungere alla state list; + quella sulla seconda gli statement da aggiungere alla statement list. + *) + (* gestione degli observer *) + - add_observer: (MatitaTypes.status -> unit) -> observer_id + - remove_observer: observer_id -> unit + (* gestione del salvataggio *) + - save_to: string -> unit (* ridisegna su file *) + - load_from: string -> unit + (* retract fino allo stato zero, nuovo stato con future text pari al + contenuto del file passato *) + diff --git a/helm/software/matita/matitaEngine.ml b/helm/software/matita/matitaEngine.ml new file mode 100644 index 000000000..f0d8ee46c --- /dev/null +++ b/helm/software/matita/matitaEngine.ml @@ -0,0 +1,142 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let debug = false ;; +let debug_print = if debug then prerr_endline else ignore ;; + +let disambiguate_tactic lexicon_status_ref grafite_status goal tac = + let metasenv,tac = + GrafiteDisambiguate.disambiguate_tactic + lexicon_status_ref + (GrafiteTypes.get_proof_context grafite_status goal) + (GrafiteTypes.get_proof_metasenv grafite_status) + tac + in + GrafiteTypes.set_metasenv metasenv grafite_status,tac + +let disambiguate_command lexicon_status_ref grafite_status cmd = + let lexicon_status,metasenv,cmd = + GrafiteDisambiguate.disambiguate_command + ~baseuri:( + try + Some (GrafiteTypes.get_string_option grafite_status "baseuri") + with + GrafiteTypes.Option_error _ -> None) + !lexicon_status_ref (GrafiteTypes.get_proof_metasenv grafite_status) cmd + in + lexicon_status_ref := lexicon_status; + GrafiteTypes.set_metasenv metasenv grafite_status,cmd + +let disambiguate_macro lexicon_status_ref grafite_status macro context = + let metasenv,macro = + GrafiteDisambiguate.disambiguate_macro + lexicon_status_ref + (GrafiteTypes.get_proof_metasenv grafite_status) + context macro + in + GrafiteTypes.set_metasenv metasenv grafite_status,macro + +let eval_ast ?do_heavy_checks ?clean_baseuri lexicon_status + grafite_status ast += + let lexicon_status_ref = ref lexicon_status in + let new_grafite_status,new_objs = + GrafiteEngine.eval_ast + ~disambiguate_tactic:(disambiguate_tactic lexicon_status_ref) + ~disambiguate_command:(disambiguate_command lexicon_status_ref) + ~disambiguate_macro:(disambiguate_macro lexicon_status_ref) + ?do_heavy_checks ?clean_baseuri grafite_status ast in + let new_lexicon_status = + LexiconSync.add_aliases_for_objs !lexicon_status_ref new_objs in + let new_aliases = + LexiconSync.alias_diff ~from:lexicon_status new_lexicon_status in + let _,intermediate_states = + let baseuri = GrafiteTypes.get_string_option new_grafite_status "baseuri" in + List.fold_left + (fun (lexicon_status,acc) (k,((v,_) as value)) -> + let b = + try + UriManager.buri_of_uri (UriManager.uri_of_string v) = baseuri + with + UriManager.IllFormedUri _ -> false (* v is a description, not a URI *) + in + if b then + lexicon_status,acc + else + let new_lexicon_status = + LexiconEngine.set_proof_aliases lexicon_status [k,value] + in + new_lexicon_status, + ((new_grafite_status,new_lexicon_status),Some (k,value))::acc + ) (lexicon_status,[]) new_aliases + in + ((new_grafite_status,new_lexicon_status),None)::intermediate_states + +let eval_from_stream ~first_statement_only ~include_paths ?(prompt=false) + ?do_heavy_checks ?clean_baseuri lexicon_status grafite_status str cb += + let rec loop lexicon_status grafite_status statuses = + let loop = + if first_statement_only then + fun _ _ _ -> raise End_of_file + else + loop + in + if prompt then (print_string "matita> "; flush stdout); + try + let lexicon_status,ast = + GrafiteParser.parse_statement ~include_paths str lexicon_status + in + (match ast with + GrafiteParser.LNone _ -> + loop lexicon_status grafite_status + (((grafite_status,lexicon_status),None)::statuses) + | GrafiteParser.LSome ast -> + cb grafite_status ast; + let new_statuses = + eval_ast ?do_heavy_checks ?clean_baseuri lexicon_status + grafite_status ast in + let grafite_status,lexicon_status = + match new_statuses with + [] -> assert false + | (s,_)::_ -> s + in + loop lexicon_status grafite_status (new_statuses @ statuses)) + with + End_of_file -> statuses + in + loop lexicon_status grafite_status [] +;; + +let eval_string ~first_statement_only ~include_paths ?do_heavy_checks + ?clean_baseuri lexicon_status status str += + eval_from_stream ~first_statement_only ~include_paths ?do_heavy_checks + ?clean_baseuri lexicon_status status (Ulexing.from_utf8_string str) + (fun _ _ -> ()) diff --git a/helm/software/matita/matitaEngine.mli b/helm/software/matita/matitaEngine.mli new file mode 100644 index 000000000..a3c54dea6 --- /dev/null +++ b/helm/software/matita/matitaEngine.mli @@ -0,0 +1,68 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val eval_ast : + ?do_heavy_checks:bool -> + ?clean_baseuri:bool -> + LexiconEngine.status -> + GrafiteTypes.status -> + (CicNotationPt.term, CicNotationPt.term, + CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) + GrafiteAst.statement -> + ((GrafiteTypes.status * LexiconEngine.status) * + (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) option + ) list + + +(* heavy checks slow down the compilation process but give you some interesting + * infos like if the theorem is a duplicate *) +val eval_string : + first_statement_only:bool -> + include_paths:string list -> + ?do_heavy_checks:bool -> + ?clean_baseuri:bool -> + LexiconEngine.status -> + GrafiteTypes.status -> + string -> + ((GrafiteTypes.status * LexiconEngine.status) * + (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) option + ) list + +val eval_from_stream : + first_statement_only:bool -> + include_paths:string list -> + ?prompt:bool -> + ?do_heavy_checks:bool -> + ?clean_baseuri:bool -> + LexiconEngine.status -> + GrafiteTypes.status -> + Ulexing.lexbuf -> + (GrafiteTypes.status -> + (CicNotationPt.term, CicNotationPt.term, + CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string) + GrafiteAst.statement -> unit) -> + ((GrafiteTypes.status * LexiconEngine.status) * + (DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) option + ) list diff --git a/helm/software/matita/matitaExcPp.ml b/helm/software/matita/matitaExcPp.ml new file mode 100644 index 000000000..28f25fd5c --- /dev/null +++ b/helm/software/matita/matitaExcPp.ml @@ -0,0 +1,111 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let rec to_string = + function + | HExtlib.Localized (floc,exn) -> + let _,msg = to_string exn in + let (x, y) = HExtlib.loc_of_floc floc in + Some floc, sprintf "Error at %d-%d: %s" x y msg + | GrafiteTypes.Option_error ("baseuri", "not found" ) -> + None, + "Baseuri not set for this script. " + ^ "Use 'set \"baseuri\" \"\".' to set it." + | GrafiteTypes.Command_error msg -> None, "Error: " ^ msg + | CicNotationParser.Parse_error err -> + None, sprintf "Parse error: %s" err + | UriManager.IllFormedUri uri -> None, sprintf "invalid uri: %s" uri + | CicEnvironment.Object_not_found uri -> + None, sprintf "object not found: %s" (UriManager.string_of_uri uri) + | Unix.Unix_error (code, api, param) -> + let err = Unix.error_message code in + None, "Unix Error (" ^ api ^ "): " ^ err + | HMarshal.Corrupt_file fname -> None, sprintf "file '%s' is corrupt" fname + | HMarshal.Format_mismatch fname + | HMarshal.Version_mismatch fname -> + None, + sprintf "format/version mismatch for file '%s', please recompile it'" + fname + | ProofEngineTypes.Fail msg -> None, "Tactic error: " ^ Lazy.force msg + | Continuationals.Error s -> None, "Tactical error: " ^ Lazy.force s + | CicTypeChecker.TypeCheckerFailure msg -> + None, "Type checking error: " ^ Lazy.force msg + | CicTypeChecker.AssertFailure msg -> + None, "Type checking assertion failed: " ^ Lazy.force msg + | LibrarySync.AlreadyDefined s -> + None, "Already defined: " ^ UriManager.string_of_uri s + | GrafiteDisambiguator.DisambiguationError (offset,errorll) -> + let rec aux n ?(dummy=false) (prev_msg,phases) = + function + [] -> [prev_msg,phases] + | phase::tl -> + let msg = + String.concat "\n\n\n" + (List.map (fun (floc,msg) -> + let loc_descr = + match floc with + None -> "" + | Some floc -> + let (x, y) = HExtlib.loc_of_floc floc in + sprintf " at %d-%d" (x+offset) (y+offset) + in + "*Error" ^ loc_descr ^ ": " ^ Lazy.force msg) phase) + in + if msg = prev_msg then + aux (n+1) (msg,phases@[n]) tl + else + (if not dummy then [prev_msg,phases] else []) @ + (aux (n+1) (msg,[n]) tl) in + let loc = + match errorll with + ((Some floc,_)::_)::_ -> + let (x, y) = HExtlib.loc_of_floc floc in + let x = x + offset in + let y = y + offset in + let flocb,floce = floc in + let floc = + {flocb with Lexing.pos_cnum = x}, {floce with Lexing.pos_cnum = y} + in + Some floc + | _ -> None in + let rec explain = + function + [] -> "" + | (msg,phases)::tl -> + explain tl ^ + "***** Errors obtained during phase" ^ + (if phases = [] then " " else "s ") ^ + String.concat "," (List.map string_of_int phases) ^": *****\n"^ + msg ^ "\n\n" + in + loc, + "********** DISAMBIGUATION ERRORS: **********\n" ^ + explain (aux 1 ~dummy:true ("",[]) errorll) + | exn -> None, "Uncaught exception: " ^ Printexc.to_string exn + diff --git a/helm/software/matita/matitaExcPp.mli b/helm/software/matita/matitaExcPp.mli new file mode 100644 index 000000000..9d8c7739f --- /dev/null +++ b/helm/software/matita/matitaExcPp.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val to_string: exn -> Token.flocation option * string + diff --git a/helm/software/matita/matitaGtkMisc.ml b/helm/software/matita/matitaGtkMisc.ml new file mode 100644 index 000000000..553406635 --- /dev/null +++ b/helm/software/matita/matitaGtkMisc.ml @@ -0,0 +1,439 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +exception PopupClosed +open Printf + +let wrap_callback f = f + +let connect_button (button: #GButton.button) callback = + ignore (button#connect#clicked (wrap_callback callback)) + +let connect_toggle_button (button: #GButton.toggle_button) callback = + ignore (button#connect#toggled (wrap_callback callback)) + +let connect_menu_item (menu_item: #GMenu.menu_item) callback = + ignore (menu_item#connect#activate (wrap_callback callback)) + +let connect_key (ev:GObj.event_ops) ?(modifiers = []) ?(stop = false) key + callback += + ignore (ev#connect#key_press (fun key' -> + let modifiers' = GdkEvent.Key.state key' in + (match key' with + | key' when GdkEvent.Key.keyval key' = key + && List.for_all (fun m -> List.mem m modifiers') modifiers -> + callback (); + stop + | _ -> false))) + +let toggle_widget_visibility ~(widget: GObj.widget) + ~(check: GMenu.check_menu_item) += + ignore (check#connect#toggled (fun _ -> + if check#active then widget#misc#show () else widget#misc#hide ())) + +let toggle_window_visibility ~(window: GWindow.window) + ~(check: GMenu.check_menu_item) += + ignore (check#connect#toggled (fun _ -> + if check#active then window#show () else window#misc#hide ())); + ignore (window#event#connect#delete (fun _ -> + window#misc#hide (); + check#set_active false; + true)) + +let toggle_win ?(check: GMenu.check_menu_item option) (win: GWindow.window) () = + if win#is_active then win#misc#hide () else win#show (); + match check with + | None -> () + | Some check -> check#set_active (not check#active) + +let toggle_callback ~callback ~(check: GMenu.check_menu_item) = + ignore (check#connect#toggled (fun _ -> callback check#active)) + +let add_key_binding key callback (evbox: GBin.event_box) = + ignore (evbox#event#connect#key_press (function + | key' when GdkEvent.Key.keyval key' = key -> + callback (); + false + | _ -> false)) + +class multiStringListModel ~cols (tree_view: GTree.view) = + let column_list = new GTree.column_list in + let text_columns = + let rec aux = function + | 0 -> [] + | n -> column_list#add Gobject.Data.string :: aux (n - 1) + in + aux cols + in + let list_store = GTree.list_store column_list in + let renderers = + List.map + (fun text_column -> + (GTree.cell_renderer_text [], ["text", text_column])) + text_columns + in + let view_columns = + List.map + (fun renderer -> GTree.view_column ~renderer ()) + renderers + in + object (self) + val text_columns = text_columns + + initializer + tree_view#set_model (Some (list_store :> GTree.model)); + List.iter + (fun view_column -> ignore (tree_view#append_column view_column)) + view_columns + + method list_store = list_store + + method easy_mappend slist = + let tree_iter = list_store#append () in + List.iter2 + (fun s text_column -> + list_store#set ~row:tree_iter ~column:text_column s) + slist text_columns + + method easy_minsert pos s = + let tree_iter = list_store#insert pos in + List.iter2 + (fun s text_column -> + list_store#set ~row:tree_iter ~column:text_column s) + s text_columns + + method easy_mselection () = + List.map + (fun tree_path -> + let iter = list_store#get_iter tree_path in + List.map + (fun text_column -> + list_store#get ~row:iter ~column:text_column) + text_columns) + tree_view#selection#get_selected_rows + end + +class stringListModel (tree_view: GTree.view) = + object (self) + inherit multiStringListModel ~cols:1 tree_view as multi + + method list_store = multi#list_store + + method easy_append s = + multi#easy_mappend [s] + + method easy_insert pos s = + multi#easy_minsert pos [s] + + method easy_selection () = + let m = List.map + (fun tree_path -> + let iter = self#list_store#get_iter tree_path in + List.map + (fun text_column -> + self#list_store#get ~row:iter ~column:text_column) + text_columns) + tree_view#selection#get_selected_rows + in + List.map (function [x] -> x | _ -> assert false) m + end + +class taggedStringListModel ~(tags:(string * GdkPixbuf.pixbuf) list) + (tree_view: GTree.view) += + let column_list = new GTree.column_list in + let tag_column = column_list#add Gobject.Data.gobject in + let text_column = column_list#add Gobject.Data.string in + let list_store = GTree.list_store column_list in + let text_renderer = (GTree.cell_renderer_text [], ["text", text_column]) in + let tag_renderer = (GTree.cell_renderer_pixbuf [], ["pixbuf", tag_column]) in + let text_vcolumn = GTree.view_column ~renderer:text_renderer () in + let tag_vcolumn = GTree.view_column ~renderer:tag_renderer () in + let lookup_pixbuf tag = + try List.assoc tag tags with Not_found -> assert false + in + object (self) + initializer + tree_view#set_model (Some (list_store :> GTree.model)); + ignore (tree_view#append_column tag_vcolumn); + ignore (tree_view#append_column text_vcolumn) + + method list_store = list_store + + method easy_append ~tag s = + let tree_iter = list_store#append () in + list_store#set ~row:tree_iter ~column:text_column s; + list_store#set ~row:tree_iter ~column:tag_column (lookup_pixbuf tag) + + method easy_insert pos ~tag s = + let tree_iter = list_store#insert pos in + list_store#set ~row:tree_iter ~column:text_column s; + list_store#set ~row:tree_iter ~column:tag_column (lookup_pixbuf tag) + + method easy_selection () = + List.map + (fun tree_path -> + let iter = list_store#get_iter tree_path in + list_store#get ~row:iter ~column:text_column) + tree_view#selection#get_selected_rows + end + +class recordModel (tree_view:GTree.view) = + let cols_list = new GTree.column_list in + let text_col = cols_list#add Gobject.Data.string in +(* let combo_col = cols_list#add (Gobject.Data.gobject_by_name "GtkListStore") in *) + let combo_col = cols_list#add Gobject.Data.int in + let toggle_col = cols_list#add Gobject.Data.boolean in + let list_store = GTree.list_store cols_list in + let text_rend = (GTree.cell_renderer_text [], ["text", text_col]) in + let combo_rend = GTree.cell_renderer_combo [] in +(* let combo_rend = (GTree.cell_renderer_combo [], [|+"model", combo_col+|]) in *) + let toggle_rend = + (GTree.cell_renderer_toggle [`ACTIVATABLE true], ["active", toggle_col]) + in + let text_vcol = GTree.view_column ~renderer:text_rend () in + let combo_vcol = GTree.view_column ~renderer:(combo_rend, []) () in + let _ = + combo_vcol#set_cell_data_func combo_rend + (fun _ _ -> + prerr_endline "qui"; + let model, col = + GTree.store_of_list Gobject.Data.string ["a"; "b"; "c"] + in + combo_rend#set_properties [ + `MODEL (Some (model :> GTree.model)); + `TEXT_COLUMN col + ]) + in + let toggle_vcol = GTree.view_column ~renderer:toggle_rend () in + object (self) + initializer + tree_view#set_model (Some (list_store :> GTree.model)); + ignore (tree_view#append_column text_vcol); + ignore (tree_view#append_column combo_vcol); + ignore (tree_view#append_column toggle_vcol) + + method list_store = list_store + + method easy_append s (combo:int) (toggle:bool) = + let tree_iter = list_store#append () in + list_store#set ~row:tree_iter ~column:text_col s; + list_store#set ~row:tree_iter ~column:combo_col combo; + list_store#set ~row:tree_iter ~column:toggle_col toggle + end + +class type gui = + object + method newUriDialog: unit -> MatitaGeneratedGui.uriChoiceDialog + method newRecordDialog: unit -> MatitaGeneratedGui.recordChoiceDialog + method newConfirmationDialog: unit -> MatitaGeneratedGui.confirmationDialog + method newEmptyDialog: unit -> MatitaGeneratedGui.emptyDialog + end + +let popup_message + ~title ~message ~buttons ~callback + ?(message_type=`QUESTION) ?parent ?(use_markup=true) + ?(destroy_with_parent=true) ?(allow_grow=false) ?(allow_shrink=false) + ?icon ?(modal=true) ?(resizable=false) ?screen ?type_hint + ?(position=`CENTER_ON_PARENT) ?wm_name ?wm_class ?border_width ?width + ?height ?(show=true) () += + let m = + GWindow.message_dialog + ~message ~use_markup ~message_type ~buttons ?parent ~destroy_with_parent + ~title ~allow_grow ~allow_shrink ?icon ~modal ~resizable ?screen + ?type_hint ~position ?wm_name ?wm_class ?border_width ?width ?height + ~show () + in + ignore(m#connect#response + ~callback:(fun a -> GMain.Main.quit ();callback a)); + ignore(m#connect#close + ~callback:(fun _ -> GMain.Main.quit ();raise PopupClosed)); + GtkThread.main (); + m#destroy () + +let popup_message_lowlevel + ~title ~message ?(no_separator=true) ~callback ~message_type ~buttons + ?parent ?(destroy_with_parent=true) ?(allow_grow=false) ?(allow_shrink=false) + ?icon ?(modal=true) ?(resizable=false) ?screen ?type_hint + ?(position=`CENTER_ON_PARENT) ?wm_name ?wm_class ?border_width ?width + ?height ?(show=true) () += + let m = + GWindow.dialog + ~no_separator + ?parent ~destroy_with_parent + ~title ~allow_grow ~allow_shrink ?icon ~modal ~resizable ?screen + ?type_hint ~position ?wm_name ?wm_class ?border_width ?width ?height + ~show:false () + in + let stock = + match message_type with + | `WARNING -> `DIALOG_WARNING + | `INFO -> `DIALOG_INFO + | `ERROR ->`DIALOG_ERROR + | `QUESTION -> `DIALOG_QUESTION + in + let image = GMisc.image ~stock ~icon_size:`DIALOG () in + let label = GMisc.label ~markup:message () in + label#set_line_wrap true; + let hbox = GPack.hbox ~spacing:10 () in + hbox#pack ~from:`START ~expand:true ~fill:true (image:>GObj.widget); + hbox#pack ~from:`START ~expand:true ~fill:true (label:>GObj.widget); + m#vbox#pack ~from:`START + ~padding:20 ~expand:true ~fill:true (hbox:>GObj.widget); + List.iter (fun (x, y) -> + m#add_button_stock x y; + if y = `CANCEL then + m#set_default_response y + ) buttons; + ignore(m#connect#response + ~callback:(fun a -> GMain.Main.quit ();callback a)); + ignore(m#connect#close + ~callback:(fun _ -> GMain.Main.quit ();callback `POPUPCLOSED)); + if show = true then + m#show (); + GtkThread.main (); + m#destroy () + + +let ask_confirmation ~title ~message ?parent () = + let rc = ref `YES in + let callback = + function + | `YES -> rc := `YES + | `NO -> rc := `NO + | `CANCEL -> rc := `CANCEL + | `DELETE_EVENT -> rc := `CANCEL + | `POPUPCLOSED -> rc := `CANCEL + in + let buttons = [`YES,`YES ; `NO,`NO ; `CANCEL,`CANCEL] in + popup_message_lowlevel + ~title ~message ~message_type:`WARNING ~callback ~buttons ?parent (); + !rc + +let report_error ~title ~message ?parent () = + let callback _ = () in + let buttons = GWindow.Buttons.ok in + try + popup_message + ~title ~message ~message_type:`ERROR ~callback ~buttons ?parent () + with + | PopupClosed -> () + + +let ask_text ~(gui:#gui) ?(title = "") ?(message = "") ?(multiline = false) + ?default () += + let dialog = gui#newEmptyDialog () in + dialog#emptyDialog#set_title title; + dialog#emptyDialogLabel#set_label message; + let result = ref None in + let return r = + result := r; + dialog#emptyDialog#destroy (); + GMain.Main.quit () + in + ignore (dialog#emptyDialog#event#connect#delete (fun _ -> true)); + if multiline then begin (* multiline input required: use a TextView widget *) + let win = + GBin.scrolled_window ~width:400 ~height:150 ~hpolicy:`NEVER + ~vpolicy:`ALWAYS ~packing:dialog#emptyDialogVBox#add () + in + let view = GText.view ~wrap_mode:`CHAR ~packing:win#add () in + let buffer = view#buffer in + (match default with + | None -> () + | Some text -> + buffer#set_text text; + buffer#select_range buffer#start_iter buffer#end_iter); + view#misc#grab_focus (); + connect_button dialog#emptyDialogOkButton (fun _ -> + return (Some (buffer#get_text ()))) + end else begin (* monoline input required: use a TextEntry widget *) + let entry = GEdit.entry ~packing:dialog#emptyDialogVBox#add () in + (match default with + | None -> () + | Some text -> + entry#set_text text; + entry#select_region ~start:0 ~stop:max_int); + entry#misc#grab_focus (); + connect_button dialog#emptyDialogOkButton (fun _ -> + return (Some entry#text)) + end; + connect_button dialog#emptyDialogCancelButton (fun _ ->return None); + dialog#emptyDialog#show (); + GtkThread.main (); + (match !result with None -> raise MatitaTypes.Cancel | Some r -> r) + +let ask_record_choice ~(gui:#gui) ?(title= "") ?(message = "") + ~fields ~records () += + let fields = Array.of_list fields in + let fields_no = Array.length fields in + assert (fields_no > 0); + let dialog = gui#newRecordDialog () in + dialog#recordChoiceDialog#set_title title; + dialog#recordChoiceDialogLabel#set_label message; + let model = new recordModel dialog#recordChoiceTreeView in + dialog#recordChoiceTreeView#set_headers_visible true; + let combos = + Array.init fields_no + (fun _ -> GTree.store_of_list Gobject.Data.string ["a"; "b"; "c"]) + in + let (store, col) = combos.(0) in + store#set ~row:(store#append ()) ~column:col "uno"; + store#set ~row:(store#append ()) ~column:col "due"; + let toggles = Array.init fields_no (fun _ -> false) in + Array.iteri + (fun i f -> model#easy_append f i toggles.(i)) + fields; + let record_no = ref None in + let return _ = + dialog#recordChoiceDialog#destroy (); + GMain.Main.quit () + in + let fail _ = record_no := None; return () in + ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true)); + connect_button dialog#recordChoiceOkButton (fun _ -> + match !record_no with None -> () | Some _ -> return ()); + connect_button dialog#recordChoiceCancelButton fail; +(* ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ -> + interp_no := Some (model#get_interp_no path); + return ())); + let selection = dialog#recordChoiceTreeView#selection in + ignore (selection#connect#changed (fun _ -> + match selection#get_selected_rows with + | [path] -> interp_no := Some (model#get_interp_no path) + | _ -> assert false)); *) + dialog#recordChoiceDialog#show (); + GtkThread.main (); + (match !record_no with Some n -> n | _ -> raise MatitaTypes.Cancel) + diff --git a/helm/software/matita/matitaGtkMisc.mli b/helm/software/matita/matitaGtkMisc.mli new file mode 100644 index 000000000..1affd2a39 --- /dev/null +++ b/helm/software/matita/matitaGtkMisc.mli @@ -0,0 +1,157 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** {2 Gtk helpers} *) + + (** given a window and a check menu item it links the two so that the former + * is only hidden on delete and the latter toggle show/hide of the former *) +val toggle_window_visibility: + window:GWindow.window -> check:GMenu.check_menu_item -> unit + + (** given a window and a check menu item it links the two so that the former + * is only hidden on delete and the latter toggle show/hide of the former *) +val toggle_widget_visibility: + widget:GObj.widget -> check:GMenu.check_menu_item -> unit + +val toggle_callback: + callback:(bool -> unit) -> check:GMenu.check_menu_item -> unit + +val toggle_win: + ?check:GMenu.check_menu_item -> GWindow.window -> unit -> unit + +val add_key_binding: Gdk.keysym -> (unit -> 'a) -> GBin.event_box -> unit + +(** Connect a callback to the clicked signal of a button, ignoring its return + * value *) +val connect_button: #GButton.button -> (unit -> unit) -> unit + + +(** Connect a callback to the toggled signal of a button, ignoring its return + * value *) +val connect_toggle_button: #GButton.toggle_button -> (unit -> unit) -> unit + +(** Like connect_button above, but connects a callback to the activate signal of + * a menu item *) +val connect_menu_item: #GMenu.menu_item -> (unit -> unit) -> unit + + (** connect a unit -> unit callback to a particular key press event. Event can + * be specified using its keysym and a list of modifiers which must be in + * effect for the callback to be executed. Further signal processing of other + * key press events remains unchanged; further signal processing of the + * specified key press depends on the stop parameter *) +val connect_key: + GObj.event_ops -> + ?modifiers:Gdk.Tags.modifier list -> + ?stop:bool -> (* stop signal handling when the given key has been pressed? + * Defaults to false *) + Gdk.keysym -> (* (= int) the key, see GdkKeysyms.ml *) + (unit -> unit) -> (* callback *) + unit + + (** n-ary string column list *) +class multiStringListModel: + cols:int -> + GTree.view -> + object + method list_store: GTree.list_store (** list_store forwarding *) + + method easy_mappend: string list -> unit (** append + set *) + method easy_minsert: int -> string list -> unit (** insert + set *) + method easy_mselection: unit -> string list list + end + + (** single string column list *) +class stringListModel: + GTree.view -> + object + inherit multiStringListModel + + method easy_append: string -> unit (** append + set *) + method easy_insert: int -> string -> unit (** insert + set *) + method easy_selection: unit -> string list + end + + + (** as above with Pixbuf associated to each row. Each time an insert is + * performed a string tag should be specified, the corresponding pixbuf in the + * tags associative list will be shown on the left of the inserted row *) +class taggedStringListModel: + tags:((string * GdkPixbuf.pixbuf) list) -> + GTree.view -> + object + method list_store: GTree.list_store (** list_store forwarding *) + + method easy_append: tag:string -> string -> unit + method easy_insert: int -> tag:string -> string -> unit + method easy_selection: unit -> string list + end + +(** {2 Matita GUI components} *) + +class type gui = + object (* minimal gui object requirements *) + method newUriDialog: unit -> MatitaGeneratedGui.uriChoiceDialog + method newRecordDialog: unit -> MatitaGeneratedGui.recordChoiceDialog + method newConfirmationDialog: unit -> MatitaGeneratedGui.confirmationDialog + method newEmptyDialog: unit -> MatitaGeneratedGui.emptyDialog + end + + (** {3 Dialogs} + * In functions below: + * @param title window title + * @param message content of the text label shown to the user *) + + (** @param parent to center the window on it *) +val ask_confirmation: + title:string -> message:string -> + ?parent:#GWindow.window_skel -> + unit -> + [`YES | `NO | `CANCEL] + + (** @param multiline (default: false) if true a TextView widget will be used + * for prompting the user otherwise a TextEntry widget will be + * @return the string given by the user *) +val ask_text: + gui:#gui -> + ?title:string -> ?message:string -> + ?multiline:bool -> ?default:string -> unit -> + string + + (** @param fields field names + * @param records list of records, each record is a list of [fields] strings + * @return number of the chosen record, 0 for the first one *) +val ask_record_choice: + gui:#gui -> + ?title:string -> ?message:string -> + fields:string list -> records:string list list -> + unit -> + int + +val report_error: + title:string -> message:string -> + ?parent:#GWindow.window_skel -> + unit -> + unit + diff --git a/helm/software/matita/matitaGui.ml b/helm/software/matita/matitaGui.ml new file mode 100644 index 000000000..ed739eefb --- /dev/null +++ b/helm/software/matita/matitaGui.ml @@ -0,0 +1,1280 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open MatitaGeneratedGui +open MatitaGtkMisc +open MatitaMisc + +exception Found of int + +let gui_instance = ref None + +class type browserWin = + (* this class exists only because GEdit.combo_box_entry is not supported by + * lablgladecc :-(((( *) +object + inherit MatitaGeneratedGui.browserWin + method browserUri: GEdit.combo_box_entry +end + +class console ~(buffer: GText.buffer) () = + object (self) + val error_tag = buffer#create_tag [ `FOREGROUND "red" ] + val warning_tag = buffer#create_tag [ `FOREGROUND "orange" ] + val message_tag = buffer#create_tag [] + val debug_tag = buffer#create_tag [ `FOREGROUND "#888888" ] + method message s = buffer#insert ~iter:buffer#end_iter ~tags:[message_tag] s + method error s = buffer#insert ~iter:buffer#end_iter ~tags:[error_tag] s + method warning s = buffer#insert ~iter:buffer#end_iter ~tags:[warning_tag] s + method debug s = buffer#insert ~iter:buffer#end_iter ~tags:[debug_tag] s + method clear () = + buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter + method log_callback (tag: HLog.log_tag) s = + match tag with + | `Debug -> self#debug (s ^ "\n") + | `Error -> self#error (s ^ "\n") + | `Message -> self#message (s ^ "\n") + | `Warning -> self#warning (s ^ "\n") + end + +let clean_current_baseuri grafite_status = + try + let baseuri = GrafiteTypes.get_string_option grafite_status "baseuri" in + let basedir = Helm_registry.get "matita.basedir" in + LibraryClean.clean_baseuris ~basedir [baseuri] + with GrafiteTypes.Option_error _ -> () + +let ask_and_save_moo_if_needed parent fname lexicon_status grafite_status = + let basedir = Helm_registry.get "matita.basedir" in + let baseuri = DependenciesParser.baseuri_of_script ~include_paths:[] fname in + let moo_fname = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in + let save () = + let metadata_fname = + LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri in + let lexicon_fname = + LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri + in + GrafiteMarshal.save_moo moo_fname + grafite_status.GrafiteTypes.moo_content_rev; + LibraryNoDb.save_metadata metadata_fname + lexicon_status.LexiconEngine.metadata; + LexiconMarshal.save_lexicon lexicon_fname + lexicon_status.LexiconEngine.lexicon_content_rev + in + if (MatitaScript.current ())#eos && + grafite_status.GrafiteTypes.proof_status = GrafiteTypes.No_proof + then + begin + let rc = + MatitaGtkMisc.ask_confirmation + ~title:"A .moo can be generated" + ~message:(Printf.sprintf + "%s can be generated for %s.\nShould I generate it?" + (Filename.basename moo_fname) (Filename.basename fname)) + ~parent () + in + let b = + match rc with + | `YES -> true + | `NO -> false + | `CANCEL -> raise MatitaTypes.Cancel + in + if b then + save () + else + clean_current_baseuri grafite_status + end + else + clean_current_baseuri grafite_status + +let ask_unsaved parent = + MatitaGtkMisc.ask_confirmation + ~parent ~title:"Unsaved work!" + ~message:("Your work is unsaved!\n\n"^ + "Do you want to save the script before continuing?") + () + +(** Selection handling + * Two clipboards are used: "clipboard" and "primary". + * "primary" is used by X, when you hit the middle button mouse is content is + * pasted between applications. In Matita this selection always contain the + * textual version of the selected term. + * "clipboard" is used inside Matita only and support ATM two different targets: + * "TERM" and "PATTERN", in the future other targets like "MATHMLCONTENT" may + * be added + *) + +class gui () = + (* creation order _is_ relevant for windows placement *) + let main = new mainWin () in + let fileSel = new fileSelectionWin () in + let findRepl = new findReplWin () in + let develList = new develListWin () in + let newDevel = new newDevelWin () in + let keyBindingBoxes = (* event boxes which should receive global key events *) + [ main#mainWinEventBox ] + in + let console = new console ~buffer:main#logTextView#buffer () in + let (source_view: GSourceView.source_view) = + GSourceView.source_view + ~auto_indent:true + ~insert_spaces_instead_of_tabs:true ~tabs_width:2 + ~margin:80 ~show_margin:true + ~smart_home_end:true + ~packing:main#scriptScrolledWin#add + () + in + let default_font_size = + Helm_registry.get_opt_default Helm_registry.int + ~default:BuildTimeConf.default_font_size "matita.font_size" + in + let source_buffer = source_view#source_buffer in + object (self) + val mutable chosen_file = None + val mutable _ok_not_exists = false + val mutable _only_directory = false + val mutable script_fname = None + val mutable font_size = default_font_size + val mutable next_devel_must_contain = None + val mutable next_ligatures = [] + val clipboard = GData.clipboard Gdk.Atom.clipboard + val primary = GData.clipboard Gdk.Atom.primary + + initializer + (* glade's check widgets *) + List.iter (fun w -> w#check_widgets ()) + (let c w = (w :> unit>) in + [ c fileSel; c main; c findRepl]); + (* key bindings *) + List.iter (* global key bindings *) + (fun (key, callback) -> self#addKeyBinding key callback) +(* + [ GdkKeysyms._F3, + toggle_win ~check:main#showProofMenuItem proof#proofWin; + GdkKeysyms._F4, + toggle_win ~check:main#showCheckMenuItem check#checkWin; +*) + [ ]; + (* about win *) + let parse_txt_file file = + let ch = open_in (BuildTimeConf.runtime_base_dir ^ "/" ^ file) in + let l_rev = ref [] in + try + while true do + l_rev := input_line ch :: !l_rev; + done; + assert false + with + End_of_file -> + close_in ch; + List.rev !l_rev in + let about_dialog = + GWindow.about_dialog + ~authors:(parse_txt_file "AUTHORS") + (*~comments:"comments"*) + ~copyright:"Copyright (C) 2005, the HELM team" + ~license:(String.concat "\n" (parse_txt_file "LICENSE")) + ~logo:(GdkPixbuf.from_file (MatitaMisc.image_path "/matita_medium.png")) + ~name:"Matita" + ~version:BuildTimeConf.version + ~website:"http://helm.cs.unibo.it" + () + in + connect_menu_item main#aboutMenuItem about_dialog#present; + (* findRepl win *) + let show_find_Repl () = + findRepl#toplevel#misc#show (); + findRepl#toplevel#misc#grab_focus () + in + let hide_find_Repl () = findRepl#toplevel#misc#hide () in + let find_forward _ = + let highlight start end_ = + source_buffer#move_mark `INSERT ~where:start; + source_buffer#move_mark `SEL_BOUND ~where:end_; + source_view#scroll_mark_onscreen `INSERT + in + let text = findRepl#findEntry#text in + let iter = source_buffer#get_iter `SEL_BOUND in + match iter#forward_search text with + | None -> + (match source_buffer#start_iter#forward_search text with + | None -> () + | Some (start,end_) -> highlight start end_) + | Some (start,end_) -> highlight start end_ + in + let replace _ = + let text = findRepl#replaceEntry#text in + let ins = source_buffer#get_iter `INSERT in + let sel = source_buffer#get_iter `SEL_BOUND in + if ins#compare sel < 0 then + begin + ignore(source_buffer#delete_selection ()); + source_buffer#insert text + end + in + connect_button findRepl#findButton find_forward; + connect_button findRepl#findReplButton replace; + connect_button findRepl#cancelButton (fun _ -> hide_find_Repl ()); + ignore(findRepl#toplevel#event#connect#delete + ~callback:(fun _ -> hide_find_Repl ();true)); + let safe_undo = + fun () -> + (* phase 1: we save the actual status of the marks and we undo *) + let locked_mark = `MARK ((MatitaScript.current ())#locked_mark) in + let locked_iter = source_view#buffer#get_iter_at_mark locked_mark in + let locked_iter_offset = locked_iter#offset in + let mark2 = + `MARK + (source_view#buffer#create_mark ~name:"lock_point" + ~left_gravity:true locked_iter) in + source_view#source_buffer#undo (); + (* phase 2: we save the cursor position and we redo, restoring + the previous status of all the marks *) + let cursor_iter = source_view#buffer#get_iter_at_mark `INSERT in + let mark = + `MARK + (source_view#buffer#create_mark ~name:"undo_point" + ~left_gravity:true cursor_iter) + in + source_view#source_buffer#redo (); + let mark_iter = source_view#buffer#get_iter_at_mark mark in + let mark2_iter = source_view#buffer#get_iter_at_mark mark2 in + let mark2_iter = mark2_iter#set_offset locked_iter_offset in + source_view#buffer#move_mark locked_mark ~where:mark2_iter; + source_view#buffer#delete_mark mark; + source_view#buffer#delete_mark mark2; + (* phase 3: if after the undo the cursor was in the locked area, + then we move it there again and we perform a goto *) + if mark_iter#offset < locked_iter_offset then + begin + source_view#buffer#move_mark `INSERT ~where:mark_iter; + (MatitaScript.current ())#goto `Cursor (); + end; + (* phase 4: we perform again the undo. This time we are sure that + the text to undo is not locked *) + source_view#source_buffer#undo (); + source_view#misc#grab_focus () in + let safe_redo = + fun () -> + (* phase 1: we save the actual status of the marks, we redo and + we undo *) + let locked_mark = `MARK ((MatitaScript.current ())#locked_mark) in + let locked_iter = source_view#buffer#get_iter_at_mark locked_mark in + let locked_iter_offset = locked_iter#offset in + let mark2 = + `MARK + (source_view#buffer#create_mark ~name:"lock_point" + ~left_gravity:true locked_iter) in + source_view#source_buffer#redo (); + source_view#source_buffer#undo (); + (* phase 2: we save the cursor position and we restore + the previous status of all the marks *) + let cursor_iter = source_view#buffer#get_iter_at_mark `INSERT in + let mark = + `MARK + (source_view#buffer#create_mark ~name:"undo_point" + ~left_gravity:true cursor_iter) + in + let mark_iter = source_view#buffer#get_iter_at_mark mark in + let mark2_iter = source_view#buffer#get_iter_at_mark mark2 in + let mark2_iter = mark2_iter#set_offset locked_iter_offset in + source_view#buffer#move_mark locked_mark ~where:mark2_iter; + source_view#buffer#delete_mark mark; + source_view#buffer#delete_mark mark2; + (* phase 3: if after the undo the cursor is in the locked area, + then we move it there again and we perform a goto *) + if mark_iter#offset < locked_iter_offset then + begin + source_view#buffer#move_mark `INSERT ~where:mark_iter; + (MatitaScript.current ())#goto `Cursor (); + end; + (* phase 4: we perform again the redo. This time we are sure that + the text to redo is not locked *) + source_view#source_buffer#redo (); + source_view#misc#grab_focus () + in + connect_menu_item main#undoMenuItem safe_undo; + ignore(source_view#source_buffer#connect#can_undo + ~callback:main#undoMenuItem#misc#set_sensitive); + connect_menu_item main#redoMenuItem safe_redo; + ignore(source_view#source_buffer#connect#can_redo + ~callback:main#redoMenuItem#misc#set_sensitive); + ignore(source_view#connect#after#populate_popup + ~callback:(fun pre_menu -> + let menu = new GMenu.menu pre_menu in + let menuItems = menu#children in + let undoMenuItem, redoMenuItem = + match menuItems with + [undo;redo;sep1;cut;copy;paste;delete;sep2; + selectall;sep3;inputmethod;insertunicodecharacter] -> + List.iter menu#remove [ copy; cut; delete; paste ]; + undo,redo + | _ -> assert false in + let add_menu_item = + let i = ref 2 in (* last occupied position *) + fun ?label ?stock () -> + incr i; + GMenu.image_menu_item ?label ?stock ~packing:(menu#insert ~pos:!i) + () + in + let copy = add_menu_item ~stock:`COPY () in + let cut = add_menu_item ~stock:`CUT () in + let delete = add_menu_item ~stock:`DELETE () in + let paste = add_menu_item ~stock:`PASTE () in + let paste_pattern = add_menu_item ~label:"Paste as pattern" () in + copy#misc#set_sensitive self#canCopy; + cut#misc#set_sensitive self#canCut; + delete#misc#set_sensitive self#canDelete; + paste#misc#set_sensitive self#canPaste; + paste_pattern#misc#set_sensitive self#canPastePattern; + connect_menu_item copy self#copy; + connect_menu_item cut self#cut; + connect_menu_item delete self#delete; + connect_menu_item paste self#paste; + connect_menu_item paste_pattern self#pastePattern; + let new_undoMenuItem = + GMenu.image_menu_item + ~image:(GMisc.image ~stock:`UNDO ()) + ~use_mnemonic:true + ~label:"_Undo" + ~packing:(menu#insert ~pos:0) () in + new_undoMenuItem#misc#set_sensitive + (undoMenuItem#misc#get_flag `SENSITIVE); + menu#remove (undoMenuItem :> GMenu.menu_item); + connect_menu_item new_undoMenuItem safe_undo; + let new_redoMenuItem = + GMenu.image_menu_item + ~image:(GMisc.image ~stock:`REDO ()) + ~use_mnemonic:true + ~label:"_Redo" + ~packing:(menu#insert ~pos:1) () in + new_redoMenuItem#misc#set_sensitive + (redoMenuItem#misc#get_flag `SENSITIVE); + menu#remove (redoMenuItem :> GMenu.menu_item); + connect_menu_item new_redoMenuItem safe_redo)); + + connect_menu_item main#editMenu (fun () -> + main#copyMenuItem#misc#set_sensitive self#canCopy; + main#cutMenuItem#misc#set_sensitive self#canCut; + main#deleteMenuItem#misc#set_sensitive self#canDelete; + main#pasteMenuItem#misc#set_sensitive self#canPaste; + main#pastePatternMenuItem#misc#set_sensitive self#canPastePattern); + connect_menu_item main#copyMenuItem self#copy; + connect_menu_item main#cutMenuItem self#cut; + connect_menu_item main#deleteMenuItem self#delete; + connect_menu_item main#pasteMenuItem self#paste; + connect_menu_item main#pastePatternMenuItem self#pastePattern; + connect_menu_item main#selectAllMenuItem (fun () -> + source_buffer#move_mark `INSERT source_buffer#start_iter; + source_buffer#move_mark `SEL_BOUND source_buffer#end_iter); + connect_menu_item main#findReplMenuItem show_find_Repl; + connect_menu_item main#externalEditorMenuItem self#externalEditor; + connect_menu_item main#ligatureButton self#nextLigature; + ignore (findRepl#findEntry#connect#activate find_forward); + (* interface lockers *) + let lock_world _ = + main#buttonsToolbar#misc#set_sensitive false; + develList#buttonsHbox#misc#set_sensitive false; + source_view#set_editable false + in + let unlock_world _ = + main#buttonsToolbar#misc#set_sensitive true; + develList#buttonsHbox#misc#set_sensitive true; + source_view#set_editable true + in + let locker f = + fun () -> + lock_world (); + try f ();unlock_world () with exc -> unlock_world (); raise exc in + let keep_focus f = + fun () -> + try + f (); source_view#misc#grab_focus () + with + exc -> source_view#misc#grab_focus (); raise exc in + (* developments win *) + let model = + new MatitaGtkMisc.multiStringListModel + ~cols:2 develList#developmentsTreeview + in + let refresh_devels_win () = + model#list_store#clear (); + List.iter + (fun (name, root) -> model#easy_mappend [name;root]) + (MatitamakeLib.list_known_developments ()) + in + let get_devel_selected () = + match model#easy_mselection () with + | [[name;_]] -> MatitamakeLib.development_for_name name + | _ -> None + in + let refresh () = + while Glib.Main.pending () do + ignore(Glib.Main.iteration false); + done + in + connect_button develList#newButton + (fun () -> + next_devel_must_contain <- None; + newDevel#toplevel#misc#show()); + connect_button develList#deleteButton + (locker (fun () -> + (match get_devel_selected () with + | None -> () + | Some d -> MatitamakeLib.destroy_development_in_bg refresh d); + refresh_devels_win ())); + connect_button develList#buildButton + (locker (fun () -> + match get_devel_selected () with + | None -> () + | Some d -> + let build = locker + (fun () -> MatitamakeLib.build_development_in_bg refresh d) + in + ignore(build ()))); + connect_button develList#cleanButton + (locker (fun () -> + match get_devel_selected () with + | None -> () + | Some d -> + let clean = locker + (fun () -> MatitamakeLib.clean_development_in_bg refresh d) + in + ignore(clean ()))); + connect_button develList#closeButton + (fun () -> develList#toplevel#misc#hide()); + ignore(develList#toplevel#event#connect#delete + (fun _ -> develList#toplevel#misc#hide();true)); + connect_menu_item main#developmentsMenuItem + (fun () -> refresh_devels_win ();develList#toplevel#misc#show ()); + + (* add development win *) + let check_if_root_contains root = + match next_devel_must_contain with + | None -> true + | Some path -> + let is_prefix_of d1 d2 = + let len1 = String.length d1 in + let len2 = String.length d2 in + if len2 < len1 then + false + else + let pref = String.sub d2 0 len1 in + pref = d1 + in + is_prefix_of root path + in + connect_button newDevel#addButton + (fun () -> + let name = newDevel#nameEntry#text in + let root = newDevel#rootEntry#text in + if check_if_root_contains root then + begin + ignore (MatitamakeLib.initialize_development name root); + refresh_devels_win (); + newDevel#nameEntry#set_text ""; + newDevel#rootEntry#set_text ""; + newDevel#toplevel#misc#hide() + end + else + HLog.error ("The selected root does not contain " ^ + match next_devel_must_contain with + | Some x -> x + | _ -> assert false)); + connect_button newDevel#chooseRootButton + (fun () -> + let path = self#chooseDir () in + match path with + | Some path -> newDevel#rootEntry#set_text path + | None -> ()); + connect_button newDevel#cancelButton + (fun () -> newDevel#toplevel#misc#hide ()); + ignore(newDevel#toplevel#event#connect#delete + (fun _ -> newDevel#toplevel#misc#hide();true)); + + (* file selection win *) + ignore (fileSel#fileSelectionWin#event#connect#delete (fun _ -> true)); + ignore (fileSel#fileSelectionWin#connect#response (fun event -> + let return r = + chosen_file <- r; + fileSel#fileSelectionWin#misc#hide (); + GMain.Main.quit () + in + match event with + | `OK -> + let fname = fileSel#fileSelectionWin#filename in + if Sys.file_exists fname then + begin + if HExtlib.is_regular fname && not (_only_directory) then + return (Some fname) + else if _only_directory && HExtlib.is_dir fname then + return (Some fname) + end + else + begin + if _ok_not_exists then + return (Some fname) + end + | `CANCEL -> return None + | `HELP -> () + | `DELETE_EVENT -> return None)); + (* menus *) + List.iter (fun w -> w#misc#set_sensitive false) [ main#saveMenuItem ]; + (* console *) + let adj = main#logScrolledWin#vadjustment in + ignore (adj#connect#changed + (fun _ -> adj#set_value (adj#upper -. adj#page_size))); + console#message (sprintf "\tMatita version %s\n" BuildTimeConf.version); + (* toolbar *) + let module A = GrafiteAst in + let hole = CicNotationPt.UserInput in + let loc = HExtlib.dummy_floc in + let tac ast _ = + if (MatitaScript.current ())#onGoingProof () then + (MatitaScript.current ())#advance + ~statement:("\n" + ^ GrafiteAstPp.pp_tactical ~term_pp:CicNotationPp.pp_term + ~lazy_term_pp:CicNotationPp.pp_term (A.Tactic (loc, ast))) + () + in + let tac_w_term ast _ = + if (MatitaScript.current ())#onGoingProof () then + let buf = source_buffer in + buf#insert ~iter:(buf#get_iter_at_mark (`NAME "locked")) + ("\n" + ^ GrafiteAstPp.pp_tactic ~term_pp:CicNotationPp.pp_term + ~lazy_term_pp:CicNotationPp.pp_term ast) + in + let tbar = main in + connect_button tbar#introsButton (tac (A.Intros (loc, None, []))); + connect_button tbar#applyButton (tac_w_term (A.Apply (loc, hole))); + connect_button tbar#exactButton (tac_w_term (A.Exact (loc, hole))); + connect_button tbar#elimButton (tac_w_term + (A.Elim (loc, hole, None, None, []))); + connect_button tbar#elimTypeButton (tac_w_term + (A.ElimType (loc, hole, None, None, []))); + connect_button tbar#splitButton (tac (A.Split loc)); + connect_button tbar#leftButton (tac (A.Left loc)); + connect_button tbar#rightButton (tac (A.Right loc)); + connect_button tbar#existsButton (tac (A.Exists loc)); + connect_button tbar#reflexivityButton (tac (A.Reflexivity loc)); + connect_button tbar#symmetryButton (tac (A.Symmetry loc)); + connect_button tbar#transitivityButton + (tac_w_term (A.Transitivity (loc, hole))); + connect_button tbar#assumptionButton (tac (A.Assumption loc)); + connect_button tbar#cutButton (tac_w_term (A.Cut (loc, None, hole))); + connect_button tbar#autoButton (tac (A.Auto (loc,None,None,None,None))); + MatitaGtkMisc.toggle_widget_visibility + ~widget:(main#tacticsButtonsHandlebox :> GObj.widget) + ~check:main#tacticsBarMenuItem; + let module Hr = Helm_registry in + if + not (Hr.get_opt_default Hr.bool ~default:false "matita.tactics_bar") + then + main#tacticsBarMenuItem#set_active false; + MatitaGtkMisc.toggle_callback + ~callback:(function + | true -> main#toplevel#fullscreen () + | false -> main#toplevel#unfullscreen ()) + ~check:main#fullscreenMenuItem; + main#fullscreenMenuItem#set_active false; + (* log *) + HLog.set_log_callback self#console#log_callback; + GtkSignal.user_handler := + (function + | MatitaScript.ActionCancelled -> () + | exn -> + if not (Helm_registry.get_bool "matita.debug") then + let floc, msg = MatitaExcPp.to_string exn in + begin + match floc with + None -> () + | Some floc -> + let (x, y) = HExtlib.loc_of_floc floc in + let script = MatitaScript.current () in + let locked_mark = script#locked_mark in + let error_tag = script#error_tag in + let baseoffset = + (source_buffer#get_iter_at_mark (`MARK locked_mark))#offset in + let x' = baseoffset + x in + let y' = baseoffset + y in + let x_iter = source_buffer#get_iter (`OFFSET x') in + let y_iter = source_buffer#get_iter (`OFFSET y') in + source_buffer#apply_tag error_tag ~start:x_iter ~stop:y_iter; + let id = ref None in + id := Some (source_buffer#connect#changed ~callback:(fun () -> + source_buffer#remove_tag error_tag + ~start:source_buffer#start_iter + ~stop:source_buffer#end_iter; + match !id with + | None -> assert false (* a race condition occurred *) + | Some id -> + (new GObj.gobject_ops source_buffer#as_buffer)#disconnect id)); + source_buffer#place_cursor + (source_buffer#get_iter (`OFFSET x')); + end; + HLog.error msg + else raise exn); + (* script *) + ignore (source_buffer#connect#mark_set (fun _ _ -> next_ligatures <- [])); + let _ = + match GSourceView.source_language_from_file BuildTimeConf.lang_file with + | None -> + HLog.warn (sprintf "can't load language file %s" + BuildTimeConf.lang_file) + | Some matita_lang -> + source_buffer#set_language matita_lang; + source_buffer#set_highlight true + in + let s () = MatitaScript.current () in + let disableSave () = + script_fname <- None; + main#saveMenuItem#misc#set_sensitive false + in + let saveAsScript () = + let script = s () in + match self#chooseFile ~ok_not_exists:true () with + | Some f -> + script#assignFileName f; + script#saveToFile (); + console#message ("'"^f^"' saved.\n"); + self#_enableSaveTo f + | None -> () + in + let saveScript () = + match script_fname with + | None -> saveAsScript () + | Some f -> + (s ())#assignFileName f; + (s ())#saveToFile (); + console#message ("'"^f^"' saved.\n"); + in + let abandon_script () = + let lexicon_status = (s ())#lexicon_status in + let grafite_status = (s ())#grafite_status in + if source_view#buffer#modified then + (match ask_unsaved main#toplevel with + | `YES -> saveScript () + | `NO -> () + | `CANCEL -> raise MatitaTypes.Cancel); + (match script_fname with + | None -> () + | Some fname -> + ask_and_save_moo_if_needed main#toplevel fname + lexicon_status grafite_status); + in + let loadScript () = + let script = s () in + try + match self#chooseFile () with + | Some f -> + abandon_script (); + script#reset (); + script#assignFileName f; + source_view#source_buffer#begin_not_undoable_action (); + script#loadFromFile f; + source_view#source_buffer#end_not_undoable_action (); + console#message ("'"^f^"' loaded.\n"); + self#_enableSaveTo f + | None -> () + with MatitaTypes.Cancel -> () + in + let newScript () = + abandon_script (); + source_view#source_buffer#begin_not_undoable_action (); + (s ())#reset (); + (s ())#template (); + source_view#source_buffer#end_not_undoable_action (); + disableSave (); + script_fname <- None + in + let cursor () = + source_buffer#place_cursor + (source_buffer#get_iter_at_mark (`NAME "locked")) in + let advance _ = (MatitaScript.current ())#advance (); cursor () in + let retract _ = (MatitaScript.current ())#retract (); cursor () in + let top _ = (MatitaScript.current ())#goto `Top (); cursor () in + let bottom _ = (MatitaScript.current ())#goto `Bottom (); cursor () in + let jump _ = (MatitaScript.current ())#goto `Cursor (); cursor () in + let advance = locker (keep_focus advance) in + let retract = locker (keep_focus retract) in + let top = locker (keep_focus top) in + let bottom = locker (keep_focus bottom) in + let jump = locker (keep_focus jump) in + (* quit *) + self#setQuitCallback (fun () -> + let lexicon_status = (MatitaScript.current ())#lexicon_status in + let grafite_status = (MatitaScript.current ())#grafite_status in + if source_view#buffer#modified then + begin + let rc = ask_unsaved main#toplevel in + try + match rc with + | `YES -> saveScript (); + if not source_view#buffer#modified then + begin + (match script_fname with + | None -> () + | Some fname -> + ask_and_save_moo_if_needed main#toplevel + fname lexicon_status grafite_status); + GMain.Main.quit () + end + | `NO -> GMain.Main.quit () + | `CANCEL -> raise MatitaTypes.Cancel + with MatitaTypes.Cancel -> () + end + else + begin + (match script_fname with + | None -> clean_current_baseuri grafite_status; GMain.Main.quit () + | Some fname -> + try + ask_and_save_moo_if_needed main#toplevel fname lexicon_status + grafite_status; + GMain.Main.quit () + with MatitaTypes.Cancel -> ()) + end); + connect_button main#scriptAdvanceButton advance; + connect_button main#scriptRetractButton retract; + connect_button main#scriptTopButton top; + connect_button main#scriptBottomButton bottom; + connect_button main#scriptJumpButton jump; + connect_menu_item main#scriptAdvanceMenuItem advance; + connect_menu_item main#scriptRetractMenuItem retract; + connect_menu_item main#scriptTopMenuItem top; + connect_menu_item main#scriptBottomMenuItem bottom; + connect_menu_item main#scriptJumpMenuItem jump; + connect_menu_item main#openMenuItem loadScript; + connect_menu_item main#saveMenuItem saveScript; + connect_menu_item main#saveAsMenuItem saveAsScript; + connect_menu_item main#newMenuItem newScript; + (* script monospace font stuff *) + self#updateFontSize (); + (* debug menu *) + main#debugMenu#misc#hide (); + (* status bar *) + main#hintLowImage#set_file (image_path "matita-bulb-low.png"); + main#hintMediumImage#set_file (image_path "matita-bulb-medium.png"); + main#hintHighImage#set_file (image_path "matita-bulb-high.png"); + (* focus *) + self#sourceView#misc#grab_focus (); + (* main win dimension *) + let width = Gdk.Screen.width () in + let height = Gdk.Screen.height () in + let main_w = width * 90 / 100 in + let main_h = height * 80 / 100 in + let script_w = main_w * 6 / 10 in + main#toplevel#resize ~width:main_w ~height:main_h; + main#hpaneScriptSequent#set_position script_w; + (* source_view *) + ignore(source_view#connect#after#paste_clipboard + ~callback:(fun () -> (MatitaScript.current ())#clean_dirty_lock)); + (* clean_locked is set to true only "during" a PRIMARY paste + operation (i.e. by clicking with the second mouse button) *) + let clean_locked = ref false in + ignore(source_view#event#connect#button_press + ~callback: + (fun button -> + if GdkEvent.Button.button button = 2 then + clean_locked := true; + false + )); + ignore(source_view#event#connect#button_release + ~callback:(fun button -> clean_locked := false; false)); + ignore(source_view#buffer#connect#after#apply_tag + ~callback:( + fun tag ~start:_ ~stop:_ -> + if !clean_locked && + tag#get_oid = (MatitaScript.current ())#locked_tag#get_oid + then + begin + clean_locked := false; + (MatitaScript.current ())#clean_dirty_lock; + clean_locked := true + end)); + (* math view handling *) + connect_menu_item main#newCicBrowserMenuItem (fun () -> + ignore (MatitaMathView.cicBrowser ())); + connect_menu_item main#increaseFontSizeMenuItem (fun () -> + self#increaseFontSize (); + MatitaMathView.increase_font_size (); + MatitaMathView.update_font_sizes ()); + connect_menu_item main#decreaseFontSizeMenuItem (fun () -> + self#decreaseFontSize (); + MatitaMathView.decrease_font_size (); + MatitaMathView.update_font_sizes ()); + connect_menu_item main#normalFontSizeMenuItem (fun () -> + self#resetFontSize (); + MatitaMathView.reset_font_size (); + MatitaMathView.update_font_sizes ()); + MatitaMathView.reset_font_size (); + + (** selections / clipboards handling *) + + method markupSelected = MatitaMathView.has_selection () + method private textSelected = + (source_buffer#get_iter_at_mark `INSERT)#compare + (source_buffer#get_iter_at_mark `SEL_BOUND) <> 0 + method private somethingSelected = self#markupSelected || self#textSelected + method private markupStored = MatitaMathView.has_clipboard () + method private textStored = clipboard#text <> None + method private somethingStored = self#markupStored || self#textStored + + method canCopy = self#somethingSelected + method canCut = self#textSelected + method canDelete = self#textSelected + method canPaste = self#somethingStored + method canPastePattern = self#markupStored + + method copy () = + if self#textSelected + then begin + MatitaMathView.empty_clipboard (); + source_view#buffer#copy_clipboard clipboard; + end else + MatitaMathView.copy_selection () + method cut () = + source_view#buffer#cut_clipboard clipboard; + MatitaMathView.empty_clipboard () + method delete () = ignore (source_view#buffer#delete_selection ()) + method paste () = + if MatitaMathView.has_clipboard () + then source_view#buffer#insert (MatitaMathView.paste_clipboard `Term) + else source_view#buffer#paste_clipboard clipboard; + (MatitaScript.current ())#clean_dirty_lock + method pastePattern () = + source_view#buffer#insert (MatitaMathView.paste_clipboard `Pattern) + + method private nextLigature () = + let iter = source_buffer#get_iter_at_mark `INSERT in + let write_ligature len s = + source_buffer#delete ~start:iter ~stop:(iter#copy#backward_chars len); + source_buffer#insert ~iter:(source_buffer#get_iter_at_mark `INSERT) s + in + let get_ligature word = + let len = String.length word in + let aux_tex () = + try + for i = len - 1 downto 0 do + if HExtlib.is_alpha word.[i] then () + else + (if word.[i] = '\\' then raise (Found i) else raise (Found ~-1)) + done; + None + with Found i -> + if i = ~-1 then None else Some (String.sub word i (len - i)) + in + let aux_ligature () = + try + for i = len - 1 downto 0 do + if CicNotationLexer.is_ligature_char word.[i] then () + else raise (Found (i+1)) + done; + raise (Found 0) + with + | Found i -> + (try + Some (String.sub word i (len - i)) + with Invalid_argument _ -> None) + in + match aux_tex () with + | Some macro -> macro + | None -> (match aux_ligature () with Some l -> l | None -> word) + in + (match next_ligatures with + | [] -> (* find ligatures and fill next_ligatures, then try again *) + let last_word = + iter#get_slice + ~stop:(iter#copy#backward_find_char Glib.Unichar.isspace) + in + let ligature = get_ligature last_word in + (match CicNotationLexer.lookup_ligatures ligature with + | [] -> () + | hd :: tl -> + write_ligature (String.length ligature) hd; + next_ligatures <- tl @ [ hd ]) + | hd :: tl -> + write_ligature 1 hd; + next_ligatures <- tl @ [ hd ]) + + method private externalEditor () = + let cmd = Helm_registry.get "matita.external_editor" in +(* ZACK uncomment to enable interactive ask of external editor command *) +(* let cmd = + let msg = + "External editor command: +%f will be substitute for the script name, +%p for the cursor position in bytes, +%l for the execution point in bytes." + in + ask_text ~gui:self ~title:"External editor" ~msg ~multiline:false + ~default:(Helm_registry.get "matita.external_editor") () + in *) + let fname = (MatitaScript.current ())#filename in + let slice mark = + source_buffer#start_iter#get_slice + ~stop:(source_buffer#get_iter_at_mark mark) + in + let script = MatitaScript.current () in + let locked = `MARK script#locked_mark in + let string_pos mark = string_of_int (String.length (slice mark)) in + let cursor_pos = string_pos `INSERT in + let locked_pos = string_pos locked in + let cmd = + Pcre.replace ~pat:"%f" ~templ:fname + (Pcre.replace ~pat:"%p" ~templ:cursor_pos + (Pcre.replace ~pat:"%l" ~templ:locked_pos + cmd)) + in + let locked_before = slice locked in + let locked_offset = (source_buffer#get_iter_at_mark locked)#offset in + ignore (Unix.system cmd); + source_buffer#set_text (HExtlib.input_file fname); + let locked_iter = source_buffer#get_iter (`OFFSET locked_offset) in + source_buffer#move_mark locked locked_iter; + source_buffer#apply_tag script#locked_tag + ~start:source_buffer#start_iter ~stop:locked_iter; + let locked_after = slice locked in + let line = ref 0 in + let col = ref 0 in + try + for i = 0 to String.length locked_before - 1 do + if locked_before.[i] <> locked_after.[i] then begin + source_buffer#place_cursor + ~where:(source_buffer#get_iter (`LINEBYTE (!line, !col))); + script#goto `Cursor (); + raise Exit + end else if locked_before.[i] = '\n' then begin + incr line; + col := 0 + end + done + with + | Exit -> () + | Invalid_argument _ -> script#goto `Bottom () + + method loadScript file = + let script = MatitaScript.current () in + script#reset (); + script#assignFileName file; + let content = + if Sys.file_exists file then file + else BuildTimeConf.script_template + in + source_view#source_buffer#begin_not_undoable_action (); + script#loadFromFile content; + source_view#source_buffer#end_not_undoable_action (); + console#message ("'"^file^"' loaded."); + self#_enableSaveTo file + + method setStar name b = + let l = main#scriptLabel in + if b then + l#set_text (name ^ " *") + else + l#set_text (name) + + method private _enableSaveTo file = + script_fname <- Some file; + self#main#saveMenuItem#misc#set_sensitive true + + method console = console + method sourceView: GSourceView.source_view = + (source_view: GSourceView.source_view) + method fileSel = fileSel + method findRepl = findRepl + method main = main + method develList = develList + method newDevel = newDevel + + method newBrowserWin () = + object (self) + inherit browserWin () + val combo = GEdit.combo_box_entry () + initializer + self#check_widgets (); + let combo_widget = combo#coerce in + uriHBox#pack ~from:`END ~fill:true ~expand:true combo_widget; + combo#entry#misc#grab_focus () + method browserUri = combo + end + + method newUriDialog () = + let dialog = new uriChoiceDialog () in + dialog#check_widgets (); + dialog + + method newRecordDialog () = + let dialog = new recordChoiceDialog () in + dialog#check_widgets (); + dialog + + method newConfirmationDialog () = + let dialog = new confirmationDialog () in + dialog#check_widgets (); + dialog + + method newEmptyDialog () = + let dialog = new emptyDialog () in + dialog#check_widgets (); + dialog + + method private addKeyBinding key callback = + List.iter (fun evbox -> add_key_binding key callback evbox) + keyBindingBoxes + + method setQuitCallback callback = + connect_menu_item main#quitMenuItem callback; + ignore (main#toplevel#event#connect#delete + (fun _ -> callback ();true)); + self#addKeyBinding GdkKeysyms._q callback + + method chooseFile ?(ok_not_exists = false) () = + _ok_not_exists <- ok_not_exists; + _only_directory <- false; + fileSel#fileSelectionWin#show (); + GtkThread.main (); + chosen_file + + method private chooseDir ?(ok_not_exists = false) () = + _ok_not_exists <- ok_not_exists; + _only_directory <- true; + fileSel#fileSelectionWin#show (); + GtkThread.main (); + (* we should check that this is a directory *) + chosen_file + + method createDevelopment ~containing = + next_devel_must_contain <- containing; + newDevel#toplevel#misc#show() + + method askText ?(title = "") ?(msg = "") () = + let dialog = new textDialog () in + dialog#textDialog#set_title title; + dialog#textDialogLabel#set_label msg; + let text = ref None in + let return v = + text := v; + dialog#textDialog#destroy (); + GMain.Main.quit () + in + ignore (dialog#textDialog#event#connect#delete (fun _ -> true)); + connect_button dialog#textDialogCancelButton (fun _ -> return None); + connect_button dialog#textDialogOkButton (fun _ -> + let text = dialog#textDialogTextView#buffer#get_text () in + return (Some text)); + dialog#textDialog#show (); + GtkThread.main (); + !text + + method private updateFontSize () = + self#sourceView#misc#modify_font_by_name + (sprintf "%s %d" BuildTimeConf.script_font font_size) + + method increaseFontSize () = + font_size <- font_size + 1; + self#updateFontSize () + + method decreaseFontSize () = + font_size <- font_size - 1; + self#updateFontSize () + + method resetFontSize () = + font_size <- default_font_size; + self#updateFontSize () + + end + +let gui () = + let g = new gui () in + gui_instance := Some g; + MatitaMathView.set_gui g; + g + +let instance = singleton gui + +let non p x = not (p x) + +(* this is a shit and should be changed :-{ *) +let interactive_uri_choice + ?(selection_mode:[`SINGLE|`MULTIPLE] = `MULTIPLE) ?(title = "") + ?(msg = "") ?(nonvars_button = false) ?(hide_uri_entry=false) + ?(hide_try=false) ?(ok_label="_Auto") ?(ok_action:[`SELECT|`AUTO] = `AUTO) + ?copy_cb () + ~id uris += + let gui = instance () in + let nonvars_uris = lazy (List.filter (non UriManager.uri_is_var) uris) in + if (selection_mode <> `SINGLE) && + (Helm_registry.get_bool "matita.auto_disambiguation") + then + Lazy.force nonvars_uris + else begin + let dialog = gui#newUriDialog () in + if hide_uri_entry then + dialog#uriEntryHBox#misc#hide (); + if hide_try then + begin + dialog#uriChoiceSelectedButton#misc#hide (); + dialog#uriChoiceConstantsButton#misc#hide (); + end; + dialog#okLabel#set_label ok_label; + dialog#uriChoiceTreeView#selection#set_mode + (selection_mode :> Gtk.Tags.selection_mode); + let model = new stringListModel dialog#uriChoiceTreeView in + let choices = ref None in + (match copy_cb with + | None -> () + | Some cb -> + dialog#copyButton#misc#show (); + connect_button dialog#copyButton + (fun _ -> + match model#easy_selection () with + | [u] -> (cb u) + | _ -> ())); + dialog#uriChoiceDialog#set_title title; + dialog#uriChoiceLabel#set_text msg; + List.iter model#easy_append (List.map UriManager.string_of_uri uris); + dialog#uriChoiceConstantsButton#misc#set_sensitive nonvars_button; + let return v = + choices := v; + dialog#uriChoiceDialog#destroy (); + GMain.Main.quit () + in + ignore (dialog#uriChoiceDialog#event#connect#delete (fun _ -> true)); + connect_button dialog#uriChoiceConstantsButton (fun _ -> + return (Some (Lazy.force nonvars_uris))); + if ok_action = `AUTO then + connect_button dialog#uriChoiceAutoButton (fun _ -> + Helm_registry.set_bool "matita.auto_disambiguation" true; + return (Some (Lazy.force nonvars_uris))) + else + connect_button dialog#uriChoiceAutoButton (fun _ -> + match model#easy_selection () with + | [] -> () + | uris -> return (Some (List.map UriManager.uri_of_string uris))); + connect_button dialog#uriChoiceSelectedButton (fun _ -> + match model#easy_selection () with + | [] -> () + | uris -> return (Some (List.map UriManager.uri_of_string uris))); + connect_button dialog#uriChoiceAbortButton (fun _ -> return None); + dialog#uriChoiceDialog#show (); + GtkThread.main (); + (match !choices with + | None -> raise MatitaTypes.Cancel + | Some uris -> uris) + end + +class interpModel = + let cols = new GTree.column_list in + let id_col = cols#add Gobject.Data.string in + let dsc_col = cols#add Gobject.Data.string in + let interp_no_col = cols#add Gobject.Data.int in + let tree_store = GTree.tree_store cols in + let id_renderer = GTree.cell_renderer_text [], ["text", id_col] in + let dsc_renderer = GTree.cell_renderer_text [], ["text", dsc_col] in + let id_view_col = GTree.view_column ~renderer:id_renderer () in + let dsc_view_col = GTree.view_column ~renderer:dsc_renderer () in + fun tree_view choices -> + object + initializer + tree_view#set_model (Some (tree_store :> GTree.model)); + ignore (tree_view#append_column id_view_col); + ignore (tree_view#append_column dsc_view_col); + let name_of_interp = + (* try to find a reasonable name for an interpretation *) + let idx = ref 0 in + fun interp -> + try + List.assoc "0" interp + with Not_found -> + incr idx; string_of_int !idx + in + tree_store#clear (); + let idx = ref ~-1 in + List.iter + (fun interp -> + incr idx; + let interp_row = tree_store#append () in + tree_store#set ~row:interp_row ~column:id_col + (name_of_interp interp); + tree_store#set ~row:interp_row ~column:interp_no_col !idx; + List.iter + (fun (id, dsc) -> + let row = tree_store#append ~parent:interp_row () in + tree_store#set ~row ~column:id_col id; + tree_store#set ~row ~column:dsc_col dsc; + tree_store#set ~row ~column:interp_no_col !idx) + interp) + choices + + method get_interp_no tree_path = + let iter = tree_store#get_iter tree_path in + tree_store#get ~row:iter ~column:interp_no_col + end + +let interactive_interp_choice () choices = + let gui = instance () in + assert (choices <> []); + let dialog = gui#newRecordDialog () in + let model = new interpModel dialog#recordChoiceTreeView choices in + dialog#recordChoiceDialog#set_title "Interpretation choice"; + dialog#recordChoiceDialogLabel#set_label "Choose an interpretation:"; + let interp_no = ref None in + let return _ = + dialog#recordChoiceDialog#destroy (); + GMain.Main.quit () + in + let fail _ = interp_no := None; return () in + ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true)); + connect_button dialog#recordChoiceOkButton (fun _ -> + match !interp_no with None -> () | Some _ -> return ()); + connect_button dialog#recordChoiceCancelButton fail; + ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ -> + interp_no := Some (model#get_interp_no path); + return ())); + let selection = dialog#recordChoiceTreeView#selection in + ignore (selection#connect#changed (fun _ -> + match selection#get_selected_rows with + | [path] -> interp_no := Some (model#get_interp_no path) + | _ -> assert false)); + dialog#recordChoiceDialog#show (); + GtkThread.main (); + (match !interp_no with Some row -> [row] | _ -> raise MatitaTypes.Cancel) + +let _ = + (* disambiguator callbacks *) + GrafiteDisambiguator.set_choose_uris_callback (interactive_uri_choice ()); + GrafiteDisambiguator.set_choose_interp_callback (interactive_interp_choice ()); + (* gtk initialization *) + GtkMain.Rc.add_default_file BuildTimeConf.gtkrc_file; (* loads gtk rc *) + GMathView.add_configuration_path BuildTimeConf.gtkmathview_conf; + ignore (GMain.Main.init ()) + diff --git a/helm/software/matita/matitaGui.mli b/helm/software/matita/matitaGui.mli new file mode 100644 index 000000000..8c9064e1d --- /dev/null +++ b/helm/software/matita/matitaGui.mli @@ -0,0 +1,49 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + + (** singleton instance of the gui *) +val instance: unit -> MatitaGuiTypes.gui + + (** {2 Disambiguation callbacks} + * Use singleton gui instance. *) + + (** @param selection_mode selection mode in uri list, default to `MULTIPLE + * @param title window title, defaults to "" + * @param msg message for the user, defaults to "" + * @param nonvars_button enable button to exclude vars?, defaults to false + * @raise MatitaTypes.Cancel *) +val interactive_uri_choice: + ?selection_mode:([`SINGLE|`MULTIPLE]) -> ?title:string -> + ?msg:string -> ?nonvars_button:bool -> + ?hide_uri_entry:bool -> ?hide_try:bool -> ?ok_label:string -> + ?ok_action:[`AUTO|`SELECT] -> + ?copy_cb:(string -> unit) -> unit -> + GrafiteDisambiguator.choose_uris_callback + + (** @raise MatitaTypes.Cancel *) +val interactive_interp_choice: + unit -> + GrafiteDisambiguator.choose_interp_callback + diff --git a/helm/software/matita/matitaGuiTypes.mli b/helm/software/matita/matitaGuiTypes.mli new file mode 100644 index 000000000..1b9d17cad --- /dev/null +++ b/helm/software/matita/matitaGuiTypes.mli @@ -0,0 +1,151 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +class type console = +object + method message: string -> unit + method error: string -> unit + method warning: string -> unit + method debug: string -> unit + method clear: unit -> unit + + method log_callback: HLog.log_callback +end + +class type browserWin = +object + inherit MatitaGeneratedGui.browserWin + method browserUri: GEdit.combo_box_entry +end + +class type gui = +object + method setQuitCallback : (unit -> unit) -> unit + + (** {2 Access to singleton instances of lower-level GTK widgets} *) + + method fileSel : MatitaGeneratedGui.fileSelectionWin + method main : MatitaGeneratedGui.mainWin + method findRepl : MatitaGeneratedGui.findReplWin + method develList: MatitaGeneratedGui.develListWin + method newDevel: MatitaGeneratedGui.newDevelWin +(* method toolbar : MatitaGeneratedGui.toolBarWin *) + + method console: console + method sourceView: GSourceView.source_view + + (** {2 Dialogs instantiation} + * methods below create a new window on each invocation. You should + * remember to destroy windows after use *) + + method newBrowserWin: unit -> browserWin + method newUriDialog: unit -> MatitaGeneratedGui.uriChoiceDialog + method newRecordDialog: unit -> MatitaGeneratedGui.recordChoiceDialog + method newConfirmationDialog: unit -> MatitaGeneratedGui.confirmationDialog + method newEmptyDialog: unit -> MatitaGeneratedGui.emptyDialog + + (** {2 Selections / clipboards handling} *) + + method canCopy: bool + method canCut: bool + method canDelete: bool + method canPaste: bool + method canPastePattern: bool + + method markupSelected: bool + + method copy: unit -> unit + method cut: unit -> unit + method delete: unit -> unit + method paste: unit -> unit + method pastePattern: unit -> unit + + (** {2 Utility methods} *) + + (** ask the used to choose a file with the file chooser + * @param ok_not_exists if set to true returns also non existent files + * (useful for save). Defaults to false *) + method chooseFile: ?ok_not_exists:bool -> unit -> string option + method createDevelopment: containing:string option -> unit + + (** prompt the user for a (multiline) text entry *) + method askText: ?title:string -> ?msg:string -> unit -> string option + + method loadScript: string -> unit + method setStar: string -> bool -> unit + + (** {3 Fonts} *) + method increaseFontSize: unit -> unit + method decreaseFontSize: unit -> unit + method resetFontSize: unit -> unit +end + +type paste_kind = [ `Term | `Pattern ] + + (** multi selection gtkMathView which handle mactions and hyperlinks. Mactions + * are handled internally. Hyperlinks are handled by calling an user provided + * callback *) +class type clickableMathView = +object + inherit GMathViewAux.multi_selection_math_view + + (** set hyperlink callback. None disable hyperlink handling *) + method set_href_callback: (string -> unit) option -> unit + + method has_selection: bool + + (** @raise Failure "no selection" *) + method strings_of_selection: (paste_kind * string) list + + method update_font_size: unit +end + +class type cicMathView = +object + inherit clickableMathView + + (** load a sequent and render it into parent widget *) + method load_sequent: Cic.metasenv -> int -> unit + + method load_object: Cic.obj -> unit +end + +class type sequentsViewer = +object + method reset: unit + method load_logo: unit + method load_logo_with_qed: unit + method load_sequents: GrafiteTypes.incomplete_proof -> unit + method goto_sequent: int -> unit (* to be called _after_ load_sequents *) +end + +class type cicBrowser = +object + method load: MatitaTypes.mathViewer_entry -> unit + (* method loadList: string list -> MatitaTypes.mathViewer_entry -> unit *) + method loadInput: string -> unit + method mathView: clickableMathView +end + diff --git a/helm/software/matita/matitaInit.ml b/helm/software/matita/matitaInit.ml new file mode 100644 index 000000000..53ff6b9d6 --- /dev/null +++ b/helm/software/matita/matitaInit.ml @@ -0,0 +1,242 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +type thingsToInitilaize = + ConfigurationFile | Db | Environment | Getter | Makelib | CmdLine | Registry + +exception FailedToInitialize of thingsToInitilaize + +let wants s l = + List.iter ( + fun item -> + if not (List.exists (fun x -> x = item) l) then + raise (FailedToInitialize item)) + s + +let already_configured s l = + List.for_all (fun item -> List.exists (fun x -> x = item) l) s + +let conffile = ref BuildTimeConf.matita_conf + +let registry_defaults = + [ + "db.nodb", "false"; + "matita.system", "false"; + "matita.debug", "false"; + "matita.external_editor", "gvim -f -c 'go %p' %f"; + "matita.preserve", "false"; + "matita.quiet", "false"; + "matita.profile", "true"; + ] + +let set_registry_values = + List.iter (fun key, value -> Helm_registry.set ~key ~value) + +let fill_registry init_status = + if not (already_configured [ Registry ] init_status) then begin + set_registry_values registry_defaults; + Registry :: init_status + end else + init_status + +let load_configuration init_status = + wants [ Registry ] init_status; + if not (already_configured [ConfigurationFile] init_status) then + begin + Helm_registry.load_from !conffile; + if not (Helm_registry.has "user.name") then begin + let login = (Unix.getpwuid (Unix.getuid ())).Unix.pw_name in + Helm_registry.set "user.name" login + end; + if Helm_registry.get_bool "matita.system" then + Helm_registry.set "user.home" BuildTimeConf.runtime_base_dir; + ConfigurationFile::init_status + end + else + init_status + +let initialize_db init_status = + wants [ ConfigurationFile; CmdLine ] init_status; + if not (already_configured [ Db ] init_status) then + begin + if not (Helm_registry.get_bool "matita.system") then + MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner"); + LibraryDb.create_owner_environment (); + Db::init_status + end + else + init_status + +let initialize_makelib init_status = + wants [ConfigurationFile] init_status; + if not (already_configured [Makelib] init_status) then + begin + MatitamakeLib.initialize (); + Makelib::init_status + end + else + init_status + +let initialize_environment init_status = + wants [ConfigurationFile] init_status; + if not (already_configured [Getter;Environment] init_status) then + begin + Http_getter.init (); + CicEnvironment.set_trust (* environment trust *) + (let trust = + Helm_registry.get_opt_default Helm_registry.get_bool + ~default:true "matita.environment_trust" in + fun _ -> trust); + Getter::Environment::init_status + end + else + init_status + +let status = ref [] + +let usages = Hashtbl.create 11 +let _ = + List.iter + (fun (name, s) -> Hashtbl.replace usages name s) + [ "matitac", + sprintf "MatitaC v%s +Usage: matitac [ OPTION ... ] FILE +Options:" + BuildTimeConf.version; + "matita", + sprintf "Matita v%s +Usage: matita [ OPTION ... ] [ FILE ... ] +Options:" + BuildTimeConf.version; + "cicbrowser", + sprintf + "CIC Browser v%s +Usage: cicbrowser [ URL | WHELP QUERY ] +Options:" + BuildTimeConf.version; + "matitadep", + sprintf "MatitaDep v%s +Usage: matitadep [ OPTION ... ] FILE ... +Options:" + BuildTimeConf.version; + "matitaclean", + sprintf "MatitaClean v%s +Usage: matitaclean all + matitaclean [ (FILE | URI) ... ] +Options:" + BuildTimeConf.version; + ] +let default_usage = + sprintf "Matita v%s\nUsage: matita [ ARG ]\nOptions:" BuildTimeConf.version + +let usage () = + let basename = Filename.basename Sys.argv.(0) in + let usage_key = + try Filename.chop_extension basename with Invalid_argument _ -> basename + in + try Hashtbl.find usages usage_key with Not_found -> default_usage + +let parse_cmdline init_status = + if not (already_configured [CmdLine] init_status) then begin + let includes = ref [ BuildTimeConf.stdlib_dir ] in + let args = ref [] in + let add_l l = fun s -> l := s :: !l in + let arg_spec = + let std_arg_spec = [ + "-I", Arg.String (add_l includes), + (" Adds path to the list of searched paths for the " + ^ "include command"); + "-conffile", Arg.Set_string conffile, + (Printf.sprintf " Read configuration from filename (default: %s)" + BuildTimeConf.matita_conf); + "-q", Arg.Unit (fun () -> Helm_registry.set_bool "matita.quiet" true), + "Turn off verbose compilation"; + "-preserve", + Arg.Unit (fun () -> Helm_registry.set_bool "matita.preserve" true), + "Turns off automatic baseuri cleaning"; + "-nodb", Arg.Unit (fun () -> Helm_registry.set_bool "db.nodb" true), + ("Avoid using external database connection " + ^ "(WARNING: disable many features)"); + "-system", Arg.Unit (fun () -> + Helm_registry.set_bool "matita.system" true), + ("Act on the system library instead of the user one" + ^ "(WARNING: not for the casual user)"); + "-noprofile", + Arg.Unit (fun () -> Helm_registry.set_bool "matita.profile" false), + "Turns off profiling printings"; + ] in + let debug_arg_spec = + if BuildTimeConf.debug then + [ "-debug", + Arg.Unit (fun () -> Helm_registry.set_bool "matita.debug" true), + ("Do not catch top-level exception " + ^ "(useful for backtrace inspection)"); + ] + else [] + in + std_arg_spec @ debug_arg_spec + in + let set_list ~key l = + Helm_registry.set_list Helm_registry.of_string ~key ~value:(List.rev !l) + in + Arg.parse arg_spec (add_l args) (usage ()); + set_list ~key:"matita.includes" includes; + set_list ~key:"matita.args" args; + HExtlib.set_profiling_printings + (fun () -> Helm_registry.get_bool "matita.profile"); + CmdLine :: init_status + end else + init_status + +let die_usage () = + print_endline (usage ()); + exit 1 + +let initialize_all () = + status := + List.fold_left (fun s f -> f s) !status + [ fill_registry; + parse_cmdline; load_configuration; initialize_makelib; + initialize_db; initialize_environment ] +(* initialize_notation + (initialize_environment + (initialize_db + (initialize_makelib + (load_configuration + (parse_cmdline !status))))) *) + +let load_configuration_file () = + status := load_configuration !status + +let parse_cmdline () = + status := parse_cmdline !status + +let fill_registry () = + status := fill_registry !status + diff --git a/helm/software/matita/matitaInit.mli b/helm/software/matita/matitaInit.mli new file mode 100644 index 000000000..63b84b448 --- /dev/null +++ b/helm/software/matita/matitaInit.mli @@ -0,0 +1,38 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + + (** {2 global initialization} *) +val initialize_all: unit -> unit + + (** {2 per-components initialization} *) +val fill_registry: unit -> unit (** fill registry with default values *) +val parse_cmdline: unit -> unit (** parse cmdline setting registry keys *) +val load_configuration_file: unit -> unit + + (** {2 Utilities} *) + + (** die nicely: exit with return code 1 printing usage error message *) +val die_usage: unit -> 'a + diff --git a/helm/software/matita/matitaMathView.ml b/helm/software/matita/matitaMathView.ml new file mode 100644 index 000000000..e2eb22d5b --- /dev/null +++ b/helm/software/matita/matitaMathView.ml @@ -0,0 +1,1107 @@ +(* Copyright (C) 2004-2005, 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/. + *) + +(* $Id$ *) + +open Printf + +open GrafiteTypes +open MatitaGtkMisc +open MatitaGuiTypes + +module Stack = Continuationals.Stack + +(** inherit from this class if you want to access current script *) +class scriptAccessor = +object (self) + method private script = MatitaScript.current () +end + +let cicBrowsers = ref [] +let gui_instance = ref None +let set_gui gui = gui_instance := Some gui +let get_gui () = + match !gui_instance with + | None -> assert false + | Some gui -> gui + +let default_font_size () = + Helm_registry.get_opt_default Helm_registry.int + ~default:BuildTimeConf.default_font_size "matita.font_size" +let current_font_size = ref ~-1 +let increase_font_size () = incr current_font_size +let decrease_font_size () = decr current_font_size +let reset_font_size () = current_font_size := default_font_size () + + (* is there any lablgtk2 constant corresponding to the various mouse + * buttons??? *) +let left_button = 1 +let middle_button = 2 +let right_button = 3 + +let near (x1, y1) (x2, y2) = + let distance = sqrt (((x2 -. x1) ** 2.) +. ((y2 -. y1) ** 2.)) in + (distance < 4.) + +let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink" +let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm" +let href_ds = Gdome.domString "href" +let xref_ds = Gdome.domString "xref" + +let domImpl = Gdome.domImplementation () + + (** Gdome.element of a MathML document whose rendering should be blank. Used + * by cicBrowser to render "about:blank" document *) +let empty_mathml = lazy ( + domImpl#createDocument ~namespaceURI:(Some DomMisc.mathml_ns) + ~qualifiedName:(Gdome.domString "math") ~doctype:None) + +let empty_boxml = lazy ( + domImpl#createDocument ~namespaceURI:(Some DomMisc.boxml_ns) + ~qualifiedName:(Gdome.domString "box") ~doctype:None) + + (** shown for goals closed by side effects *) +let closed_goal_mathml = lazy ( + domImpl#createDocumentFromURI ~uri:BuildTimeConf.closed_xml ()) + +(* ids_to_terms should not be passed here, is just for debugging *) +let find_root_id annobj id ids_to_father_ids ids_to_terms ids_to_inner_types = + let find_parent id ids = + let rec aux id = +(* (prerr_endline (sprintf "id %s = %s" id + (try + CicPp.ppterm (Hashtbl.find ids_to_terms id) + with Not_found -> "NONE"))); *) + if List.mem id ids then Some id + else + (match + (try Hashtbl.find ids_to_father_ids id with Not_found -> None) + with + | None -> None + | Some id' -> aux id') + in + aux id + in + let return_father id ids = + match find_parent id ids with + | None -> assert false + | Some parent_id -> parent_id + in + let mk_ids terms = List.map CicUtil.id_of_annterm terms in + let inner_types = + Hashtbl.fold + (fun _ types acc -> + match types.Cic2acic.annexpected with + None -> types.Cic2acic.annsynthesized :: acc + | Some ty -> ty :: types.Cic2acic.annsynthesized :: acc + ) ids_to_inner_types [] in + match annobj with + | Cic.AConstant (_, _, _, Some bo, ty, _, _) + | Cic.AVariable (_, _, Some bo, ty, _, _) + | Cic.ACurrentProof (_, _, _, _, bo, ty, _, _) -> + return_father id (mk_ids (ty :: bo :: inner_types)) + | Cic.AConstant (_, _, _, None, ty, _, _) + | Cic.AVariable (_, _, None, ty, _, _) -> + return_father id (mk_ids (ty::inner_types)) + | Cic.AInductiveDefinition _ -> + assert false (* TODO *) + + (** @return string content of a dom node having a single text child node, e.g. + * bool *) +let string_of_dom_node node = + match node#get_firstChild with + | None -> "" + | Some node -> + (try + let text = new Gdome.text_of_node node in + text#get_data#to_string + with GdomeInit.DOMCastException _ -> "") + +let name_of_hypothesis = function + | Some (Cic.Name s, _) -> s + | _ -> assert false + +let id_of_node (node: Gdome.element) = + let xref_attr = + node#getAttributeNS ~namespaceURI:helm_ns ~localName:xref_ds in + try + List.hd (HExtlib.split ~sep:' ' xref_attr#to_string) + with Failure _ -> assert false + +type selected_term = + | SelTerm of Cic.term * string option (* term, parent hypothesis (if any) *) + | SelHyp of string * Cic.context (* hypothesis, context *) + +class clickableMathView obj = +let text_width = 80 in +object (self) + inherit GMathViewAux.multi_selection_math_view obj + + val mutable href_callback: (string -> unit) option = None + method set_href_callback f = href_callback <- f + + val mutable _cic_info = None + method private set_cic_info info = _cic_info <- info + method private cic_info = _cic_info + + initializer + self#set_font_size !current_font_size; + ignore (self#connect#selection_changed self#choose_selection_cb); + ignore (self#event#connect#button_press self#button_press_cb); + ignore (self#event#connect#button_release self#button_release_cb); + ignore (self#event#connect#selection_clear self#selection_clear_cb); + ignore (self#coerce#misc#connect#selection_get self#selection_get_cb) + + val mutable button_press_x = -1. + val mutable button_press_y = -1. + val mutable selection_changed = false + + method private selection_get_cb ctxt ~info ~time = + let text = + match ctxt#target with + | "PATTERN" -> self#text_of_selection `Pattern + | "TERM" | _ -> self#text_of_selection `Term + in + match text with + | None -> () + | Some s -> ctxt#return s + + method private text_of_selection fmt = + match self#get_selections with + | [] -> None + | node :: _ -> Some (self#string_of_node ~paste_kind:fmt node) + + method private selection_clear_cb sel_event = + self#remove_selections; + (GData.clipboard Gdk.Atom.clipboard)#clear (); + false + + method private button_press_cb gdk_button = + let button = GdkEvent.Button.button gdk_button in + if button = left_button then begin + button_press_x <- GdkEvent.Button.x gdk_button; + button_press_y <- GdkEvent.Button.y gdk_button; + selection_changed <- false + end else if button = right_button then + self#popup_contextual_menu (GdkEvent.Button.time gdk_button); + false + + (** @return a pattern structure which contains pretty printed terms *) + method private tactic_text_pattern_of_selection = + match self#get_selections with + | [] -> assert false (* this method is invoked only if there's a sel. *) + | node :: _ -> + let id = id_of_node node in + let cic_info, unsh_sequent = self#get_cic_info id in + match self#get_term_by_id cic_info id with + | SelTerm (t, father_hyp) -> + let sequent = self#sequent_of_id ~paste_kind:`Pattern id in + let text = self#string_of_cic_sequent sequent in + (match father_hyp with + | None -> None, [], Some text + | Some hyp_name -> None, [ hyp_name, text ], None) + | SelHyp (hyp_name, _ctxt) -> None, [ hyp_name, "%" ], None + + method private popup_contextual_menu time = + let menu = GMenu.menu () in + let add_menu_item ?(menu = menu) ?stock ?label () = + GMenu.image_menu_item ?stock ?label ~packing:menu#append () in + let check = add_menu_item ~label:"Check" () in + let reductions_menu_item = GMenu.menu_item ~label:"βδιζ-reduce" () in + menu#append reductions_menu_item; + let reductions = GMenu.menu () in + reductions_menu_item#set_submenu reductions; + let normalize = add_menu_item ~menu:reductions ~label:"Normalize" () in + let reduce = add_menu_item ~menu:reductions ~label:"Reduce" () in + let simplify = add_menu_item ~menu:reductions ~label:"Simplify" () in + let whd = add_menu_item ~menu:reductions ~label:"Weak head" () in + menu#append (GMenu.separator_item ()); + let copy = add_menu_item ~stock:`COPY () in + let gui = get_gui () in + List.iter (fun item -> item#misc#set_sensitive gui#canCopy) + [ copy; check; normalize; reduce; simplify; whd ]; + let reduction_action kind () = + let pat = self#tactic_text_pattern_of_selection in + let statement = + let loc = HExtlib.dummy_floc in + "\n" ^ + GrafiteAstPp.pp_executable ~term_pp:(fun s -> s) + ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false) + (GrafiteAst.Tactical (loc, + GrafiteAst.Tactic (loc, GrafiteAst.Reduce (loc, kind, pat)), + Some (GrafiteAst.Semicolon loc))) in + (MatitaScript.current ())#advance ~statement () in + connect_menu_item copy gui#copy; + connect_menu_item normalize (reduction_action `Normalize); + connect_menu_item reduce (reduction_action `Reduce); + connect_menu_item simplify (reduction_action `Simpl); + connect_menu_item whd (reduction_action `Whd); + menu#popup ~button:right_button ~time + + method private button_release_cb gdk_button = + if GdkEvent.Button.button gdk_button = left_button then begin + let button_release_x = GdkEvent.Button.x gdk_button in + let button_release_y = GdkEvent.Button.y gdk_button in + if selection_changed then + () + else (* selection _not_ changed *) + if near (button_press_x, button_press_y) + (button_release_x, button_release_y) + then + let x = int_of_float button_press_x in + let y = int_of_float button_press_y in + (match self#get_element_at x y with + | None -> () + | Some elt -> + let localName = href_ds in + if elt#hasAttributeNS ~namespaceURI:xlink_ns ~localName then + self#invoke_href_callback + (elt#getAttributeNS ~namespaceURI:xlink_ns + ~localName)#to_string + gdk_button + else + ignore (self#action_toggle elt)); + end; + false + + method private invoke_href_callback href_value gdk_button = + let button = GdkEvent.Button.button gdk_button in + if button = left_button then + let time = GdkEvent.Button.time gdk_button in + match href_callback with + | None -> () + | Some f -> + (match HExtlib.split href_value with + | [ uri ] -> f uri + | uris -> + let menu = GMenu.menu () in + List.iter + (fun uri -> + let menu_item = + GMenu.menu_item ~label:uri ~packing:menu#append () in + connect_menu_item menu_item (fun () -> f uri)) + uris; + menu#popup ~button ~time) + + method private choose_selection_cb gdome_elt = + let set_selection elt = + let misc = self#coerce#misc in + self#set_selection (Some elt); + misc#add_selection_target ~target:"STRING" Gdk.Atom.primary; + ignore (misc#grab_selection Gdk.Atom.primary); + in + let rec aux elt = + if (elt#getAttributeNS ~namespaceURI:helm_ns + ~localName:xref_ds)#to_string <> "" + then + set_selection elt + else + try + (match elt#get_parentNode with + | None -> assert false + | Some p -> aux (new Gdome.element_of_node p)) + with GdomeInit.DOMCastException _ -> () + in + (match gdome_elt with + | Some elt when (elt#getAttributeNS ~namespaceURI:xlink_ns + ~localName:href_ds)#to_string <> "" -> + set_selection elt + | Some elt -> aux elt + | None -> self#set_selection None); + selection_changed <- true + + method update_font_size = self#set_font_size !current_font_size + + (** find a term by id from stored CIC infos @return either `Hyp if the id + * correspond to an hypothesis or `Term (cic, hyp) if the id correspond to a + * term. In the latter case hyp is either None (if the term is a subterm of + * the sequent conclusion) or Some hyp_name if the term belongs to an + * hypothesis *) + method private get_term_by_id cic_info id = + let unsh_item, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, _, _ = + cic_info in + let rec find_father_hyp id = + if Hashtbl.mem ids_to_hypotheses id + then Some (name_of_hypothesis (Hashtbl.find ids_to_hypotheses id)) + else + let father_id = + try Hashtbl.find ids_to_father_ids id + with Not_found -> assert false in + match father_id with + | Some id -> find_father_hyp id + | None -> None + in + try + let term = Hashtbl.find ids_to_terms id in + let father_hyp = find_father_hyp id in + SelTerm (term, father_hyp) + with Not_found -> + try + let hyp = Hashtbl.find ids_to_hypotheses id in + let _, context, _ = + match unsh_item with Some seq -> seq | None -> assert false in + let context' = MatitaMisc.list_tl_at hyp context in + SelHyp (name_of_hypothesis hyp, context') + with Not_found -> assert false + + method private find_obj_conclusion id = + match self#cic_info with + | None + | Some (_, _, _, _, _, None) -> assert false + | Some (_, ids_to_terms, _, ids_to_father_ids, ids_to_inner_types, Some annobj) -> + let id = + find_root_id annobj id ids_to_father_ids ids_to_terms ids_to_inner_types + in + (try Hashtbl.find ids_to_terms id with Not_found -> assert false) + + method private string_of_node ~(paste_kind:paste_kind) node = + if node#hasAttributeNS ~namespaceURI:helm_ns ~localName:xref_ds + then + let id = id_of_node node in + self#string_of_cic_sequent (self#sequent_of_id ~paste_kind id) + else string_of_dom_node node + + method private string_of_cic_sequent cic_sequent = + let script = MatitaScript.current () in + let metasenv = + if script#onGoingProof () then script#proofMetasenv else [] in + let _, (acic_sequent, _, _, ids_to_inner_sorts, _) = + Cic2acic.asequent_of_sequent metasenv cic_sequent in + let _, _, _, annterm = acic_sequent in + let ast, ids_to_uris = + TermAcicContent.ast_of_acic ids_to_inner_sorts annterm in + let pped_ast = TermContentPres.pp_ast ast in + let markup = CicNotationPres.render ids_to_uris pped_ast in + BoxPp.render_to_string text_width markup + + method private pattern_of term context unsh_sequent = + let context_len = List.length context in + let _, unsh_context, conclusion = unsh_sequent in + try + (match + List.nth unsh_context (List.length unsh_context - context_len - 1) + with + | None -> assert false (* can't select a restricted hypothesis *) + | Some (name, Cic.Decl ty) -> + ProofEngineHelpers.pattern_of ~term:ty [term] + | Some (name, Cic.Def (bo, _)) -> + ProofEngineHelpers.pattern_of ~term:bo [term]) + with Failure _ | Invalid_argument _ -> + ProofEngineHelpers.pattern_of ~term:conclusion [term] + + method private get_cic_info id = + match self#cic_info with + | Some ((Some unsh_sequent, _, _, _, _, _) as info) -> info, unsh_sequent + | Some ((None, _, _, _, _, _) as info) -> + let t = self#find_obj_conclusion id in + info, (~-1, [], t) (* dummy sequent for obj *) + | None -> assert false + + method private sequent_of_id ~(paste_kind:paste_kind) id = + let cic_info, unsh_sequent = self#get_cic_info id in + let cic_sequent = + match self#get_term_by_id cic_info id with + | SelTerm (t, _father_hyp) -> + let occurrences = + ProofEngineHelpers.locate_in_conjecture t unsh_sequent in + (match occurrences with + | [ context, _t ] -> + (match paste_kind with + | `Term -> ~-1, context, t + | `Pattern -> ~-1, [], self#pattern_of t context unsh_sequent) + | _ -> + HLog.error (sprintf "found %d occurrences while 1 was expected" + (List.length occurrences)); + assert false) (* since it uses physical equality *) + | SelHyp (_name, context) -> ~-1, context, Cic.Rel 1 in + cic_sequent + + method private string_of_selection ~(paste_kind:paste_kind) = + match self#get_selections with + | [] -> None + | node :: _ -> Some (self#string_of_node ~paste_kind node) + + method has_selection = self#get_selections <> [] + + (** @return an associative list format -> string with all possible selection + * formats. Rationale: in order to convert the selection to TERM or PATTERN + * format we need the sequent, the metasenv, ... keeping all of them in a + * closure would be more expensive than keeping their already converted + * forms *) + method strings_of_selection = + try + let misc = self#coerce#misc in + List.iter + (fun target -> misc#add_selection_target ~target Gdk.Atom.clipboard) + [ "TERM"; "PATTERN"; "STRING" ]; + ignore (misc#grab_selection Gdk.Atom.clipboard); + List.map + (fun paste_kind -> + paste_kind, HExtlib.unopt (self#string_of_selection ~paste_kind)) + [ `Term; `Pattern ] + with Failure _ -> failwith "no selection" + +end + +let clickableMathView ?hadjustment ?vadjustment ?font_size ?log_verbosity = + GtkBase.Widget.size_params + ~cont:(OgtkMathViewProps.pack_return (fun p -> + OgtkMathViewProps.set_params + (new clickableMathView (GtkMathViewProps.MathView_GMetaDOM.create p)) + ~font_size:None ~log_verbosity:None)) + [] + +class cicMathView obj = +object (self) + inherit clickableMathView obj + + val mutable current_mathml = None + + method load_sequent metasenv metano = + let sequent = CicUtil.lookup_meta metano metasenv in + let (mathml, unsh_sequent, + (_, (ids_to_terms, ids_to_father_ids, ids_to_hypotheses,_ ))) + = + ApplyTransformation.mml_of_cic_sequent metasenv sequent + in + self#set_cic_info + (Some (Some unsh_sequent, + ids_to_terms, ids_to_hypotheses, ids_to_father_ids, + Hashtbl.create 1, None)); + if BuildTimeConf.debug then begin + let name = "sequent_viewer.xml" in + HLog.debug ("load_sequent: dumping MathML to ./" ^ name); + ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()) + end; + self#load_root ~root:mathml#get_documentElement + + method load_object obj = + let use_diff = false in (* ZACK TODO use XmlDiff when re-rendering? *) + let (mathml, + (annobj, (ids_to_terms, ids_to_father_ids, _, ids_to_hypotheses, _, ids_to_inner_types))) + = + ApplyTransformation.mml_of_cic_object obj + in + self#set_cic_info + (Some (None, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, ids_to_inner_types, Some annobj)); + (match current_mathml with + | Some current_mathml when use_diff -> + self#freeze; + XmlDiff.update_dom ~from:current_mathml mathml; + self#thaw + | _ -> + if BuildTimeConf.debug then begin + let name = "cic_browser.xml" in + HLog.debug ("cic_browser: dumping MathML to ./" ^ name); + ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()) + end; + self#load_root ~root:mathml#get_documentElement; + current_mathml <- Some mathml); +end + +let tab_label meta_markup = + let rec aux = + function + | `Current m -> sprintf "%s" (aux m) + | `Closed m -> sprintf "%s" (aux m) + | `Shift (pos, m) -> sprintf "|%d: %s" pos (aux m) + | `Meta n -> sprintf "?%d" n + in + let markup = aux meta_markup in + (GMisc.label ~markup ~show:true ())#coerce + +let goal_of_switch = function Stack.Open g | Stack.Closed g -> g + +class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () = + object (self) + inherit scriptAccessor + + val mutable pages = 0 + val mutable switch_page_callback = None + val mutable page2goal = [] (* associative list: page no -> goal no *) + val mutable goal2page = [] (* the other way round *) + val mutable goal2win = [] (* associative list: goal no -> scrolled win *) + val mutable _metasenv = [] + val mutable scrolledWin: GBin.scrolled_window option = None + (* scrolled window to which the sequentViewer is currently attached *) + val logo = (GMisc.image + ~file:(MatitaMisc.image_path "matita_medium.png") () + :> GObj.widget) + + val logo_with_qed = (GMisc.image + ~file:(MatitaMisc.image_path "matita_small.png") () + :> GObj.widget) + + method load_logo = + notebook#set_show_tabs false; + notebook#append_page logo + + method load_logo_with_qed = + notebook#set_show_tabs false; + notebook#append_page logo_with_qed + + method reset = + cicMathView#remove_selections; + (match scrolledWin with + | Some w -> + (* removing page from the notebook will destroy all contained widget, + * we do not want the cicMathView to be destroyed as well *) + w#remove cicMathView#coerce; + scrolledWin <- None + | None -> ()); + (match switch_page_callback with + | Some id -> + GtkSignal.disconnect notebook#as_widget id; + switch_page_callback <- None + | None -> ()); + for i = 0 to pages do notebook#remove_page 0 done; + notebook#set_show_tabs true; + pages <- 0; + page2goal <- []; + goal2page <- []; + goal2win <- []; + _metasenv <- []; + self#script#setGoal None + + method load_sequents { proof = (_,metasenv,_,_) as proof; stack = stack } = + _metasenv <- metasenv; + pages <- 0; + let win goal_switch = + let w = + GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS + ~shadow_type:`IN ~show:true () + in + let reparent () = + scrolledWin <- Some w; + match cicMathView#misc#parent with + | None -> w#add cicMathView#coerce + | Some parent -> + let parent = + match cicMathView#misc#parent with + None -> assert false + | Some p -> GContainer.cast_container p + in + parent#remove cicMathView#coerce; + w#add cicMathView#coerce + in + goal2win <- (goal_switch, reparent) :: goal2win; + w#coerce + in + assert ( + let stack_goals = Stack.open_goals stack in + let proof_goals = ProofEngineTypes.goals_of_proof proof in + if + HExtlib.list_uniq (List.sort Pervasives.compare stack_goals) + <> List.sort Pervasives.compare proof_goals + then begin + prerr_endline ("STACK GOALS = " ^ String.concat " " (List.map string_of_int stack_goals)); + prerr_endline ("PROOF GOALS = " ^ String.concat " " (List.map string_of_int proof_goals)); + false + end + else true + ); + let render_switch = + function Stack.Open i ->`Meta i | Stack.Closed i ->`Closed (`Meta i) + in + let page = ref 0 in + let added_goals = ref [] in + (* goals can be duplicated on the tack due to focus, but we should avoid + * multiple labels in the user interface *) + let add_tab markup goal_switch = + let goal = Stack.goal_of_switch goal_switch in + if not (List.mem goal !added_goals) then begin + notebook#append_page ~tab_label:(tab_label markup) (win goal_switch); + page2goal <- (!page, goal_switch) :: page2goal; + goal2page <- (goal_switch, !page) :: goal2page; + incr page; + pages <- pages + 1; + added_goals := goal :: !added_goals + end + in + let add_switch _ _ (_, sw) = add_tab (render_switch sw) sw in + Stack.iter (** populate notebook with tabs *) + ~env:(fun depth tag (pos, sw) -> + let markup = + match depth, pos with + | 0, _ -> `Current (render_switch sw) + | 1, pos when Stack.head_tag stack = `BranchTag -> + `Shift (pos, render_switch sw) + | _ -> render_switch sw + in + add_tab markup sw) + ~cont:add_switch ~todo:add_switch + stack; + switch_page_callback <- + Some (notebook#connect#switch_page ~callback:(fun page -> + let goal_switch = + try List.assoc page page2goal with Not_found -> assert false + in + self#script#setGoal (Some (goal_of_switch goal_switch)); + self#render_page ~page ~goal_switch)) + + method private render_page ~page ~goal_switch = + (match goal_switch with + | Stack.Open goal -> cicMathView#load_sequent _metasenv goal + | Stack.Closed goal -> + let doc = Lazy.force closed_goal_mathml in + cicMathView#load_root ~root:doc#get_documentElement); + (try + cicMathView#set_selection None; + List.assoc goal_switch goal2win () + with Not_found -> assert false) + + method goto_sequent goal = + let goal_switch, page = + try + List.find + (function Stack.Open g, _ | Stack.Closed g, _ -> g = goal) + goal2page + with Not_found -> assert false + in + notebook#goto_page page; + self#render_page page goal_switch + + end + + (** constructors *) + +type 'widget constructor = + ?hadjustment:GData.adjustment -> + ?vadjustment:GData.adjustment -> + ?font_size:int -> + ?log_verbosity:int -> + ?width:int -> + ?height:int -> + ?packing:(GObj.widget -> unit) -> + ?show:bool -> + unit -> + 'widget + +let cicMathView ?hadjustment ?vadjustment ?font_size ?log_verbosity = + GtkBase.Widget.size_params + ~cont:(OgtkMathViewProps.pack_return (fun p -> + OgtkMathViewProps.set_params + (new cicMathView (GtkMathViewProps.MathView_GMetaDOM.create p)) + ~font_size ~log_verbosity)) + [] + +let blank_uri = BuildTimeConf.blank_uri +let current_proof_uri = BuildTimeConf.current_proof_uri + +type term_source = + [ `Ast of CicNotationPt.term + | `Cic of Cic.term * Cic.metasenv + | `String of string + ] + +class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) + () += + let whelp_RE = Pcre.regexp "^\\s*whelp" in + let uri_RE = + Pcre.regexp + "^cic:/([^/]+/)*[^/]+\\.(con|ind|var)(#xpointer\\(\\d+(/\\d+)+\\))?$" + in + let dir_RE = Pcre.regexp "^cic:((/([^/]+/)*[^/]+(/)?)|/|)$" in + let whelp_query_RE = Pcre.regexp "^\\s*whelp\\s+([^\\s]+)\\s+(.*)$" in + let is_whelp txt = Pcre.pmatch ~rex:whelp_RE txt in + let is_uri txt = Pcre.pmatch ~rex:uri_RE txt in + let is_dir txt = Pcre.pmatch ~rex:dir_RE txt in + let gui = get_gui () in + let (win: MatitaGuiTypes.browserWin) = gui#newBrowserWin () in + let queries = ["Locate";"Hint";"Match";"Elim";"Instance"] in + let combo,_ = GEdit.combo_box_text ~strings:queries () in + let activate_combo_query input q = + let q' = String.lowercase q in + let rec aux i = function + | [] -> failwith ("Whelp query '" ^ q ^ "' not found") + | h::_ when String.lowercase h = q' -> i + | _::tl -> aux (i+1) tl + in + combo#set_active (aux 0 queries); + win#queryInputText#set_text input + in + let set_whelp_query txt = + let query, arg = + try + let q = Pcre.extract ~rex:whelp_query_RE txt in + q.(1), q.(2) + with Invalid_argument _ -> failwith "Malformed Whelp query" + in + activate_combo_query arg query + in + let toplevel = win#toplevel in + let mathView = cicMathView ~packing:win#scrolledBrowser#add () in + let fail message = + MatitaGtkMisc.report_error ~title:"Cic browser" ~message + ~parent:toplevel () + in + let tags = + [ "dir", GdkPixbuf.from_file (MatitaMisc.image_path "matita-folder.png"); + "obj", GdkPixbuf.from_file (MatitaMisc.image_path "matita-object.png") ] + in + let handle_error f = + try + f () + with exn -> + if not (Helm_registry.get_bool "matita.debug") then + fail (snd (MatitaExcPp.to_string exn)) + else raise exn + in + let handle_error' f = (fun () -> handle_error (fun () -> f ())) in + let load_easter_egg = lazy ( + win#easterEggImage#set_file (MatitaMisc.image_path "meegg.png")) + in + object (self) + inherit scriptAccessor + + (* Whelp bar queries *) + + initializer + activate_combo_query "" "locate"; + win#whelpBarComboVbox#add combo#coerce; + let start_query () = + let query = String.lowercase (List.nth queries combo#active) in + let input = win#queryInputText#text in + let statement = "whelp " ^ query ^ " " ^ input ^ "." in + (MatitaScript.current ())#advance ~statement () + in + ignore(win#queryInputText#connect#activate ~callback:start_query); + ignore(combo#connect#changed ~callback:start_query); + win#whelpBarImage#set_file (MatitaMisc.image_path "whelp.png"); + win#mathOrListNotebook#set_show_tabs false; + win#browserForwardButton#misc#set_sensitive false; + win#browserBackButton#misc#set_sensitive false; + ignore (win#browserUri#entry#connect#activate (handle_error' (fun () -> + self#loadInput win#browserUri#entry#text))); + ignore (win#browserHomeButton#connect#clicked (handle_error' (fun () -> + self#load (`About `Current_proof)))); + ignore (win#browserRefreshButton#connect#clicked + (handle_error' (self#refresh ~force:true))); + ignore (win#browserBackButton#connect#clicked (handle_error' self#back)); + ignore (win#browserForwardButton#connect#clicked + (handle_error' self#forward)); + ignore (win#toplevel#event#connect#delete (fun _ -> + let my_id = Oo.id self in + cicBrowsers := List.filter (fun b -> Oo.id b <> my_id) !cicBrowsers; + if !cicBrowsers = [] && + Helm_registry.get "matita.mode" = "cicbrowser" + then + GMain.quit (); + false)); + ignore(win#whelpResultTreeview#connect#row_activated + ~callback:(fun _ _ -> + handle_error (fun () -> self#loadInput (self#_getSelectedUri ())))); + mathView#set_href_callback (Some (fun uri -> + handle_error (fun () -> + self#load (`Uri (UriManager.uri_of_string uri))))); + self#_load (`About `Blank); + toplevel#show () + + val mutable current_entry = `About `Blank + + val model = + new MatitaGtkMisc.taggedStringListModel tags win#whelpResultTreeview + + val mutable lastDir = "" (* last loaded "directory" *) + + method mathView = (mathView :> MatitaGuiTypes.clickableMathView) + + method private _getSelectedUri () = + match model#easy_selection () with + | [sel] when is_uri sel -> sel (* absolute URI selected *) +(* | [sel] -> win#browserUri#entry#text ^ sel |+ relative URI selected +| *) + | [sel] -> lastDir ^ sel + | _ -> assert false + + (** history RATIONALE + * + * All operations about history are done using _historyFoo. + * Only toplevel functions (ATM load and loadInput) call _historyAdd. + *) + + method private _historyAdd item = + history#add item; + win#browserBackButton#misc#set_sensitive true; + win#browserForwardButton#misc#set_sensitive false + + method private _historyPrev () = + let item = history#previous in + if history#is_begin then win#browserBackButton#misc#set_sensitive false; + win#browserForwardButton#misc#set_sensitive true; + item + + method private _historyNext () = + let item = history#next in + if history#is_end then win#browserForwardButton#misc#set_sensitive false; + win#browserBackButton#misc#set_sensitive true; + item + + (** notebook RATIONALE + * + * Use only these functions to switch between the tabs + *) + method private _showMath = win#mathOrListNotebook#goto_page 0 + method private _showList = win#mathOrListNotebook#goto_page 1 + + method private back () = + try + self#_load (self#_historyPrev ()) + with MatitaMisc.History_failure -> () + + method private forward () = + try + self#_load (self#_historyNext ()) + with MatitaMisc.History_failure -> () + + (* loads a uri which can be a cic uri or an about:* uri + * @param uri string *) + method private _load ?(force=false) entry = + handle_error (fun () -> + if entry <> current_entry || entry = `About `Current_proof || force then + begin + (match entry with + | `About `Current_proof -> self#home () + | `About `Blank -> self#blank () + | `About `Us -> self#egg () + | `Check term -> self#_loadCheck term + | `Cic (term, metasenv) -> self#_loadTermCic term metasenv + | `Dir dir -> self#_loadDir dir + | `Uri uri -> self#_loadUriManagerUri uri + | `Whelp (query, results) -> + set_whelp_query query; + self#_loadList (List.map (fun r -> "obj", + UriManager.string_of_uri r) results)); + self#setEntry entry + end) + + method private blank () = + self#_showMath; + mathView#load_root (Lazy.force empty_mathml)#get_documentElement + + method private _loadCheck term = + failwith "not implemented _loadCheck"; +(* self#_showMath *) + + method private egg () = + win#mathOrListNotebook#goto_page 2; + Lazy.force load_easter_egg + + method private home () = + self#_showMath; + match self#script#grafite_status.proof_status with + | Proof (uri, metasenv, bo, ty) -> + let name = UriManager.name_of_uri (HExtlib.unopt uri) in + let obj = Cic.CurrentProof (name, metasenv, bo, ty, [], []) in + self#_loadObj obj + | Incomplete_proof { proof = (uri, metasenv, bo, ty) } -> + let name = UriManager.name_of_uri (HExtlib.unopt uri) in + let obj = Cic.CurrentProof (name, metasenv, bo, ty, [], []) in + self#_loadObj obj + | _ -> self#blank () + + (** loads a cic uri from the environment + * @param uri UriManager.uri *) + method private _loadUriManagerUri uri = + let uri = UriManager.strip_xpointer uri in + let (obj, _) = CicEnvironment.get_obj CicUniv.empty_ugraph uri in + self#_loadObj obj + + method private _loadDir dir = + let content = Http_getter.ls dir in + let l = + List.fast_sort + Pervasives.compare + (List.map + (function + | Http_getter_types.Ls_section s -> "dir", s + | Http_getter_types.Ls_object o -> "obj", o.Http_getter_types.uri) + content) + in + lastDir <- dir; + self#_loadList l + + method private setEntry entry = + win#browserUri#entry#set_text (MatitaTypes.string_of_entry entry); + current_entry <- entry + + method private _loadObj obj = + (* showMath must be done _before_ loading the document, since if the + * widget is not mapped (hidden by the notebook) the document is not + * rendered *) + self#_showMath; + mathView#load_object obj + + method private _loadTermCic term metasenv = + let context = self#script#proofContext in + let dummyno = CicMkImplicit.new_meta metasenv [] in + let sequent = (dummyno, context, term) in + mathView#load_sequent (sequent :: metasenv) dummyno; + self#_showMath + + method private _loadList l = + model#list_store#clear (); + List.iter (fun (tag, s) -> model#easy_append ~tag s) l; + self#_showList + + (** { public methods, all must call _load!! } *) + + method load entry = + handle_error (fun () -> self#_load entry; self#_historyAdd entry) + + (** this is what the browser does when you enter a string an hit enter *) + method loadInput txt = + let txt = HExtlib.trim_blanks txt in + let fix_uri txt = + UriManager.string_of_uri + (UriManager.strip_xpointer (UriManager.uri_of_string txt)) + in + if is_whelp txt then begin + set_whelp_query txt; + (MatitaScript.current ())#advance ~statement:(txt ^ ".") () + end else begin + let entry = + match txt with + | txt when is_uri txt -> `Uri (UriManager.uri_of_string (fix_uri txt)) + | txt when is_dir txt -> `Dir (MatitaMisc.normalize_dir txt) + | txt -> + (try + MatitaTypes.entry_of_string txt + with Invalid_argument _ -> + raise + (GrafiteTypes.Command_error(sprintf "unsupported uri: %s" txt))) + in + self#_load entry; + self#_historyAdd entry + end + + (** {2 methods accessing underlying GtkMathView} *) + + method updateFontSize = mathView#set_font_size !current_font_size + + (** {2 methods used by constructor only} *) + + method win = win + method history = history + method currentEntry = current_entry + method refresh ~force () = self#_load ~force current_entry + + end + +let sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) (): + MatitaGuiTypes.sequentsViewer += + new sequentsViewer ~notebook ~cicMathView () + +let cicBrowser () = + let size = BuildTimeConf.browser_history_size in + let rec aux history = + let browser = new cicBrowser_impl ~history () in + let win = browser#win in + ignore (win#browserNewButton#connect#clicked (fun () -> + let history = + new MatitaMisc.browser_history ~memento:history#save size + (`About `Blank) + in + let newBrowser = aux history in + newBrowser#load browser#currentEntry)); +(* + (* attempt (failed) to close windows on CTRL-W ... *) + MatitaGtkMisc.connect_key win#browserWinEventBox#event ~modifiers:[`CONTROL] + GdkKeysyms._W (fun () -> win#toplevel#destroy ()); +*) + cicBrowsers := browser :: !cicBrowsers; + (browser :> MatitaGuiTypes.cicBrowser) + in + let history = new MatitaMisc.browser_history size (`About `Blank) in + aux history + +let default_cicMathView () = cicMathView ~show:true () +let cicMathView_instance = MatitaMisc.singleton default_cicMathView + +let default_sequentsViewer () = + let gui = get_gui () in + let cicMathView = cicMathView_instance () in + sequentsViewer ~notebook:gui#main#sequentsNotebook ~cicMathView () +let sequentsViewer_instance = MatitaMisc.singleton default_sequentsViewer + +let mathViewer () = + object(self) + method private get_browser reuse = + if reuse then + (match !cicBrowsers with + | [] -> cicBrowser () + | b :: _ -> (b :> MatitaGuiTypes.cicBrowser)) + else + (cicBrowser ()) + + method show_entry ?(reuse=false) t = (self#get_browser reuse)#load t + + method show_uri_list ?(reuse=false) ~entry l = + (self#get_browser reuse)#load entry + end + +let refresh_all_browsers () = + List.iter (fun b -> b#refresh ~force:false ()) !cicBrowsers + +let update_font_sizes () = + List.iter (fun b -> b#updateFontSize) !cicBrowsers; + (cicMathView_instance ())#update_font_size + +let get_math_views () = + ((cicMathView_instance ()) :> MatitaGuiTypes.clickableMathView) + :: (List.map (fun b -> b#mathView) !cicBrowsers) + +let find_selection_owner () = + let rec aux = + function + | [] -> raise Not_found + | mv :: tl -> + (match mv#get_selections with + | [] -> aux tl + | sel :: _ -> mv) + in + aux (get_math_views ()) + +let has_selection () = + try ignore (find_selection_owner ()); true + with Not_found -> false + +let math_view_clipboard = ref None (* associative list target -> string *) +let has_clipboard () = !math_view_clipboard <> None +let empty_clipboard () = math_view_clipboard := None + +let copy_selection () = + try + math_view_clipboard := + Some ((find_selection_owner ())#strings_of_selection) + with Not_found -> failwith "no selection" + +let paste_clipboard paste_kind = + match !math_view_clipboard with + | None -> failwith "empty clipboard" + | Some cb -> + (try List.assoc paste_kind cb with Not_found -> assert false) + diff --git a/helm/software/matita/matitaMathView.mli b/helm/software/matita/matitaMathView.mli new file mode 100644 index 000000000..ea0c077d8 --- /dev/null +++ b/helm/software/matita/matitaMathView.mli @@ -0,0 +1,87 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(** {2 Constructors} *) + + (** meta constructor *) +type 'widget constructor = + ?hadjustment:GData.adjustment -> + ?vadjustment:GData.adjustment -> + ?font_size:int -> + ?log_verbosity:int -> + ?width:int -> + ?height:int -> + ?packing:(GObj.widget -> unit) -> + ?show:bool -> + unit -> + 'widget + +val clickableMathView: MatitaGuiTypes.clickableMathView constructor + +val cicMathView: MatitaGuiTypes.cicMathView constructor + +val sequentsViewer: + notebook:GPack.notebook -> + cicMathView:MatitaGuiTypes.cicMathView -> + unit -> + MatitaGuiTypes.sequentsViewer + +val cicBrowser: unit -> MatitaGuiTypes.cicBrowser + +(** {2 MathView wide functions} *) +(* TODO ZACK consider exporting here a single function which return a list of + * MatitaGuiTypes.clickableMathView and act on them externally ... *) + +val increase_font_size: unit -> unit +val decrease_font_size: unit -> unit +val reset_font_size: unit -> unit + +val refresh_all_browsers: unit -> unit (** act on all cicBrowsers *) +val update_font_sizes: unit -> unit + + (** {3 Clipboard & Selection handling} *) + +val has_selection: unit -> bool + + (** fills the clipboard with the current selection + * @raise Failure "no selection" *) +val copy_selection: unit -> unit +val has_clipboard: unit -> bool (** clipboard is not empty *) +val empty_clipboard: unit -> unit (** empty the clipboard *) + + (** @raise Failure "empty clipboard" *) +val paste_clipboard: MatitaGuiTypes.paste_kind -> string + +(** {2 Singleton instances} *) + +val cicMathView_instance: unit -> MatitaGuiTypes.cicMathView +val sequentsViewer_instance: unit -> MatitaGuiTypes.sequentsViewer + +val mathViewer: unit -> MatitaTypes.mathViewer + +(** {2 Initialization} *) + +val set_gui: MatitaGuiTypes.gui -> unit + diff --git a/helm/software/matita/matitaMisc.ml b/helm/software/matita/matitaMisc.ml new file mode 100644 index 000000000..0c4329e55 --- /dev/null +++ b/helm/software/matita/matitaMisc.ml @@ -0,0 +1,152 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +(** Functions "imported" from Http_getter_misc *) + +let normalize_dir = Http_getter_misc.normalize_dir +let strip_suffix = Http_getter_misc.strip_suffix + +let absolute_path file = + if file.[0] = '/' then file else Unix.getcwd () ^ "/" ^ file + +let is_proof_script fname = true (** TODO Zack *) +let is_proof_object fname = true (** TODO Zack *) + +let append_phrase_sep s = + if not (Pcre.pmatch ~pat:(sprintf "%s$" BuildTimeConf.phrase_sep) s) then + s ^ BuildTimeConf.phrase_sep + else + s + +exception History_failure + +type 'a memento = 'a array * int * int * int (* data, hd, tl, cur *) + +class type ['a] history = + object + method add : 'a -> unit + method next : 'a + method previous : 'a + method load: 'a memento -> unit + method save: 'a memento + method is_begin: bool + method is_end: bool + end + +class basic_history (head, tail, cur) = + object + val mutable hd = head (* insertion point *) + val mutable tl = tail (* oldest inserted item *) + val mutable cur = cur (* current item for the history *) + + method is_begin = cur <= tl + method is_end = cur >= hd + end + + +class shell_history size = + let size = size + 1 in + let decr x = let x' = x - 1 in if x' < 0 then size + x' else x' in + let incr x = (x + 1) mod size in + object (self) + val data = Array.create size "" + + inherit basic_history (0, -1 , -1) + + method add s = + data.(hd) <- s; + if tl = -1 then tl <- hd; + hd <- incr hd; + if hd = tl then tl <- incr tl; + cur <- hd + method previous = + if cur = tl then raise History_failure; + cur <- decr cur; + data.(cur) + method next = + if cur = hd then raise History_failure; + cur <- incr cur; + if cur = hd then "" else data.(cur) + method load (data', hd', tl', cur') = + assert (Array.length data = Array.length data'); + hd <- hd'; tl <- tl'; cur <- cur'; + Array.blit data' 0 data 0 (Array.length data') + method save = (Array.copy data, hd, tl, cur) + end + +class ['a] browser_history ?memento size init = + object (self) + initializer match memento with Some m -> self#load m | _ -> () + val data = Array.create size init + + inherit basic_history (0, 0, 0) + + method previous = + if cur = tl then raise History_failure; + cur <- cur - 1; + if cur = ~-1 then cur <- size - 1; + data.(cur) + method next = + if cur = hd then raise History_failure; + cur <- cur + 1; + if cur = size then cur <- 0; + data.(cur) + method add (e:'a) = + if e <> data.(cur) then + begin + cur <- cur + 1; + if cur = size then cur <- 0; + if cur = tl then tl <- tl + 1; + if tl = size then tl <- 0; + hd <- cur; + data.(cur) <- e + end + method load (data', hd', tl', cur') = + assert (Array.length data = Array.length data'); + hd <- hd'; tl <- tl'; cur <- cur'; + Array.blit data' 0 data 0 (Array.length data') + method save = (Array.copy data, hd, tl, cur) + end + +let singleton f = + let instance = lazy (f ()) in + fun () -> Lazy.force instance + +let image_path n = sprintf "%s/%s" BuildTimeConf.images_dir n + +let end_ma_RE = Pcre.regexp "\\.ma$" + +let list_tl_at ?(equality=(==)) e l = + let rec aux = + function + | [] -> raise Not_found + | hd :: tl as l when equality hd e -> l + | hd :: tl -> aux tl + in + aux l diff --git a/helm/software/matita/matitaMisc.mli b/helm/software/matita/matitaMisc.mli new file mode 100644 index 000000000..170a87c9b --- /dev/null +++ b/helm/software/matita/matitaMisc.mli @@ -0,0 +1,75 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val absolute_path: string -> string + + (** @return true if file is a (textual) proof script *) +val is_proof_script: string -> bool + + (** @return true if file is a (binary) proof object *) +val is_proof_object: string -> bool + + (** given a phrase, if it doesn't end with BuildTimeConf.phrase_sep, append + * it *) +val append_phrase_sep: string -> string + +val normalize_dir: string -> string (** add trailing "/" if missing *) +val strip_suffix: suffix:string -> string -> string + + (** @return tl tail of a list starting at a given element + * @param eq equality to be used, defaults to physical equality (==) + * @raise Not_found *) +val list_tl_at: ?equality:('a -> 'a -> bool) -> 'a -> 'a list -> 'a list + +exception History_failure + +type 'a memento + +class type ['a] history = + object ('b) + method add : 'a -> unit + method next : 'a (** @raise History_failure *) + method previous : 'a (** @raise History_failure *) + method load: 'a memento -> unit + method save: 'a memento + method is_begin: bool + method is_end: bool + end + + (** shell like history: new items added at the end of the history + * @param size maximum history size *) +class shell_history : int -> [string] history + + (** browser like history: new items added at the current point of the history + * @param size maximum history size + * @param first element in history (this history is never empty) *) +class ['a] browser_history: ?memento:'a memento -> int -> 'a -> ['a] history + + (** create a singleton from a given function. Given function is invoked the + * first time it gets called. Next invocation will return first value *) +val singleton: (unit -> 'a) -> (unit -> 'a) + + (** given the base name of an image, returns its full path *) +val image_path: string -> string diff --git a/helm/software/matita/matitaScript.ml b/helm/software/matita/matitaScript.ml new file mode 100644 index 000000000..188726d95 --- /dev/null +++ b/helm/software/matita/matitaScript.ml @@ -0,0 +1,830 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf +open GrafiteTypes + +module TA = GrafiteAst + +let debug = false +let debug_print = if debug then prerr_endline else ignore + + (** raised when one of the script margins (top or bottom) is reached *) +exception Margin +exception NoUnfinishedProof +exception ActionCancelled + +let safe_substring s i j = + try String.sub s i j with Invalid_argument _ -> assert false + +let heading_nl_RE = Pcre.regexp "^\\s*\n\\s*" +let heading_nl_RE' = Pcre.regexp "^(\\s*\n\\s*)((.|\n)*)" +let only_dust_RE = Pcre.regexp "^(\\s|\n|%%[^\n]*\n)*$" +let multiline_RE = Pcre.regexp "^\n[^\n]+$" +let newline_RE = Pcre.regexp "\n" + +let comment str = + if Pcre.pmatch ~rex:multiline_RE str then + "\n(** " ^ (Pcre.replace ~rex:newline_RE str) ^ " *)" + else + "\n(**\n" ^ str ^ "\n*)" + +let first_line s = + let s = Pcre.replace ~rex:heading_nl_RE s in + try + let nl_pos = String.index s '\n' in + String.sub s 0 nl_pos + with Not_found -> s + + (** creates a statement AST for the Goal tactic, e.g. "goal 7" *) +let goal_ast n = + let module A = GrafiteAst in + let loc = HExtlib.dummy_floc in + A.Executable (loc, A.Tactical (loc, + A.Tactic (loc, A.Goal (loc, n)), + Some (A.Dot loc))) + +type guistuff = { + mathviewer:MatitaTypes.mathViewer; + urichooser: UriManager.uri list -> UriManager.uri list; + ask_confirmation: title:string -> message:string -> [`YES | `NO | `CANCEL]; + develcreator: containing:string option -> unit; + mutable filenamedata: string option * MatitamakeLib.development option +} + +let eval_with_engine guistuff lexicon_status grafite_status user_goal + parsed_text st += + let module TAPp = GrafiteAstPp in + let parsed_text_length = String.length parsed_text in + let initial_space,parsed_text = + try + let pieces = Pcre.extract ~rex:heading_nl_RE' parsed_text in + pieces.(1), pieces.(2) + with + Not_found -> "", parsed_text in + let inital_space,new_grafite_status,new_lexicon_status,new_status_and_text_list' = + (* the code commented out adds the "select" command if needed *) + initial_space,grafite_status,lexicon_status,[] in +(* let loc, ex = + match st with TA.Executable (loc,ex) -> loc, ex | _ -> assert false in + match grafite_status.proof_status with + | Incomplete_proof { stack = stack } + when not (List.mem user_goal (Continuationals.head_goals stack)) -> + let grafite_status = + MatitaEngine.eval_ast + ~do_heavy_checks:true grafite_status (goal_ast user_goal) + in + let initial_space = if initial_space = "" then "\n" else initial_space + in + "\n", grafite_status, + [ grafite_status, + initial_space ^ TAPp.pp_tactical (TA.Select (loc, [user_goal])) ] + | _ -> initial_space,grafite_status,[] in *) + let enriched_history_fragment = + MatitaEngine.eval_ast ~do_heavy_checks:true + new_lexicon_status new_grafite_status st + in + let _,new_text_list_rev = + let module DTE = DisambiguateTypes.Environment in + let module UM = UriManager in + List.fold_right ( + fun (_,alias) (initial_space,acc) -> + match alias with + None -> initial_space,initial_space::acc + | Some (k,((v,_) as value)) -> + let new_text = + let initial_space = + if initial_space = "" then "\n" else initial_space + in + initial_space ^ + DisambiguatePp.pp_environment + (DisambiguateTypes.Environment.add k value + DisambiguateTypes.Environment.empty) + in + "\n",new_text::acc + ) enriched_history_fragment (initial_space,[]) in + let new_text_list_rev = + match enriched_history_fragment,new_text_list_rev with + (_,None)::_, initial_space::tl -> (initial_space ^ parsed_text)::tl + | _,_ -> assert false + in + let res = + try + List.combine (fst (List.split enriched_history_fragment)) new_text_list_rev + with + Invalid_argument _ -> assert false + in + res,parsed_text_length + +let wrap_with_developments guistuff f arg = + try + f arg + with + | DependenciesParser.UnableToInclude what + | LexiconEngine.IncludedFileNotCompiled what + | GrafiteEngine.IncludedFileNotCompiled what as exc -> + let compile_needed_and_go_on d = + let target = Pcre.replace ~pat:"lexicon$" ~templ:"moo" what in + let refresh_cb () = + while Glib.Main.pending () do ignore(Glib.Main.iteration false); done + in + if not(MatitamakeLib.build_development_in_bg ~target refresh_cb d) then + raise exc + else + f arg + in + let do_nothing () = raise ActionCancelled in + let handle_with_devel d = + let name = MatitamakeLib.name_for_development d in + let title = "Unable to include " ^ what in + let message = + what ^ " is handled by development " ^ name ^ ".\n\n" ^ + "Should I compile it and Its dependencies?" + in + (match guistuff.ask_confirmation ~title ~message with + | `YES -> compile_needed_and_go_on d + | `NO -> raise exc + | `CANCEL -> do_nothing ()) + in + let handle_without_devel filename = + let title = "Unable to include " ^ what in + let message = + what ^ " is not handled by a development.\n" ^ + "All dependencies are automatically solved for a development.\n\n" ^ + "Do you want to set up a development?" + in + (match guistuff.ask_confirmation ~title ~message with + | `YES -> + (match filename with + | Some f -> + guistuff.develcreator ~containing:(Some (Filename.dirname f)) + | None -> guistuff.develcreator ~containing:None); + do_nothing () + | `NO -> raise exc + | `CANCEL -> do_nothing()) + in + match guistuff.filenamedata with + | None,None -> handle_without_devel None + | None,Some d -> handle_with_devel d + | Some f,_ -> + match MatitamakeLib.development_for_dir (Filename.dirname f) with + | None -> handle_without_devel (Some f) + | Some d -> handle_with_devel d +;; + +let eval_with_engine + guistuff lexicon_status grafite_status user_goal parsed_text st += + wrap_with_developments guistuff + (eval_with_engine + guistuff lexicon_status grafite_status user_goal parsed_text) st +;; + +let pp_eager_statement_ast = + GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term + ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false) + +let rec eval_macro include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script mac = + let module TAPp = GrafiteAstPp in + let module MQ = MetadataQuery in + let module MDB = LibraryDb in + let module CTC = CicTypeChecker in + let module CU = CicUniv in + (* no idea why ocaml wants this *) + let parsed_text_length = String.length parsed_text in + let dbd = LibraryDb.instance () in + (* XXX use a real CIC -> string pretty printer *) + let pp_macro = TAPp.pp_macro ~term_pp:CicPp.ppterm in + match mac with + (* WHELP's stuff *) + | TA.WMatch (loc, term) -> + let l = Whelp.match_term ~dbd term in + let query_url = + MatitaMisc.strip_suffix ~suffix:"." + (HExtlib.trim_blanks unparsed_text) + in + let entry = `Whelp (query_url, l) in + guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WInstance (loc, term) -> + let l = Whelp.instance ~dbd term in + let entry = `Whelp (pp_macro (TA.WInstance (loc, term)), l) in + guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WLocate (loc, s) -> + let l = Whelp.locate ~dbd s in + let entry = `Whelp (pp_macro (TA.WLocate (loc, s)), l) in + guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WElim (loc, term) -> + let uri = + match term with + | Cic.MutInd (uri,n,_) -> UriManager.uri_of_uriref uri n None + | _ -> failwith "Not a MutInd" + in + let l = Whelp.elim ~dbd uri in + let entry = `Whelp (pp_macro (TA.WElim (loc, term)), l) in + guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + | TA.WHint (loc, term) -> + let s = ((None,[0,[],term], Cic.Meta (0,[]) ,term),0) in + let l = List.map fst (MQ.experimental_hint ~dbd s) in + let entry = `Whelp (pp_macro (TA.WHint (loc, term)), l) in + guistuff.mathviewer#show_uri_list ~reuse:true ~entry l; + [], parsed_text_length + (* REAL macro *) + | TA.Hint loc -> + let user_goal' = + match user_goal with + Some n -> n + | None -> raise NoUnfinishedProof + in + let proof = GrafiteTypes.get_current_proof grafite_status in + let proof_status = proof,user_goal' in + let l = List.map fst (MQ.experimental_hint ~dbd proof_status) in + let selected = guistuff.urichooser l in + (match selected with + | [] -> [], parsed_text_length + | [uri] -> + let suri = UriManager.string_of_uri uri in + let ast loc = + TA.Executable (loc, (TA.Tactical (loc, + TA.Tactic (loc, + TA.Apply (loc, CicNotationPt.Uri (suri, None))), + Some (TA.Dot loc)))) in + let text = + comment parsed_text ^ "\n" ^ + pp_eager_statement_ast (ast HExtlib.dummy_floc) in + let text_len = String.length text in + let loc = HExtlib.floc_of_loc (0,text_len) in + let statement = `Ast (GrafiteParser.LSome (ast loc),text) in + let res,_parsed_text_len = + eval_statement include_paths buffer guistuff lexicon_status + grafite_status user_goal script statement + in + (* we need to replace all the parsed_text *) + res,String.length parsed_text + | _ -> + HLog.error + "The result of the urichooser should be only 1 uri, not:\n"; + List.iter ( + fun u -> HLog.error (UriManager.string_of_uri u ^ "\n") + ) selected; + assert false) + | TA.Check (_,term) -> + let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in + let context = + match user_goal with + None -> [] + | Some n -> GrafiteTypes.get_proof_context grafite_status n in + let ty,_ = CTC.type_of_aux' metasenv context term CicUniv.empty_ugraph in + let t_and_ty = Cic.Cast (term,ty) in + guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv)); + [], parsed_text_length + (* TODO *) + | TA.Quit _ -> failwith "not implemented" + | TA.Print (_,kind) -> failwith "not implemented" + | TA.Search_pat (_, search_kind, str) -> failwith "not implemented" + | TA.Search_term (_, search_kind, term) -> failwith "not implemented" + +and eval_executable include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script loc ex += + let module TAPp = GrafiteAstPp in + let module MD = GrafiteDisambiguator in + let module ML = MatitaMisc in + try + begin + match ex with + | TA.Command (_,TA.Set (_,"baseuri",u)) -> + if not (GrafiteMisc.is_empty u) then + (match + guistuff.ask_confirmation + ~title:"Baseuri redefinition" + ~message:( + "Baseuri " ^ u ^ " already exists.\n" ^ + "Do you want to redefine the corresponding "^ + "part of the library?") + with + | `YES -> + let basedir = Helm_registry.get "matita.basedir" in + LibraryClean.clean_baseuris ~basedir [u] + | `NO -> () + | `CANCEL -> raise MatitaTypes.Cancel) + | _ -> () + end; + eval_with_engine + guistuff lexicon_status grafite_status user_goal parsed_text + (TA.Executable (loc, ex)) + with + MatitaTypes.Cancel -> [], 0 + | GrafiteEngine.Macro (_loc,lazy_macro) -> + let context = + match user_goal with + None -> [] + | Some n -> GrafiteTypes.get_proof_context grafite_status n in + let grafite_status,macro = lazy_macro context in + eval_macro include_paths buffer guistuff lexicon_status grafite_status + user_goal unparsed_text parsed_text script macro + +and eval_statement include_paths (buffer : GText.buffer) guistuff lexicon_status + grafite_status user_goal script statement += + let (lexicon_status,st), unparsed_text = + match statement with + | `Raw text -> + if Pcre.pmatch ~rex:only_dust_RE text then raise Margin; + let ast = + wrap_with_developments guistuff + (GrafiteParser.parse_statement + (Ulexing.from_utf8_string text) ~include_paths) lexicon_status + in + ast, text + | `Ast (st, text) -> (lexicon_status, st), text + in + let text_of_loc loc = + let parsed_text_length = snd (HExtlib.loc_of_floc loc) in + let parsed_text = safe_substring unparsed_text 0 parsed_text_length in + parsed_text, parsed_text_length + in + match st with + | GrafiteParser.LNone loc -> + let parsed_text, parsed_text_length = text_of_loc loc in + [(grafite_status,lexicon_status),parsed_text], + parsed_text_length + | GrafiteParser.LSome (GrafiteAst.Comment (loc, _)) -> + let parsed_text, parsed_text_length = text_of_loc loc in + let remain_len = String.length unparsed_text - parsed_text_length in + let s = String.sub unparsed_text parsed_text_length remain_len in + let s,len = + try + eval_statement include_paths buffer guistuff lexicon_status + grafite_status user_goal script (`Raw s) + with + HExtlib.Localized (floc, exn) -> + HExtlib.raise_localized_exception ~offset:parsed_text_length floc exn + | GrafiteDisambiguator.DisambiguationError (offset,errorll) -> + raise + (GrafiteDisambiguator.DisambiguationError + (offset+parsed_text_length, errorll)) + in + (match s with + | (statuses,text)::tl -> + (statuses,parsed_text ^ text)::tl,parsed_text_length + len + | [] -> [], 0) + | GrafiteParser.LSome (GrafiteAst.Executable (loc, ex)) -> + let parsed_text, parsed_text_length = text_of_loc loc in + eval_executable include_paths buffer guistuff lexicon_status + grafite_status user_goal unparsed_text parsed_text script loc ex + +let fresh_script_id = + let i = ref 0 in + fun () -> incr i; !i + +class script ~(source_view: GSourceView.source_view) + ~(mathviewer: MatitaTypes.mathViewer) + ~set_star + ~ask_confirmation + ~urichooser + ~develcreator + () = +let buffer = source_view#buffer in +let source_buffer = source_view#source_buffer in +let initial_statuses = + (* these include_paths are used only to load the initial notation *) + let include_paths = + Helm_registry.get_list Helm_registry.string "matita.includes" in + let lexicon_status = + CicNotation2.load_notation ~include_paths + BuildTimeConf.core_notation_script in + let grafite_status = GrafiteSync.init () in + grafite_status,lexicon_status +in +object (self) + val mutable include_paths = + Helm_registry.get_list Helm_registry.string "matita.includes" + + val scriptId = fresh_script_id () + + val guistuff = { + mathviewer = mathviewer; + urichooser = urichooser; + ask_confirmation = ask_confirmation; + develcreator = develcreator; + filenamedata = (None, None)} + + method private getFilename = + match guistuff.filenamedata with Some f,_ -> f | _ -> assert false + + method filename = self#getFilename + + method private ppFilename = + match guistuff.filenamedata with + | Some f,_ -> f + | None,_ -> sprintf ".unnamed%d.ma" scriptId + + initializer + ignore (GMain.Timeout.add ~ms:300000 + ~callback:(fun _ -> self#_saveToBackupFile ();true)); + ignore (buffer#connect#modified_changed + (fun _ -> set_star (Filename.basename self#ppFilename) buffer#modified)) + + val mutable statements = [] (** executed statements *) + + val mutable history = [ initial_statuses ] + (** list of states before having executed statements. Head element of this + * list is the current state, last element is the state at the beginning of + * the script. + * Invariant: this list length is 1 + length of statements *) + + (** goal as seen by the user (i.e. metano corresponding to current tab) *) + val mutable userGoal = None + + (** text mark and tag representing locked part of a script *) + val locked_mark = + buffer#create_mark ~name:"locked" ~left_gravity:true buffer#start_iter + val locked_tag = buffer#create_tag [`BACKGROUND "lightblue"; `EDITABLE false] + val error_tag = buffer#create_tag [`UNDERLINE `SINGLE; `FOREGROUND "red"] + + method locked_mark = locked_mark + method locked_tag = locked_tag + method error_tag = error_tag + + (* history can't be empty, the invariant above grant that it contains at + * least the init grafite_status *) + method grafite_status = match history with (s,_)::_ -> s | _ -> assert false + method lexicon_status = match history with (_,ss)::_ -> ss | _ -> assert false + + method private _advance ?statement () = + let s = match statement with Some s -> s | None -> self#getFuture in + HLog.debug ("evaluating: " ^ first_line s ^ " ..."); + let (entries, parsed_len) = + try + eval_statement include_paths buffer guistuff self#lexicon_status + self#grafite_status userGoal self (`Raw s) + with End_of_file -> raise Margin + in + let new_statuses, new_statements = + let statuses, texts = List.split entries in + statuses, texts + in + history <- new_statuses @ history; + statements <- new_statements @ statements; + let start = buffer#get_iter_at_mark (`MARK locked_mark) in + let new_text = String.concat "" (List.rev new_statements) in + if statement <> None then + buffer#insert ~iter:start new_text + else begin + if new_text <> String.sub s 0 parsed_len then begin + buffer#delete ~start ~stop:(start#copy#forward_chars parsed_len); + buffer#insert ~iter:start new_text; + end; + end; + self#moveMark (String.length new_text); + (* here we need to set the Goal in case we are going to cursor (or to + bottom) and we will face a macro *) + match self#grafite_status.proof_status with + Incomplete_proof p -> + userGoal <- + (try Some (Continuationals.Stack.find_goal p.stack) + with Failure _ -> None) + | _ -> userGoal <- None + + method private _retract offset lexicon_status grafite_status new_statements + new_history + = + let cur_grafite_status,cur_lexicon_status = + match history with s::_ -> s | [] -> assert false + in + LexiconSync.time_travel ~present:cur_lexicon_status ~past:lexicon_status; + GrafiteSync.time_travel ~present:cur_grafite_status ~past:grafite_status; + statements <- new_statements; + history <- new_history; + self#moveMark (- offset) + + method advance ?statement () = + try + self#_advance ?statement (); + self#notify + with + | Margin -> self#notify + | exc -> self#notify; raise exc + + method retract () = + try + let cmp,new_statements,new_history,(grafite_status,lexicon_status) = + match statements,history with + stat::statements, _::(status::_ as history) -> + String.length stat, statements, history, status + | [],[_] -> raise Margin + | _,_ -> assert false + in + self#_retract cmp lexicon_status grafite_status new_statements + new_history; + self#notify + with + | Margin -> self#notify + | exc -> self#notify; raise exc + + method private getFuture = + buffer#get_text ~start:(buffer#get_iter_at_mark (`MARK locked_mark)) + ~stop:buffer#end_iter () + + + (** @param rel_offset relative offset from current position of locked_mark *) + method private moveMark rel_offset = + let mark = `MARK locked_mark in + let old_insert = buffer#get_iter_at_mark `INSERT in + buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; + let current_mark_pos = buffer#get_iter_at_mark mark in + let new_mark_pos = + match rel_offset with + | 0 -> current_mark_pos + | n when n > 0 -> current_mark_pos#forward_chars n + | n (* when n < 0 *) -> current_mark_pos#backward_chars (abs n) + in + buffer#move_mark mark ~where:new_mark_pos; + buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:new_mark_pos; + buffer#move_mark `INSERT old_insert; + let mark_position = buffer#get_iter_at_mark mark in + if source_view#move_mark_onscreen mark then + begin + buffer#move_mark mark mark_position; + source_view#scroll_to_mark ~use_align:true ~xalign:1.0 ~yalign:0.1 mark; + end; + while Glib.Main.pending () do ignore(Glib.Main.iteration false); done + + method clean_dirty_lock = + let lock_mark_iter = buffer#get_iter_at_mark (`MARK locked_mark) in + buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; + buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:lock_mark_iter + + val mutable observers = [] + + method addObserver (o: LexiconEngine.status -> GrafiteTypes.status -> unit) = + observers <- o :: observers + + method private notify = + let lexicon_status = self#lexicon_status in + let grafite_status = self#grafite_status in + List.iter (fun o -> o lexicon_status grafite_status) observers + + method loadFromFile f = + buffer#set_text (HExtlib.input_file f); + self#reset_buffer; + buffer#set_modified false + + method assignFileName file = + let abspath = MatitaMisc.absolute_path file in + let dirname = Filename.dirname abspath in + let devel = MatitamakeLib.development_for_dir dirname in + guistuff.filenamedata <- Some abspath, devel; + let include_ = + match MatitamakeLib.development_for_dir dirname with + None -> [] + | Some devel -> [MatitamakeLib.root_for_development devel] in + let include_ = + include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes") + in + include_paths <- include_ + + method saveToFile () = + let oc = open_out self#getFilename in + output_string oc (buffer#get_text ~start:buffer#start_iter + ~stop:buffer#end_iter ()); + close_out oc; + buffer#set_modified false + + method private _saveToBackupFile () = + if buffer#modified then + begin + let f = self#ppFilename ^ "~" in + let oc = open_out f in + output_string oc (buffer#get_text ~start:buffer#start_iter + ~stop:buffer#end_iter ()); + close_out oc; + HLog.debug ("backup " ^ f ^ " saved") + end + + method private goto_top = + let grafite_status,lexicon_status = + let rec last x = function + | [] -> x + | hd::tl -> last hd tl + in + last (self#grafite_status,self#lexicon_status) history + in + (* FIXME: this is not correct since there is no undo for + * library_objects.set_default... *) + GrafiteSync.time_travel ~present:self#grafite_status ~past:grafite_status; + LexiconSync.time_travel ~present:self#lexicon_status ~past:lexicon_status + + method private reset_buffer = + statements <- []; + history <- [ initial_statuses ]; + userGoal <- None; + self#notify; + buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter; + buffer#move_mark (`MARK locked_mark) ~where:buffer#start_iter + + method reset () = + self#reset_buffer; + source_buffer#begin_not_undoable_action (); + buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter; + source_buffer#end_not_undoable_action (); + buffer#set_modified false; + + method template () = + let template = HExtlib.input_file BuildTimeConf.script_template in + buffer#insert ~iter:(buffer#get_iter `START) template; + let development = MatitamakeLib.development_for_dir (Unix.getcwd ()) in + guistuff.filenamedata <- (None,development); + let include_ = + match development with + None -> [] + | Some devel -> [MatitamakeLib.root_for_development devel ] + in + let include_ = + include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes") + in + include_paths <- include_ ; + buffer#set_modified false; + set_star (Filename.basename self#ppFilename) false + + method goto (pos: [`Top | `Bottom | `Cursor]) () = + let old_locked_mark = + `MARK + (buffer#create_mark ~name:"old_locked_mark" + ~left_gravity:true (buffer#get_iter_at_mark (`MARK locked_mark))) in + let getpos _ = buffer#get_iter_at_mark (`MARK locked_mark) in + let getoldpos _ = buffer#get_iter_at_mark old_locked_mark in + let dispose_old_locked_mark () = buffer#delete_mark old_locked_mark in + match pos with + | `Top -> + dispose_old_locked_mark (); + self#goto_top; + self#reset_buffer; + self#notify + | `Bottom -> + (try + let rec dowhile () = + self#_advance (); + let newpos = getpos () in + if (getoldpos ())#compare newpos < 0 then + begin + buffer#move_mark old_locked_mark newpos; + dowhile () + end + in + dowhile (); + dispose_old_locked_mark (); + self#notify + with + | Margin -> dispose_old_locked_mark (); self#notify + | exc -> dispose_old_locked_mark (); self#notify; raise exc) + | `Cursor -> + let locked_iter () = buffer#get_iter_at_mark (`NAME "locked") in + let cursor_iter () = buffer#get_iter_at_mark `INSERT in + let remember = + `MARK + (buffer#create_mark ~name:"initial_insert" + ~left_gravity:true (cursor_iter ())) in + let dispose_remember () = buffer#delete_mark remember in + let remember_iter () = + buffer#get_iter_at_mark (`NAME "initial_insert") in + let cmp () = (locked_iter ())#offset - (remember_iter ())#offset in + let icmp = cmp () in + let forward_until_cursor () = (* go forward until locked > cursor *) + let rec aux () = + self#_advance (); + if cmp () < 0 && (getoldpos ())#compare (getpos ()) < 0 + then + begin + buffer#move_mark old_locked_mark (getpos ()); + aux () + end + in + aux () + in + let rec back_until_cursor len = (* go backward until locked < cursor *) + function + statements, ((grafite_status,lexicon_status)::_ as history) + when len <= 0 -> + self#_retract (icmp - len) lexicon_status grafite_status statements + history + | statement::tl1, _::tl2 -> + back_until_cursor (len - String.length statement) (tl1,tl2) + | _,_ -> assert false + in + (try + begin + if icmp < 0 then (* locked < cursor *) + (forward_until_cursor (); self#notify) + else if icmp > 0 then (* locked > cursor *) + (back_until_cursor icmp (statements,history); self#notify) + else (* cursor = locked *) + () + end ; + dispose_remember (); + dispose_old_locked_mark (); + with + | Margin -> dispose_remember (); dispose_old_locked_mark (); self#notify + | exc -> dispose_remember (); dispose_old_locked_mark (); + self#notify; raise exc) + + method onGoingProof () = + match self#grafite_status.proof_status with + | No_proof | Proof _ -> false + | Incomplete_proof _ -> true + | Intermediate _ -> assert false + +(* method proofStatus = MatitaTypes.get_proof_status self#status *) + method proofMetasenv = GrafiteTypes.get_proof_metasenv self#grafite_status + + method proofContext = + match userGoal with + None -> [] + | Some n -> GrafiteTypes.get_proof_context self#grafite_status n + + method proofConclusion = + match userGoal with + None -> assert false + | Some n -> + GrafiteTypes.get_proof_conclusion self#grafite_status n + + method stack = GrafiteTypes.get_stack self#grafite_status + method setGoal n = userGoal <- n + method goal = userGoal + + method eos = + let s = self#getFuture in + let rec is_there_only_comments lexicon_status s = + if Pcre.pmatch ~rex:only_dust_RE s then raise Margin; + let lexicon_status,st = + GrafiteParser.parse_statement (Ulexing.from_utf8_string s) + ~include_paths lexicon_status + in + match st with + | GrafiteParser.LSome (GrafiteAst.Comment (loc,_)) -> + let parsed_text_length = snd (HExtlib.loc_of_floc loc) in + let remain_len = String.length s - parsed_text_length in + let next = String.sub s parsed_text_length remain_len in + is_there_only_comments lexicon_status next + | GrafiteParser.LNone _ + | GrafiteParser.LSome (GrafiteAst.Executable _) -> false + in + try + is_there_only_comments self#lexicon_status s + with + | CicNotationParser.Parse_error _ -> false + | Margin | End_of_file -> true + + (* debug *) + method dump () = + HLog.debug "script status:"; + HLog.debug ("history size: " ^ string_of_int (List.length history)); + HLog.debug (sprintf "%d statements:" (List.length statements)); + List.iter HLog.debug statements; + HLog.debug ("Current file name: " ^ + (match guistuff.filenamedata with + |None,_ -> "[ no name ]" + | Some f,_ -> f)); + +end + +let _script = ref None + +let script ~source_view ~mathviewer ~urichooser ~develcreator ~ask_confirmation ~set_star () += + let s = new script + ~source_view ~mathviewer ~ask_confirmation ~urichooser ~develcreator ~set_star () + in + _script := Some s; + s + +let current () = match !_script with None -> assert false | Some s -> s + diff --git a/helm/software/matita/matitaScript.mli b/helm/software/matita/matitaScript.mli new file mode 100644 index 000000000..cfc465541 --- /dev/null +++ b/helm/software/matita/matitaScript.mli @@ -0,0 +1,103 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +exception NoUnfinishedProof +exception ActionCancelled + +class type script = +object + + method locked_mark : Gtk.text_mark + method locked_tag : GText.tag + method error_tag : GText.tag + + (** @return current status *) + method lexicon_status: LexiconEngine.status + method grafite_status: GrafiteTypes.status + + (** {2 Observers} *) + + method addObserver : + (LexiconEngine.status -> GrafiteTypes.status -> unit) -> unit + + (** {2 History} *) + + method advance : ?statement:string -> unit -> unit + method retract : unit -> unit + method goto: [`Top | `Bottom | `Cursor] -> unit -> unit + method reset: unit -> unit + method template: unit -> unit + + (** {2 Load/save} *) + + method assignFileName : string -> unit (* to the current active file *) + method loadFromFile : string -> unit + method saveToFile : unit -> unit + method filename : string + + (** {2 Current proof} (if any) *) + + (** @return true if there is an ongoing proof, false otherise *) + method onGoingProof: unit -> bool + +(* method proofStatus: ProofEngineTypes.status |+* @raise Statement_error +| *) + method proofMetasenv: Cic.metasenv (** @raise Statement_error *) + method proofContext: Cic.context (** @raise Statement_error *) + method proofConclusion: Cic.term (** @raise Statement_error *) + method stack: Continuationals.Stack.t (** @raise Statement_error *) + + method setGoal: int option -> unit + method goal: int option + + (** end of script, true if the whole script has been executed *) + method eos: bool + + (** misc *) + method clean_dirty_lock: unit + + (* debug *) + method dump : unit -> unit + +end + + (** @param set_star callback used to set the modified symbol (usually a star + * "*") on the side of a script name *) +val script: + source_view:GSourceView.source_view -> + mathviewer: MatitaTypes.mathViewer-> + urichooser: (UriManager.uri list -> UriManager.uri list) -> + develcreator: (containing:string option -> unit) -> + ask_confirmation: + (title:string -> message:string -> [`YES | `NO | `CANCEL]) -> + set_star: (string -> bool -> unit) -> + unit -> + script + +(* each time script above is called an internal ref is set, instance will return + * the value of this ref *) +(* TODO Zack: orrible solution until we found a better one for having a single + * access point for the script *) +val current: unit -> script + diff --git a/helm/software/matita/matitaTypes.ml b/helm/software/matita/matitaTypes.ml new file mode 100644 index 000000000..13543dbb6 --- /dev/null +++ b/helm/software/matita/matitaTypes.ml @@ -0,0 +1,74 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf +open GrafiteTypes + + (** user hit the cancel button *) +exception Cancel + +type abouts = + [ `Blank + | `Current_proof + | `Us + ] + +type mathViewer_entry = + [ `About of abouts (* current proof *) + | `Check of string (* term *) + | `Cic of Cic.term * Cic.metasenv + | `Dir of string (* "directory" in cic uris namespace *) + | `Uri of UriManager.uri (* cic object uri *) + | `Whelp of string * UriManager.uri list (* query and results *) + ] + +let string_of_entry = function + | `About `Blank -> "about:blank" + | `About `Current_proof -> "about:proof" + | `About `Us -> "about:us" + | `Check _ -> "check:" + | `Cic (_, _) -> "term:" + | `Dir uri -> uri + | `Uri uri -> UriManager.string_of_uri uri + | `Whelp (query, _) -> query + +let entry_of_string = function + | "about:blank" -> `About `Blank + | "about:proof" -> `About `Current_proof + | "about:us" -> `About `Us + | _ -> (* only about entries supported ATM *) + raise (Invalid_argument "entry_of_string") + +class type mathViewer = + object + (** @param reuse if set reused last opened cic browser otherwise + * opens a new one. default is false + *) + method show_entry: ?reuse:bool -> mathViewer_entry -> unit + method show_uri_list: + ?reuse:bool -> entry:mathViewer_entry -> UriManager.uri list -> unit + end diff --git a/helm/software/matita/matitaTypes.mli b/helm/software/matita/matitaTypes.mli new file mode 100644 index 000000000..be77c4435 --- /dev/null +++ b/helm/software/matita/matitaTypes.mli @@ -0,0 +1,46 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +exception Cancel + +type abouts = [ `Blank | `Current_proof | `Us ] + +type mathViewer_entry = + [ `About of abouts + | `Check of string + | `Cic of Cic.term * Cic.metasenv + | `Dir of string + | `Uri of UriManager.uri + | `Whelp of string * UriManager.uri list ] + +val string_of_entry : mathViewer_entry -> string +val entry_of_string : string -> mathViewer_entry + +class type mathViewer = + object + method show_entry : ?reuse:bool -> mathViewer_entry -> unit + method show_uri_list : + ?reuse:bool -> entry:mathViewer_entry -> UriManager.uri list -> unit + end diff --git a/helm/software/matita/matitac.ml b/helm/software/matita/matitac.ml new file mode 100644 index 000000000..95b500b87 --- /dev/null +++ b/helm/software/matita/matitac.ml @@ -0,0 +1,41 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let main () = + match Filename.basename Sys.argv.(0) with + | "matitadep" | "matitadep.opt" -> Matitadep.main () + | "matitaclean" | "matitaclean.opt" -> Matitaclean.main () + | "matitamake" | "matitamake.opt" -> Matitamake.main () + | _ -> +(* + let _ = Paramodulation.Saturation.init () in *) +(* ALB to link paramodulation *) + let _ = MatitacLib.main `COMPILER in + () + +let _ = main () + diff --git a/helm/software/matita/matitacLib.ml b/helm/software/matita/matitacLib.ml new file mode 100644 index 000000000..ee09258e0 --- /dev/null +++ b/helm/software/matita/matitacLib.ml @@ -0,0 +1,267 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +open GrafiteTypes + +exception AttemptToInsertAnAlias + +let pp_ast_statement = + GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term + ~lazy_term_pp:CicNotationPp.pp_term ~obj_pp:CicNotationPp.pp_obj + +(** {2 Initialization} *) + +let grafite_status = (ref None : GrafiteTypes.status option ref) +let lexicon_status = (ref None : LexiconEngine.status option ref) + +let run_script is eval_function = + let lexicon_status',grafite_status' = + match !lexicon_status,!grafite_status with + | Some ss, Some s -> ss,s + | _,_ -> assert false + in + let slash_n_RE = Pcre.regexp "\\n" in + let cb = + if Helm_registry.get_bool "matita.quiet" then + (fun _ _ -> ()) + else + (fun grafite_status stm -> + (* dump_status grafite_status; *) + let stm = pp_ast_statement stm in + let stm = Pcre.replace ~rex:slash_n_RE stm in + let stm = + if String.length stm > 50 then + String.sub stm 0 50 ^ " ..." + else + stm + in + HLog.debug ("Executing: ``" ^ stm ^ "''")) + in + try + let grafite_status'', lexicon_status'' = + match eval_function lexicon_status' grafite_status' is cb with + [] -> assert false + | (s,None)::_ -> s + | (s,Some _)::_ -> raise AttemptToInsertAnAlias + in + lexicon_status := Some lexicon_status''; + grafite_status := Some grafite_status'' + with + | GrafiteEngine.Drop + | End_of_file + | CicNotationParser.Parse_error _ as exn -> raise exn + | exn -> + HLog.error (snd (MatitaExcPp.to_string exn)); + raise exn + +let fname () = + match Helm_registry.get_list Helm_registry.string "matita.args" with + | [x] -> x + | _ -> MatitaInit.die_usage () + +let pp_ocaml_mode () = + HLog.message ""; + HLog.message " ** Entering Ocaml mode ** "; + HLog.message ""; + HLog.message "Type 'go ();;' to enter an interactive matitac"; + HLog.message "" + +let clean_exit n = + let opt_exit = + function + None -> () + | Some n -> exit n + in + match !grafite_status with + None -> opt_exit n + | Some grafite_status -> + try + let baseuri = GrafiteTypes.get_string_option grafite_status "baseuri" in + let basedir = Helm_registry.get "matita.basedir" in + LibraryClean.clean_baseuris ~basedir ~verbose:false [baseuri]; + opt_exit n + with GrafiteTypes.Option_error("baseuri", "not found") -> + (* no baseuri ==> nothing to clean yet *) + opt_exit n + +let rec interactive_loop () = + let str = Ulexing.from_utf8_channel stdin in + try + run_script str + (MatitaEngine.eval_from_stream ~first_statement_only:false ~prompt:true + ~include_paths:(Helm_registry.get_list Helm_registry.string + "matita.includes")) + with + | GrafiteEngine.Drop -> pp_ocaml_mode () + | GrafiteEngine.Macro (floc,_) -> + let x, y = HExtlib.loc_of_floc floc in + HLog.error + (sprintf "A macro has been found in a script at %d-%d" x y); + interactive_loop () + | Sys.Break -> HLog.error "user break!"; interactive_loop () + | GrafiteTypes.Command_error _ -> interactive_loop () + | End_of_file -> + print_newline (); + clean_exit (Some 0) + | HExtlib.Localized (floc,CicNotationParser.Parse_error err) -> + let x, y = HExtlib.loc_of_floc floc in + HLog.error (sprintf "Parse error at %d-%d: %s" x y err); + interactive_loop () + | exn -> HLog.error (Printexc.to_string exn); interactive_loop () + +let go () = + Helm_registry.load_from BuildTimeConf.matita_conf; + Http_getter.init (); + MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner"); + LibraryDb.create_owner_environment (); + CicEnvironment.set_trust (* environment trust *) + (let trust = + Helm_registry.get_opt_default Helm_registry.get_bool + ~default:true "matita.environment_trust" in + fun _ -> trust); + let include_paths = + Helm_registry.get_list Helm_registry.string "matita.includes" in + grafite_status := Some (GrafiteSync.init ()); + lexicon_status := + Some (CicNotation2.load_notation ~include_paths + BuildTimeConf.core_notation_script); + Sys.catch_break true; + interactive_loop () + +let main ~mode = + MatitaInit.initialize_all (); + (* must be called after init since args are set by cmdline parsing *) + let fname = fname () in + let include_paths = + Helm_registry.get_list Helm_registry.string "matita.includes" in + grafite_status := Some (GrafiteSync.init ()); + lexicon_status := + Some (CicNotation2.load_notation ~include_paths + BuildTimeConf.core_notation_script); + Sys.catch_break true; + let origcb = HLog.get_log_callback () in + let newcb tag s = + match tag with + | `Debug | `Message -> () + | `Warning | `Error -> origcb tag s + in + if Helm_registry.get_bool "matita.quiet" then + HLog.set_log_callback newcb; + let matita_debug = Helm_registry.get_bool "matita.debug" in + try + let time = Unix.time () in + if Helm_registry.get_bool "matita.quiet" then + origcb `Message ("compiling " ^ Filename.basename fname ^ "...") + else + HLog.message (sprintf "execution of %s started:" fname); + let is = + Ulexing.from_utf8_channel + (match fname with + | "stdin" -> stdin + | fname -> open_in fname) in + let include_paths = + Helm_registry.get_list Helm_registry.string "matita.includes" in + (try + run_script is + (MatitaEngine.eval_from_stream ~first_statement_only:false ~include_paths + ~clean_baseuri:(not (Helm_registry.get_bool "matita.preserve"))) + with End_of_file -> ()); + let elapsed = Unix.time () -. time in + let tm = Unix.gmtime elapsed in + let sec = string_of_int tm.Unix.tm_sec ^ "''" in + let min = + if tm.Unix.tm_min > 0 then (string_of_int tm.Unix.tm_min ^ "' ") else "" + in + let hou = + if tm.Unix.tm_hour > 0 then (string_of_int tm.Unix.tm_hour ^ "h ") else "" + in + let proof_status,moo_content_rev,metadata,lexicon_content_rev = + match !lexicon_status,!grafite_status with + | Some ss, Some s -> + s.proof_status, s.moo_content_rev, ss.LexiconEngine.metadata, + ss.LexiconEngine.lexicon_content_rev + | _,_ -> assert false + in + if proof_status <> GrafiteTypes.No_proof then + begin + HLog.error + "there are still incomplete proofs at the end of the script"; + clean_exit (Some 2) + end + else + begin + let basedir = Helm_registry.get "matita.basedir" in + let baseuri = + DependenciesParser.baseuri_of_script ~include_paths fname in + let moo_fname = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in + let lexicon_fname= LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri in + let metadata_fname = + LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri + in + GrafiteMarshal.save_moo moo_fname moo_content_rev; + LibraryNoDb.save_metadata metadata_fname metadata; + LexiconMarshal.save_lexicon lexicon_fname lexicon_content_rev; + HLog.message + (sprintf "execution of %s completed in %s." fname (hou^min^sec)); + exit 0 + end + with + | Sys.Break -> + HLog.error "user break!"; + if mode = `COMPILER then + clean_exit (Some ~-1) + else + pp_ocaml_mode () + | GrafiteEngine.Drop -> + if mode = `COMPILER then + clean_exit (Some 1) + else + pp_ocaml_mode () + | GrafiteEngine.Macro (floc,_) -> + let x, y = HExtlib.loc_of_floc floc in + HLog.error + (sprintf "A macro has been found in a script at %d-%d" x y); + if mode = `COMPILER then + clean_exit (Some 1) + else + pp_ocaml_mode () + | HExtlib.Localized (floc,CicNotationParser.Parse_error err) -> + let (x, y) = HExtlib.loc_of_floc floc in + HLog.error (sprintf "Parse error at %d-%d: %s" x y err); + if mode = `COMPILER then + clean_exit (Some 1) + else + pp_ocaml_mode () + | exn -> + if matita_debug then raise exn; + if mode = `COMPILER then + clean_exit (Some 3) + else + pp_ocaml_mode () + diff --git a/helm/software/matita/matitacLib.mli b/helm/software/matita/matitacLib.mli new file mode 100644 index 000000000..636c51d57 --- /dev/null +++ b/helm/software/matita/matitacLib.mli @@ -0,0 +1,37 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +val interactive_loop : unit -> unit + +(** go initializes the status and calls interactive_loop *) +val go : unit -> unit +val main : mode:[ `COMPILER | `TOPLEVEL ] -> unit + +(** clean_exit n + if n = Some n it performs an exit [n] after a complete clean-up of what was + partially compiled + otherwise it performs the clean-up without exiting +*) +val clean_exit : int option -> unit diff --git a/helm/software/matita/matitaclean.ml b/helm/software/matita/matitaclean.ml new file mode 100644 index 000000000..826a4a282 --- /dev/null +++ b/helm/software/matita/matitaclean.ml @@ -0,0 +1,73 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +module UM = UriManager +module TA = GrafiteAst + +let clean_suffixes = [ ".moo"; ".lexicon"; ".metadata"; ".xml.gz" ] + +let main () = + let _ = MatitaInit.initialize_all () in + let basedir = Helm_registry.get "matita.basedir" in + match Helm_registry.get_list Helm_registry.string "matita.args" with + | [ "all" ] -> + LibraryDb.clean_owner_environment (); + let xmldir = basedir ^ "/xml" in + let clean_pat = + String.concat " -o " + (List.map (fun suf -> "-name \\*" ^ suf) clean_suffixes) in + let clean_cmd = + sprintf "find %s \\( %s \\) -exec rm \\{\\} \\; 2> /dev/null" + xmldir clean_pat in + ignore (Sys.command clean_cmd); + ignore + (Sys.command ("find " ^ xmldir ^ + " -type d -exec rmdir -p {} \\; 2> /dev/null")); + exit 0 + | [] -> MatitaInit.die_usage () + | files -> + let uris_to_remove = + List.fold_left + (fun uris_to_remove suri -> + let uri = + try + UM.buri_of_uri (UM.uri_of_string suri) + with UM.IllFormedUri _ -> + let u = + DependenciesParser.baseuri_of_script ~include_paths:[] suri in + if String.length u < 5 || String.sub u 0 5 <> "cic:/" then begin + HLog.error (sprintf "File %s defines a bad baseuri: %s" + suri u); + exit 1 + end else + u + in + uri::uris_to_remove) [] files + in + LibraryClean.clean_baseuris ~basedir uris_to_remove diff --git a/helm/software/matita/matitaclean.mli b/helm/software/matita/matitaclean.mli new file mode 100644 index 000000000..45d57a886 --- /dev/null +++ b/helm/software/matita/matitaclean.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val main: unit -> unit + diff --git a/helm/software/matita/matitadep.ml b/helm/software/matita/matitadep.ml new file mode 100644 index 000000000..c1ada6aea --- /dev/null +++ b/helm/software/matita/matitadep.ml @@ -0,0 +1,94 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +module GA = GrafiteAst +module U = UriManager + +let main () = + (* all are maps from "file" to "something" *) + let include_deps = Hashtbl.create (Array.length Sys.argv) in + let baseuri_of = Hashtbl.create (Array.length Sys.argv) in + let uri_deps = Hashtbl.create (Array.length Sys.argv) in + let buri alias = U.buri_of_uri (U.uri_of_string alias) in + let resolve alias current_buri = + let buri = buri alias in + if buri <> current_buri then Some buri else None in + MatitaInit.fill_registry (); + MatitaInit.parse_cmdline (); + MatitaInit.load_configuration_file (); + let include_paths = + Helm_registry.get_list Helm_registry.string "matita.includes" in + let basedir = Helm_registry.get "matita.basedir" in + List.iter + (fun ma_file -> + let ic = open_in ma_file in + let istream = Ulexing.from_utf8_channel ic in + let dependencies = DependenciesParser.parse_dependencies istream in + close_in ic; + List.iter + (function + | DependenciesParser.UriDep uri -> + let uri = UriManager.string_of_uri uri in + if not (Http_getter_storage.is_legacy uri) then + Hashtbl.add uri_deps ma_file uri + | DependenciesParser.BaseuriDep uri -> + let uri = Http_getter_misc.strip_trailing_slash uri in + Hashtbl.add baseuri_of ma_file uri + | DependenciesParser.IncludeDep path -> + try + let baseuri = + DependenciesParser.baseuri_of_script ~include_paths path in + if not (Http_getter_storage.is_legacy baseuri) then + let moo_file = + LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in + Hashtbl.add include_deps ma_file moo_file + with Sys_error _ -> + HLog.warn + ("Unable to find " ^ path ^ " that is included in " ^ ma_file) + ) dependencies + ) (Helm_registry.get_list Helm_registry.string "matita.args"); + Hashtbl.iter + (fun file alias -> + let dep = resolve alias (Hashtbl.find baseuri_of file) in + match dep with + | None -> () + | Some u -> + Hashtbl.add include_deps file + (LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri:u)) + uri_deps; + List.iter + (fun ma_file -> + let deps = Hashtbl.find_all include_deps ma_file in + let deps = List.fast_sort Pervasives.compare deps in + let deps = HExtlib.list_uniq deps in + let deps = ma_file :: deps in + let baseuri = Hashtbl.find baseuri_of ma_file in + let moo = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in + Printf.printf "%s: %s\n" moo (String.concat " " deps); + Printf.printf "%s: %s\n" (Pcre.replace ~pat:"ma$" ~templ:"mo" ma_file) moo) + (Helm_registry.get_list Helm_registry.string "matita.args") + diff --git a/helm/software/matita/matitadep.mli b/helm/software/matita/matitadep.mli new file mode 100644 index 000000000..45d57a886 --- /dev/null +++ b/helm/software/matita/matitadep.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +val main: unit -> unit + diff --git a/helm/software/matita/matitamake.ml b/helm/software/matita/matitamake.ml new file mode 100644 index 000000000..f0e17eb8b --- /dev/null +++ b/helm/software/matita/matitamake.ml @@ -0,0 +1,163 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +module MK = MatitamakeLib ;; + +let main () = + MatitaInit.fill_registry (); + MatitaInit.load_configuration_file (); + MK.initialize (); + let usage = ref (fun () -> ()) in + let dev_of_name name = + match MK.development_for_name name with + | None -> + prerr_endline ("Unable to find a development called " ^ name); + exit 1 + | Some d -> d + in + let dev_for_dir dir = + match MK.development_for_dir dir with + | None -> + prerr_endline ("Unable to find a development holding directory: "^ dir); + exit 1 + | Some d -> d + in + let init_dev_doc = " +\tParameters: name (the name of the development, required) +\tDescription: tells matitamake that a new development radicated +\t\tin the current working directory should be handled." + in + let init_dev args = + if List.length args <> 1 then !usage (); + match MK.initialize_development (List.hd args) (Unix.getcwd ()) with + | None -> exit 2 + | Some _ -> exit 0 + in + let list_dev_doc = " +\tParameters: +\tDescription: lists the known developments and their roots." + in + let list_dev args = + if List.length args <> 0 then !usage (); + match MK.list_known_developments () with + | [] -> print_string "No developments found.\n"; exit 0 + | l -> + List.iter + (fun (name, root) -> + print_string (Printf.sprintf "%-10s\trooted in %s\n" name root)) + l; + exit 0 + in + let destroy_dev_doc = " +\tParameters: name (the name of the development to destroy, required) +\tDescription: deletes a development (only from matitamake metadat, no +\t\t.ma files will be deleted)." + in + let destroy_dev args = + if List.length args <> 1 then !usage (); + let name = (List.hd args) in + let dev = dev_of_name name in + MK.destroy_development dev; + exit 0 + in + let clean_dev_doc = " +\tParameters: name (the name of the development to destroy, optional) +\t\tIf omitted the development that holds the current working +\t\tdirectory is used (if any). +\tDescription: clean the develpoment." + in + let clean_dev args = + let dev = + match args with + | [] -> dev_for_dir (Unix.getcwd ()) + | [name] -> dev_of_name name + | _ -> !usage (); exit 1 + in + match MK.clean_development dev with + | true -> exit 0 + | false -> exit 1 + in + let build_dev_doc = " +\tParameters: name (the name of the development to build, required) +\tDescription: completely builds the develpoment." + in + let build_dev args = + if List.length args <> 1 then !usage (); + let name = (List.hd args) in + let dev = dev_of_name name in + match MK.build_development dev with + | true -> exit 0 + | false -> exit 1 + in + let nodb_doc = " +\tParameters: +\tDescription: avoid using external database connection." + in + let nodb _ = Helm_registry.set_bool "db.nodb" true in + let target args = + if List.length args < 1 then !usage (); + let dev = dev_for_dir (Unix.getcwd ()) in + List.iter + (fun t -> + ignore(MK.build_development ~target:t dev)) + args + in + let params = [ + "-init", init_dev, init_dev_doc; + "-clean", clean_dev, clean_dev_doc; + "-list", list_dev, list_dev_doc; + "-destroy", destroy_dev, destroy_dev_doc; + "-build", build_dev, build_dev_doc; + "-nodb", nodb, nodb_doc; + "-h", (fun _ -> !usage()), "print this help screen"; + "-help", (fun _ -> !usage()), "print this help screen"; + ] + in + usage := (fun () -> + let p = prerr_endline in + p "\nusage:"; + p "\tmatitamake(.opt) [command [options]]\n"; + p "\tmatitamake(.opt) [target]\n"; + p "commands:"; + List.iter (fun (n,_,d) -> p (Printf.sprintf " %-10s%s" n d)) params; + p "\nIf target is omitted a 'all' will be used as the default."; + p "With -build you can build a development wherever it is."; + p "If you specify a target it implicitly refers to the development that"; + p "holds the current working directory (if any).\n"; + exit 1); + let rec parse args = + match args with + | [] -> target ["all"] + | s::tl -> + try + let _,f,_ = List.find (fun (n,_,_) -> n = s) params in + f tl; + parse tl + with Not_found -> if s.[0] = '-' then !usage () else target args + in + parse (List.tl (Array.to_list Sys.argv)) + diff --git a/helm/software/matita/matitamakeLib.ml b/helm/software/matita/matitamakeLib.ml new file mode 100644 index 000000000..fba66e0d6 --- /dev/null +++ b/helm/software/matita/matitamakeLib.ml @@ -0,0 +1,306 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +open Printf + +let logger = fun mark -> + match mark with + | `Error -> HLog.error + | `Warning -> HLog.warn + | `Debug -> HLog.debug + | `Message -> HLog.message +;; + +type development = + { root: string ; name: string } + +let developments = ref [] + +let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;; +let rootfile = "/root" ;; + +let ls_dir dir = + try + let d = Unix.opendir dir in + let content = ref [] in + try + while true do + let name = Unix.readdir d in + if name <> "." && name <> ".." then + content := name :: !content + done; + Some [] + with End_of_file -> Unix.closedir d; Some !content + with Unix.Unix_error _ -> None + +let initialize () = + (* create a base env if none *) + HExtlib.mkdir (pool ()); + (* load developments *) + match ls_dir (pool ()) with + | None -> logger `Error ("Unable to list directory " ^ pool ()) + | Some l -> + List.iter + (fun name -> + let root = + try + Some (HExtlib.input_file (pool () ^ name ^ rootfile)) + with Unix.Unix_error _ -> + logger `Warning ("Malformed development " ^ name); + None + in + match root with + | None -> () + | Some root -> + developments := {root = root ; name = name} :: !developments) + l + +(* finds the makefile path for development devel *) +let makefile_for_development devel = + let develdir = pool () ^ devel.name in + develdir ^ "/makefile" +;; + +(* given a dir finds a development that is radicated in it or below *) +let development_for_dir dir = + let is_prefix_of d1 d2 = + let len1 = String.length d1 in + let len2 = String.length d2 in + if len2 < len1 then + false + else + let pref = String.sub d2 0 len1 in + pref = d1 + in + (* it must be unique *) + try + Some (List.find (fun d -> is_prefix_of d.root dir) !developments) + with Not_found -> None +;; + +let development_for_name name = + try + Some (List.find (fun d -> d.name = name) !developments) + with Not_found -> None + +(* dumps the deveopment to disk *) +let dump_development devel = + let devel_dir = pool () ^ devel.name in + HExtlib.mkdir devel_dir; + HExtlib.output_file ~filename:(devel_dir ^ rootfile) ~text:devel.root +;; + +let list_known_developments () = + List.map (fun r -> r.name,r.root) !developments + +let am_i_opt () = + if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else "" + +let rebuild_makefile development = + let makefilepath = makefile_for_development development in + let template = + HExtlib.input_file BuildTimeConf.matitamake_makefile_template + in + let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in + let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in + let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in + let df = pool () ^ development.name ^ "/depend" in + let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in + let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in + let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in + let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in + let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in + HExtlib.output_file ~filename:makefilepath ~text:template + +(* creates a new development if possible *) +let initialize_development name dir = + let name = Pcre.replace ~pat:" " ~templ:"_" name in + let dev = {name = name ; root = dir} in + match development_for_dir dir with + | Some d -> + logger `Error + ("Directory " ^ dir ^ " is already handled by development " ^ d.name); + logger `Error + ("Development " ^ d.name ^ " is rooted in " ^ d.root); + logger `Error + (dir ^ " is a subdir of " ^ d.root); + None + | None -> + dump_development dev; + rebuild_makefile dev; + developments := dev :: !developments; + Some dev + +let make chdir args = + let old = Unix.getcwd () in + try + Unix.chdir chdir; + let rc = + Unix.system + (String.concat " " ("make"::(List.map Filename.quote args))) + in + Unix.chdir old; + match rc with + | Unix.WEXITED 0 -> true + | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false + | _ -> logger `Error "make STOPPED or SIGNALED!";false + with Unix.Unix_error (_,cmd,err) -> + logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err); + false + +let call_make development target make = + rebuild_makefile development; + let makefile = makefile_for_development development in + let nodb = + Helm_registry.get_opt_default Helm_registry.bool ~default:false "db.nodb" + in + let flags = [] in + let flags = flags @ if nodb then ["NODB=true"] else [] in + let flags = + try + flags @ [ sprintf "MATITA_FLAGS=\"%s\"" (Sys.getenv "MATITA_FLAGS") ] + with Not_found -> flags in + make development.root + (["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target] + @ flags) + +let build_development ?(target="all") development = + call_make development target make + +(* not really good vt100 *) +let vt100 s = + let rex = Pcre.regexp "\\[[0-9;]+m" in + let rex_i = Pcre.regexp "^Info" in + let rex_w = Pcre.regexp "^Warning" in + let rex_e = Pcre.regexp "^Error" in + let rex_d = Pcre.regexp "^Debug" in + let rex_noendline = Pcre.regexp "\\n" in + let s = Pcre.replace ~rex:rex_noendline s in + let tokens = Pcre.split ~rex s in + let logger = ref HLog.message in + let rec aux = + function + | [] -> () + | s::tl -> + (if Pcre.pmatch ~rex:rex_i s then + logger := HLog.message + else if Pcre.pmatch ~rex:rex_w s then + logger := HLog.warn + else if Pcre.pmatch ~rex:rex_e s then + logger := HLog.error + else if Pcre.pmatch ~rex:rex_d s then + logger := HLog.debug + else + !logger s); + aux tl + in + aux tokens + + +let mk_maker refresh_cb = + (fun chdir args -> + let out_r,out_w = Unix.pipe () in + let err_r,err_w = Unix.pipe () in + let pid = ref ~-1 in + ignore(Sys.signal Sys.sigchld (Sys.Signal_ignore)); + try + let argv = Array.of_list ("make"::args) in + pid := Unix.create_process "make" argv Unix.stdin out_w err_w; + Unix.close out_w; + Unix.close err_w; + let buf = String.create 1024 in + let rec aux = function + | f::tl -> + let len = Unix.read f buf 0 1024 in + if len = 0 then + raise + (Unix.Unix_error + (Unix.EPIPE,"read","len = 0 (matita internal)")); + vt100 (String.sub buf 0 len); + aux tl + | _ -> () + in + while true do + let r,_,_ = Unix.select [out_r; err_r] [] [] (-. 1.) in + aux r; + refresh_cb () + done; + true + with + | Unix.Unix_error (_,"read",_) + | Unix.Unix_error (_,"select",_) -> true) + +let build_development_in_bg ?(target="all") refresh_cb development = + call_make development target (mk_maker refresh_cb) +;; + +let clean_development development = + call_make development "clean" make + +let clean_development_in_bg refresh_cb development = + call_make development "clean" (mk_maker refresh_cb) + +let destroy_development_aux development clean_development = + let delete_development development = + let unlink file = + try + Unix.unlink file + with Unix.Unix_error _ -> logger `Debug ("Unable to delete " ^ file) + in + let rmdir dir = + try + Unix.rmdir dir + with Unix.Unix_error _ -> + logger `Warning ("Unable to remove dir " ^ dir); + match ls_dir dir with + | None -> logger `Error ("Unable to list directory " ^ dir) + | Some [] -> () + | Some l -> logger `Error ("The directory is not empty") + in + unlink (makefile_for_development development); + unlink (pool () ^ development.name ^ rootfile); + unlink (pool () ^ development.name ^ "/depend"); + rmdir (pool () ^ development.name); + developments := + List.filter (fun d -> d.name <> development.name) !developments + in + if not(clean_development development) then + begin + logger `Warning "Unable to clean the development problerly."; + logger `Warning "This may cause garbage." + end; + delete_development development + +let destroy_development development = + destroy_development_aux development clean_development + +let destroy_development_in_bg refresh development = + destroy_development_aux development (clean_development_in_bg refresh) + +let root_for_development development = development.root +let name_for_development development = development.name + diff --git a/helm/software/matita/matitamakeLib.mli b/helm/software/matita/matitamakeLib.mli new file mode 100644 index 000000000..4aaab47b1 --- /dev/null +++ b/helm/software/matita/matitamakeLib.mli @@ -0,0 +1,54 @@ +(* Copyright (C) 2005, 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://helm.cs.unibo.it/ + *) + +type development + +(* initialize_development [name] [dir] + * ask matitamake to recorder [dir] as the root for thedevelopment [name] *) +val initialize_development: string -> string -> development option +(* make target [default all] *) +val build_development: ?target:string -> development -> bool +(* make target [default all], the refresh cb is called after every output *) +val build_development_in_bg: + ?target:string -> (unit -> unit) -> development -> bool +(* make clean *) +val clean_development: development -> bool +val clean_development_in_bg: (unit -> unit) -> development -> bool +(* return the development that handles dir *) +val development_for_dir: string -> development option +(* return the development *) +val development_for_name: string -> development option +(* return the known list of name, development_root *) +val list_known_developments: unit -> (string * string ) list +(* cleans the development, forgetting about it *) +val destroy_development: development -> unit +val destroy_development_in_bg: (unit -> unit) -> development -> unit +(* initiale internal data structures *) +val initialize : unit -> unit +(* gives back the root *) +val root_for_development : development -> string +(* gives back the name *) +val name_for_development : development -> string + diff --git a/helm/software/matita/matitatop.ml b/helm/software/matita/matitatop.ml new file mode 100644 index 000000000..0aba1e9b5 --- /dev/null +++ b/helm/software/matita/matitatop.ml @@ -0,0 +1,31 @@ +(* Copyright (C) 2004-2005, 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://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +let _ = + let _ = Topdirs.dir_quit in + Toploop.loop Format.std_formatter; + assert false diff --git a/helm/software/matita/scripts/README b/helm/software/matita/scripts/README new file mode 100644 index 000000000..d48449056 --- /dev/null +++ b/helm/software/matita/scripts/README @@ -0,0 +1,20 @@ +bench.sql + the SQL code to generate the bench table + +crontab + install this crontab (may need tweaking) to have cron run the whole + stuff for you + +crontab.sh + the script crontab should run (includes a "pretty" report) + +do_tests.sh + script used by ../Makefile to run matitac[.opt] on some tests. supports some + options and prints out some informations neded my insert + +insert.awk + creates the SQL INSERT statements for the output of profile_cvs.sh + +profile_svn.sh + SVN co, compilation, run + diff --git a/helm/software/matita/scripts/bench.sql b/helm/software/matita/scripts/bench.sql new file mode 100644 index 000000000..a45508548 --- /dev/null +++ b/helm/software/matita/scripts/bench.sql @@ -0,0 +1,13 @@ +DROP TABLE bench; + +CREATE TABLE bench ( + mark VARCHAR(100) NOT NULL, + time VARCHAR(8) NOT NULL, + timeuser VARCHAR(8) NOT NULL, + compilation ENUM('byte','opt') NOT NULL, + test VARCHAR(100) NOT NULL, + result ENUM('ok','fail') NOT NULL, + options SET('gc-off','gc-on') +); + +DESCRIBE bench; diff --git a/helm/software/matita/scripts/crontab b/helm/software/matita/scripts/crontab new file mode 100644 index 000000000..4b4c1e80a --- /dev/null +++ b/helm/software/matita/scripts/crontab @@ -0,0 +1,4 @@ +MAILTO=helm@cs.unibo.it +HOME=/home/tassi/ +#SVNOPTIONS='-r {2006-01-09}' +10 5 * * * sh /home/tassi/helm/matita/scripts/crontab.sh diff --git a/helm/software/matita/scripts/crontab.sh b/helm/software/matita/scripts/crontab.sh new file mode 100644 index 000000000..5ad50de5e --- /dev/null +++ b/helm/software/matita/scripts/crontab.sh @@ -0,0 +1,78 @@ +#!/bin/bash +TODAY=`date +%Y%m%d` +YESTERDAY=`date -d yesterday +%Y%m%d` +TMPDIRNAME=$HOME/__${TODAY}_crontab +TMPDIRNAMEOLD=$HOME/__${YESTERDAY}_crontab +SVNROOT="svn+ssh://mowgli.cs.unibo.it/local/svn/helm/trunk/" +SHELLTIME2CENTSPHP=scripts/shell_time2cents.php +SHELLADDERPHP=scripts/shell_adder.php +COMMONPHP=scripts/public_html/common.php + + +OLD=$PWD +mkdir -p $TMPDIRNAME +rm -rf $TMPDIRNAMEOLD +cd $TMPDIRNAME +rm -rf helm +svn co ${SVNROOT}helm/matita/scripts/ > LOG.svn 2>&1 +scripts/profile_svn.sh 2> LOG + +MARK=`echo "select distinct mark from bench where mark like '$TODAY%' order by mark" | mysql -u helm matita | tail -n 1` +LASTMARK=`echo "select distinct mark from bench where mark like '$YESTERDAY%' order by mark" | mysql -u helm matita | tail -n 1` + +if [ -z "$MARK" ]; then + echo "No benchmark records for $TODAY" + exit 1 +fi + +if [ -z "$LASTMARK" ]; then + echo "No benchmark records for $YESTERDAY" + exit 1 +fi + +CUR_TIME=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLADDERPHP -- $COMMONPHP "select SEC_TO_TIME(SUM(TIME_TO_SEC(time))) from bench where mark = \"$MARK\" group by mark;"` +OLD_TIME=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLADDERPHP -- $COMMONPHP "select SEC_TO_TIME(SUM(TIME_TO_SEC(time))) from bench where mark = \"$LASTMARK\" group by mark;"` + +CUR_CENTS=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLTIME2CENTSPHP -- $COMMONPHP $CUR_TIME` +OLD_CENTS=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLTIME2CENTSPHP -- $COMMONPHP $OLD_TIME` + +((DELTA=$CUR_CENTS-$OLD_CENTS)) +if [ $DELTA -lt 0 ]; then + PERC=0 +else + ((PERC=100 * $DELTA)) + ((PERC=$PERC / $OLD_CENTS)) +fi +if [ $PERC -ge 5 ]; then + cat </dev/null 2>/dev/null + $COMPILER $T 1>/dev/null 2>/dev/null + fi + $CLEANER $T 1>/dev/null 2>/dev/null + TIMES=`(time $COMPILER $T > $LOG 2>&1) 2>&1` + RC=$?; + cat $LOG >> $LOGFILE + touch $DIFF + if [ $EXPECTED = "FAIL" ]; then + if [ $RC = 0 ]; then + echo "The test was successful but it should have failed!" > $DIFF + RC=1; + else + diff $LOG `basename $T .ma`.log > $DIFF + RC=$? + fi + fi + if [ $RC = 0 ]; then + printf "$OK\t$TIMES\t$DO_TESTS_EXTRA\n" + else + printf "$FAIL\t$TIMES\t$DO_TESTS_EXTRA\n"; + cat $DIFF + fi + if [ "$KEEP" != "1" ]; then + rm -f $LOG + rm -f $DIFF + fi + exit $RC +done diff --git a/helm/software/matita/scripts/insert.awk b/helm/software/matita/scripts/insert.awk new file mode 100644 index 000000000..d62a6a3ec --- /dev/null +++ b/helm/software/matita/scripts/insert.awk @@ -0,0 +1,17 @@ + { + result=tolower($3); + if( $1 ~ ".opt$" ) + compilation="opt" + else + compilation="byte" + test=$2 + time=$4 + timeuser=$5 + mark=$7 + if ( $8 ~ "^gc-off$") + options="'gc-off'"; + if ( $8 ~ "^gc-on$") + options="'gc-on'" + + printf "INSERT bench (result, compilation, test, time, timeuser, mark, options) VALUES ('%s', '%s', '%s', '%s', '%s', '%s', %s);\n", result, compilation, test, time, timeuser, mark, options; + } diff --git a/helm/software/matita/scripts/profile_svn.sh b/helm/software/matita/scripts/profile_svn.sh new file mode 100755 index 000000000..eca457ecc --- /dev/null +++ b/helm/software/matita/scripts/profile_svn.sh @@ -0,0 +1,70 @@ +#!/bin/bash +MARK=`date +%Y%m%d%H%M` +TMPDIRNAME=__${MARK}_compilation +SVNROOT="svn+ssh://mowgli.cs.unibo.it/local/svn/helm/trunk/" + +function testit { + LOGTOOPT=/dev/null + LOGTOBYTE=/dev/null + export DO_TESTS_EXTRA="$MARK\t$@" + make tests DO_TESTS_OPTS="-no-color -twice -keep-logs" + make tests.opt DO_TESTS_OPTS="-no-color -twice -keep-logs" +} + +function compile { + LOCALOLD=$PWD + cd $1 + autoconf 1>/dev/null + ./configure 1>/dev/null + make all opt 1>/dev/null + cd $2 + autoconf 1>/dev/null + ./configure 1>/dev/null + cp matita.conf.xml.sample matita.conf.xml + make all opt 1>/dev/null + cd $LOCALOLD +} + +function run_tests { + LOCALOLD=$PWD + cd $1 + ./matitaclean all + mkdir .matita + export OCAMLRUNPARAM='o=1000000' + testit "gc-off" + export OCAMLRUNPARAM='' + testit "gc-on" + cd $LOCALOLD +} + +OLD=$PWD +rm -rf $TMPDIRNAME +mkdir $TMPDIRNAME +mkdir $TMPDIRNAME.HOME +cd $TMPDIRNAME +SVNLOG=`pwd`/LOG.svn + +#svn +svn co -N $SVNROOT > $SVNLOG 2>&1 +cd trunk +svn update -N helm >> $SVNLOG 2>&1 +cd helm +svn update $SVNOPTIONS ocaml >> $SVNLOG 2>&1 +svn update $SVNOPTIONS matita >> $SVNLOG 2>&1 +cd .. +cd .. +ln -s trunk/helm . + +#compile +export HOME="`pwd`/../$TMPDIRNAME.HOME" +compile $PWD/helm/ocaml $PWD/helm/matita + +#run +run_tests $PWD/helm/matita > LOG 2>/dev/null + +cat LOG | grep "\(OK\|FAIL\)" | grep "\(gc-on\|gc-off\)" | awk -f $PWD/helm/matita/scripts/insert.awk > INSERT.sql +cat INSERT.sql | mysql -u helm -h mowgli.cs.unibo.it matita +SVNREVISION=`cat $SVNLOG | grep revision | tail -n 1 | sed "s/.*revision \(\w\+\)./\1/"` +echo "INSERT INTO bench_svn VALUES ('$MARK','$SVNREVISION')" | mysql -u helm -h mowgli.cs.unibo.it matita +cd $OLD +#rm -rf $TMPDIRNAME diff --git a/helm/software/matita/scripts/public_html/bench.php b/helm/software/matita/scripts/public_html/bench.php new file mode 100644 index 000000000..2ee540825 --- /dev/null +++ b/helm/software/matita/scripts/public_html/bench.php @@ -0,0 +1,147 @@ +$name :   "; + if (strpos($q, urlencode("***")) === false) { + echo "all"; + } else { + foreach($limits as $l) { + $q1 = str_replace(urlencode("***"), " LIMIT 0,$l", $q); + echo "" . + minus1_to_all($l) . "  "; + } + $q1 = str_replace(urlencode("***"), " ", $q); + echo "" . + minus1_to_all("-1") . "  "; + } + echo ""; +} + +?> + + + + + + +

    QUERY the benchmark system

    +

    Common Queries

    +

    +

      + + + + + + + +
    +

    +

    Custom Query

    +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Marks: + +
    Compilations: + +
    Options: + +
    Tests: + +
    Test results: + +
    Group By: + +
    Limit: + +
    + + + diff --git a/helm/software/matita/scripts/public_html/common.php b/helm/software/matita/scripts/public_html/common.php new file mode 100644 index 000000000..f2a9be030 --- /dev/null +++ b/helm/software/matita/scripts/public_html/common.php @@ -0,0 +1,89 @@ + $v) { + $rc[$x['mark']][$k] = sum_time($v, $x[$k]); + } + } + } + return array_values($rc); +} + +function array_to_combo($l,$a) { + echo ""; +} + +?> diff --git a/helm/software/matita/scripts/public_html/composequery.php b/helm/software/matita/scripts/public_html/composequery.php new file mode 100644 index 000000000..49a943e47 --- /dev/null +++ b/helm/software/matita/scripts/public_html/composequery.php @@ -0,0 +1,46 @@ + $x) { + $v = $_GET[$x]; + if($v != "--") { + if($fst == false) { + $rc = $rc . " and "; + } else { + $rc = $rc . " "; + } + $fst = false; + $rc = $rc . $x . " = '" . $v . "'"; + } + } + return $rc; + } + + $gb = $_GET['groupby']; + $limit = $_GET['limit']; + if($gb != "--") + $what = "mark, SEC_TO_TIME(SUM(TIME_TO_SEC(time))) as sum_time, SEC_TO_TIME(SUM(TIME_TO_SEC(timeuser))) as sum_timeuser"; + else + $what = "mark, time, timeuser, compilation, test, result, options"; + $clause = clause_for($c); + if($clause != "") + $query = "select $what from bench where " . clause_for($c); + else + $query = "select $what from bench "; + if( $gb != "--"){ + $query = $query. "group by $gb"; + } + + if($limit != "--") { + $query = $query. " LIMIT 0,$limit"; + } + + $query = $query. ";"; + + header("Location: showquery.php?query=".urlencode("Custom:@@@" . $query)); + exit; +?> diff --git a/helm/software/matita/scripts/public_html/index.html b/helm/software/matita/scripts/public_html/index.html new file mode 100644 index 000000000..12fd7be9f --- /dev/null +++ b/helm/software/matita/scripts/public_html/index.html @@ -0,0 +1,15 @@ + + + + + + + +

    MATITA BENCHMARKING SYSTEM

    +

    +

    + Go to the benchmark query page +
    +

    + + diff --git a/helm/software/matita/scripts/public_html/showquery.php b/helm/software/matita/scripts/public_html/showquery.php new file mode 100644 index 000000000..e7db764d8 --- /dev/null +++ b/helm/software/matita/scripts/public_html/showquery.php @@ -0,0 +1,62 @@ + + + + + + +

    QUERY results

    + $q) { ?> +

    +

    + +

    + + "; + foreach( $q[0] as $name => $txt) { + echo ""; + } + echo "\n"; + $i=0; + foreach ($q as $k => $v) { + $i = $i + 1; + if ( $i%2 == 0) + echo ""; + else + echo ""; + foreach( $v as $name => $txt) { + echo ""; + } + echo "\n"; + } + ?> +
    $name
    " . prettify($txt) . "
    + +

    BACK to the query page

    + + diff --git a/helm/software/matita/scripts/public_html/style.css b/helm/software/matita/scripts/public_html/style.css new file mode 100644 index 000000000..dc2df470d --- /dev/null +++ b/helm/software/matita/scripts/public_html/style.css @@ -0,0 +1,55 @@ +body { + font-family: sans-serif; + font-size: 12pt; +} + +h1 { + text-align: center; + background-color: #87CEFA; +} + +h2 { + margin-right: auto; + border-bottom-color: #87CEFA; + border-bottom-style: solid; + border-bottom-width: 2px; +} + +a, .button { + border: 1px outset; + text-decoration: none; + background-color: #e9e9e9; + color: black; + cursor:pointer; + font-size: small; + padding-left:4px; + padding-right:4px; +} + +li { + margin-bottom: 10pt; +} + +ul { + list-style-type: upper-roman; +} + +table, td { + border-style:none; + padding: 2px 6px 2px 6px; +} + +tr.odd { + background-color:#EEEEEE; +} +tr.even { + background-color:#CECECE; +} + +th { + border-style:solid; + border-width:0px 0px 1px 0px; + border-color: gray; +} + + diff --git a/helm/software/matita/scripts/shell_adder.php b/helm/software/matita/scripts/shell_adder.php new file mode 100755 index 000000000..a13005e55 --- /dev/null +++ b/helm/software/matita/scripts/shell_adder.php @@ -0,0 +1,6 @@ + diff --git a/helm/software/matita/scripts/shell_time2cents.php b/helm/software/matita/scripts/shell_time2cents.php new file mode 100755 index 000000000..4914fc24f --- /dev/null +++ b/helm/software/matita/scripts/shell_time2cents.php @@ -0,0 +1,4 @@ + diff --git a/helm/software/matita/template_makefile.in b/helm/software/matita/template_makefile.in new file mode 100644 index 000000000..57f1301d5 --- /dev/null +++ b/helm/software/matita/template_makefile.in @@ -0,0 +1,29 @@ +SRC=$(shell find @ROOT@ -name "*.ma" -a -type f) +TODO=$(SRC:%.ma=%.mo) + +MATITA_FLAGS= +MATITA_FLAGS+=-noprofile +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +MATITAC=@CC@ +MATITACLEAN=@CLEAN@ +MATITADEP=@DEP@ + +all: $(TODO) + +clean: + $(MATITACLEAN) $(MATITA_FLAGS) $(SRC) + rm -f $(TODO) + +%.moo: + ($(MATITAC) $(MATITA_FLAGS) -q -I @ROOT@ $< | (grep -v "^make" || true)) + +@DEPFILE@ : $(SRC) + $(MATITADEP) $(MATITA_FLAGS) -I '@ROOT@' $^ 1> @DEPFILE@ + +# this is the depend for full targets like: +# dir/dir/name.moo: dir/dir/name.ma dir/dep.moo +-include @DEPFILE@ diff --git a/helm/software/matita/tests/Makefile b/helm/software/matita/tests/Makefile new file mode 100644 index 000000000..34d4d120c --- /dev/null +++ b/helm/software/matita/tests/Makefile @@ -0,0 +1,57 @@ +SRC=$(wildcard *.ma) + +MATITA_FLAGS = -I .. +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +MATITAC=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac $(MATITA_FLAGS)" "../matitaclean $(MATITA_FLAGS)" /dev/null OK +MATITACOPT=../scripts/do_tests.sh $(DO_TESTS_OPTS) "../matitac.opt $(MATITA_FLAGS)" "../matitaclean.opt $(MATITA_FLAGS)" /dev/null OK +VERBOSEMATITAC=../matitac $(MATITA_FLAGS) +VERBOSEMATITACOPT=../matitac.opt $(MATITA_FLAGS) + +MATITACLEAN=../matitaclean $(MATITA_FLAGS) +MATITACLEANOPT=../matitaclean.opt $(MATITA_FLAGS) + +MATITADEP=../matitadep $(MATITA_FLAGS) +MATITADEPOPT=../matitadep.opt $(MATITA_FLAGS) + +DEPEND_NAME=.depend + +H=@ + +all: $(SRC:%.ma=%.mo) + +opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all + +verbose: + $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all + +%.opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) + +clean_: + $(H)rm -f __*not_for_matita + +clean: clean_ + $(H)$(MATITACLEAN) $(SRC) + +cleanall: clean_ + $(H)rm -f $(SRC:%.ma=%.moo) + $(H)$(MATITACLEAN) all + +depend: + $(H)rm -f $(DEPEND_NAME) + $(H)$(MAKE) $(DEPEND_NAME) +.PHONY: depend + +%.moo: + $(H)$(MATITAC) $< + +$(DEPEND_NAME): $(SRC) + $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ + +#include $(DEPEND_NAME) +include .depend diff --git a/helm/software/matita/tests/SK.ma b/helm/software/matita/tests/SK.ma new file mode 100644 index 000000000..708f92f30 --- /dev/null +++ b/helm/software/matita/tests/SK.ma @@ -0,0 +1,116 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/SK/". + +include "legacy/coq.ma". +alias symbol "eq" = "Coq's leibnitz's equality". + +theorem SKK: + \forall A:Set. + \forall app: A \to A \to A. + \forall K:A. + \forall S:A. + \forall H1: (\forall x,y:A.(app (app K x) y) = x). + \forall H2: (\forall x,y,z:A. + (app (app (app S x) y) z) = (app (app x z) (app y z))). + \forall x:A. + (app (app (app S K) K) x) = x. +intros.auto paramodulation. +qed. + +theorem bool1: + \forall A:Set. + \forall one:A. + \forall zero:A. + \forall add: A \to A \to A. + \forall mult: A \to A \to A. + \forall inv: A \to A. + \forall c1:(\forall x,y:A.(add x y) = (add y x)). + \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). + \forall d1: (\forall x,y,z:A. + (add x (mult y z)) = (mult (add x y) (add x z))). + \forall d2: (\forall x,y,z:A. + (mult x (add y z)) = (add (mult x y) (mult x z))). + \forall i1: (\forall x:A. (add x zero) = x). + \forall i2: (\forall x:A. (mult x one) = x). + \forall inv1: (\forall x:A. (add x (inv x)) = one). + \forall inv2: (\forall x:A. (mult x (inv x)) = zero). + (inv zero) = one. +intros.auto paramodulation. +qed. + +theorem bool2: + \forall A:Set. + \forall one:A. + \forall zero:A. + \forall add: A \to A \to A. + \forall mult: A \to A \to A. + \forall inv: A \to A. + \forall c1:(\forall x,y:A.(add x y) = (add y x)). + \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). + \forall d1: (\forall x,y,z:A. + (add x (mult y z)) = (mult (add x y) (add x z))). + \forall d2: (\forall x,y,z:A. + (mult x (add y z)) = (add (mult x y) (mult x z))). + \forall i1: (\forall x:A. (add x zero) = x). + \forall i2: (\forall x:A. (mult x one) = x). + \forall inv1: (\forall x:A. (add x (inv x)) = one). + \forall inv2: (\forall x:A. (mult x (inv x)) = zero). + \forall x:A. (mult x zero) = zero. +intros.auto paramodulation. +qed. + +theorem bool3: + \forall A:Set. + \forall one:A. + \forall zero:A. + \forall add: A \to A \to A. + \forall mult: A \to A \to A. + \forall inv: A \to A. + \forall c1:(\forall x,y:A.(add x y) = (add y x)). + \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). + \forall d1: (\forall x,y,z:A. + (add x (mult y z)) = (mult (add x y) (add x z))). + \forall d2: (\forall x,y,z:A. + (mult x (add y z)) = (add (mult x y) (mult x z))). + \forall i1: (\forall x:A. (add x zero) = x). + \forall i2: (\forall x:A. (mult x one) = x). + \forall inv1: (\forall x:A. (add x (inv x)) = one). + \forall inv2: (\forall x:A. (mult x (inv x)) = zero). + \forall x:A. (inv (inv x)) = x. +intros.auto paramodulation. +qed. + +theorem bool2: + \forall A:Set. + \forall one:A. + \forall zero:A. + \forall add: A \to A \to A. + \forall mult: A \to A \to A. + \forall inv: A \to A. + \forall c1:(\forall x,y:A.(add x y) = (add y x)). + \forall c2:(\forall x,y:A.(mult x y) = (mult y x)). + \forall d1: (\forall x,y,z:A. + (add x (mult y z)) = (mult (add x y) (add x z))). + \forall d2: (\forall x,y,z:A. + (mult x (add y z)) = (add (mult x y) (mult x z))). + \forall i1: (\forall x:A. (add x zero) = x). + \forall i2: (\forall x:A. (mult x one) = x). + \forall inv1: (\forall x:A. (add x (inv x)) = one). + \forall inv2: (\forall x:A. (mult x (inv x)) = zero). + \forall x,y:A. + (inv (mult x y)) = (add (inv x) (inv y)). +intros.auto paramodulation. +qed. diff --git a/helm/software/matita/tests/absurd.ma b/helm/software/matita/tests/absurd.ma new file mode 100644 index 000000000..fe789a00f --- /dev/null +++ b/helm/software/matita/tests/absurd.ma @@ -0,0 +1,26 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/absurd/". +include "legacy/coq.ma". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias id "not" = "cic:/Coq/Init/Logic/not.con". + +theorem stupid : \forall a:Prop. a \to not a \to 0 = 1. +intros. +absurd a. +assumption. +assumption. +qed. diff --git a/helm/software/matita/tests/apply.ma b/helm/software/matita/tests/apply.ma new file mode 100644 index 000000000..abd4a9407 --- /dev/null +++ b/helm/software/matita/tests/apply.ma @@ -0,0 +1,57 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +(* test _with_ the WHD on the apply argument *) +set "baseuri" "cic:/matita/tests/apply/". +include "legacy/coq.ma". + +alias id "not" = "cic:/Coq/Init/Logic/not.con". +alias id "False" = "cic:/Coq/Init/Logic/False.ind#xpointer(1/1)". + +theorem b: + \forall x:Prop. + (not x) \to x \to False. +intros. +apply H. +assumption. +qed. + +(* test _without_ the WHD on the apply argument *) + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". + +theorem a: + \forall A:Set. + \forall x: A. + not (x=x) \to not (x=x). +intros. +apply H. +qed. + + +(* this test shows what happens when a term of type A -> ? is applied to + a goal of type A' -> B: if A unifies with A' the unifier becomes ? := B + and no goal is opened; otherwise the unifier becomes ? := A' -> B and a + new goal of type A is created. *) +theorem c: + \forall A,B:Prop. + A \to (\forall P: Prop. A \to P) \to (A \to B) \land (B \to B). + intros 4; split; [ apply H1 | apply H1; exact H ]. +qed. + +(* this test requires the delta-expansion of not in the type of the applied + term (to reveal a product) *) +theorem d: \forall A: Prop. \lnot A \to A \to False. + intros. apply H. assumption. +qed. diff --git a/helm/software/matita/tests/assumption.ma b/helm/software/matita/tests/assumption.ma new file mode 100644 index 000000000..ef84002ac --- /dev/null +++ b/helm/software/matita/tests/assumption.ma @@ -0,0 +1,39 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/assumption". +include "legacy/coq.ma". + +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias num (instance 0) = "natural number". +alias symbol "and" (instance 0) = "Coq's logical and". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". + + +theorem stupid: + \forall a: 0 = 0. + \forall b: 3 + 2 = 5. + \forall c: (\lambda x:nat.x) 3 = 3. + 0=0 \land 3 + 2 = 5 \land 3 = 3. +intros. +split. +split. +clear H2. clear H1. +assumption. +clear H. +assumption. +assumption. +qed. + diff --git a/helm/software/matita/tests/bad_tests/Makefile b/helm/software/matita/tests/bad_tests/Makefile new file mode 100644 index 000000000..7620894f2 --- /dev/null +++ b/helm/software/matita/tests/bad_tests/Makefile @@ -0,0 +1,57 @@ +SRC=$(wildcard *.ma) + +MATITA_FLAGS = -I ../.. +NODB=false +ifeq ($(NODB),true) + MATITA_FLAGS += -nodb +endif + +MATITAC=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac $(MATITA_FLAGS) -noprofile" "../../matitaclean $(MATITA_FLAGS)" /dev/null FAIL +MATITACOPT=../../scripts/do_tests.sh $(DO_TESTS_OPTS) "../../matitac.opt $(MATITA_FLAGS) -noprofile" "../../matitaclean.opt $(MATITA_FLAGS)" /dev/null FAIL +VERBOSEMATITAC=../../matitac $(MATITA_FLAGS) +VERBOSEMATITACOPT=../../matitac.opt $(MATITA_FLAGS) + +MATITACLEAN=../../matitaclean $(MATITA_FLAGS) +MATITACLEANOPT=../../matitaclean.opt $(MATITA_FLAGS) + +MATITADEP=../../matitadep $(MATITA_FLAGS) +MATITADEPOPT=../../matitadep.opt $(MATITA_FLAGS) + +DEPEND_NAME=.depend + +H=@ + +all: $(SRC:%.ma=%.mo) + +opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' all + +verbose: + $(H)$(MAKE) MATITAC='$(VERBOSEMATITAC)' MATITACLEAN='$(MATITACLEAN)' MATITADEP='$(MATITADEP)' all + +%.opt: + $(H)$(MAKE) MATITAC='$(MATITACOPT)' MATITACLEAN='$(MATITACLEANOPT)' MATITADEP='$(MATITADEPOPT)' $(@:%.opt=%) + +clean_: + $(H)rm -f __*not_for_matita + +clean: clean_ + $(H)$(MATITACLEAN) $(SRC) + +cleanall: clean_ + $(H)rm -f $(SRC:%.ma=%.moo) + $(H)$(MATITACLEAN) all + +depend: + $(H)rm -f $(DEPEND_NAME) + $(H)$(MAKE) $(DEPEND_NAME) +.PHONY: depend + +%.moo: + $(H)$(MATITAC) $< + +$(DEPEND_NAME): $(SRC) + $(H)$(MATITADEP) $(SRC) > $@ || rm -f $@ + +#include $(DEPEND_NAME) +include .depend diff --git a/helm/software/matita/tests/bad_tests/auto.log b/helm/software/matita/tests/bad_tests/auto.log new file mode 100644 index 000000000..0cac60da3 --- /dev/null +++ b/helm/software/matita/tests/bad_tests/auto.log @@ -0,0 +1,100 @@ +Info: execution of auto.ma started: +Debug: Executing: ``set "baseuri" "cic:/matita/tests/auto/"'' +Debug: Executing: ``include cic:/matita/legacy/coq'' +Debug: Executing: ``Theorem a: @[\forall ((x): (@[nat])).(\forall ((y) ...'' +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Datatypes/nat.ind +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/eq.ind +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/minus.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/mult.con +Error: Bad name: a +Debug: Executing: ``intro.'' +Debug: Executing: ``auto.'' +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/trans_eq.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/z.var +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/f_equal3.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/f_equal2.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/f_equal.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/B.var +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Logic/Logic_lemmas/equality/f.var +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/add_sub_square_identity.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/mult_n_Sm.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/TreeAutomata/semantics/conservation_0_0.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/technical_lemma.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/ARITH/Chinese/Nat_complements/technical_lemma.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/plus_minus.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_plus_simpl_l_reverse.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_plus.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/minus_minus.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_plus_distr_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_plus_distr_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_plus_distr_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/mult_plus_distr2.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_n_n.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Minus/minus_n_O.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/minus_minus_lem1.con +WE HAVE NO UNIVERSE FILE FOR cic:/Cachan/SMC/mu/Splus_nm.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus_n_Sm.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus_Sn_m.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_Snm_nSm.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/TreeAutomata/bases/S_plus_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/Qpositive/mult_reg_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_reg_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_permute_2_in_4.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_permute.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_comm.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_assoc_reverse.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_assoc.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_plus_reg_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_plus_reg_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/plus_eq.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/plus_permute2.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/minus_eq_decompose.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/Qpositive/minus_decompose.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/minus_eq.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/eq_add_S.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/expand_mult2.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_n_2.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/ring/ArithRing/S_to_plus_one.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/ZArith/BinInt/ZL0.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/S_plus.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/plus_n_SO.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/plus_n_O.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_0_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Plus/plus_0_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Marseille/GC/lib_arith/lib_plus/plus_O_O.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/plus_eqO.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/plus_O_O.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Bertrand/Misc/plus_eqO.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/g0.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/McCarthy/g.var +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/mult_SO.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Bertrand/Misc/mult_SO.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack1.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/DEMOS/Demo_AutoRewrite/Ackermann/Ack.var +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_1_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_1_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/mult2_recompose.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_n_1.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Init/Peano/mult_n_O.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_0_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_0_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_comm.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_assoc_reverse.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_assoc.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/square_recompose.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_sym.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_permut.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/mult_assoc_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_mult_reg_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Rocq/SUBST/comparith/eq_mult_reg_l.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Rsa/MiscRsa/mult_eq.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/mult_sym.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/HARDWARE/GENE/Arith_compl/mult_permute.con +WE HAVE NO UNIVERSE FILE FOR cic:/Sophia-Antipolis/Float/Faux/minus_inv_lt_aux.con +WE HAVE NO UNIVERSE FILE FOR cic:/Coq/Arith/Mult/mult_minus_distr_r.con +WE HAVE NO UNIVERSE FILE FOR cic:/Nijmegen/QArith/sqrt2/mult_minus_distr_l.con +Error: Tactic error: No Applicable theorem diff --git a/helm/software/matita/tests/bad_tests/auto.ma b/helm/software/matita/tests/bad_tests/auto.ma new file mode 100755 index 000000000..c7bd62492 --- /dev/null +++ b/helm/software/matita/tests/bad_tests/auto.ma @@ -0,0 +1,27 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/auto/". +include "legacy/coq.ma". + +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "minus" (instance 0) = "Coq's natural minus". +alias symbol "plus" (instance 0) = "Coq's natural plus". +alias symbol "times" (instance 0) = "Coq's natural times". +theorem a : \forall x,y:nat. x*x+(S y) = O - x. +intros. +auto depth = 3. diff --git a/helm/software/matita/tests/bad_tests/baseuri.log b/helm/software/matita/tests/bad_tests/baseuri.log new file mode 100644 index 000000000..9185479df --- /dev/null +++ b/helm/software/matita/tests/bad_tests/baseuri.log @@ -0,0 +1,4 @@ +Info: execution of baseuri.ma started: +Debug: Executing: ``set "baseuri" "cic:/matita/tests/baseuri/"'' +Debug: Executing: ``set "baseuri" "cic:/matita/tests/baseuri/"'' +Error: Error: Redefinition of 'baseuri' is forbidden. diff --git a/helm/software/matita/tests/bad_tests/baseuri.ma b/helm/software/matita/tests/bad_tests/baseuri.ma new file mode 100644 index 000000000..0e06223fa --- /dev/null +++ b/helm/software/matita/tests/bad_tests/baseuri.ma @@ -0,0 +1,16 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/baseuri/". +set "baseuri" "cic:/matita/tests/baseuri/". diff --git a/helm/software/matita/tests/change.ma b/helm/software/matita/tests/change.ma new file mode 100644 index 000000000..b2ae3b7a0 --- /dev/null +++ b/helm/software/matita/tests/change.ma @@ -0,0 +1,40 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/change/". +include "legacy/coq.ma". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". + +theorem stupid: + \forall a:nat. + a = 5 \to + (3 + 2) = a. +intros. +change in \vdash (? ? % ?) with 5. +rewrite < H in \vdash (? ? % ?). +reflexivity. +qed. + +(* tests changing a term under a binder *) +alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". +theorem t: (\forall x:nat. x=x) \to True. + intro H. + change in match x in H : (\forall _.%) with (0+x). + change in H: (\forall _.(? ? ? (? % ?))) with 0. + constructor 1. +qed. + diff --git a/helm/software/matita/tests/clear.ma b/helm/software/matita/tests/clear.ma new file mode 100644 index 000000000..5aaf6c0d6 --- /dev/null +++ b/helm/software/matita/tests/clear.ma @@ -0,0 +1,30 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/clear". +include "legacy/coq.ma". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". + +theorem stupid: + \forall a: True. + \forall b: 0 = 0. + 0 = 0. +intros 1 (H). +clear H. +intros 1 (H). +exact H. +qed. + diff --git a/helm/software/matita/tests/clearbody.ma b/helm/software/matita/tests/clearbody.ma new file mode 100644 index 000000000..ca4b9316e --- /dev/null +++ b/helm/software/matita/tests/clearbody.ma @@ -0,0 +1,31 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/clearbody". +include "legacy/coq.ma". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". + + +theorem stupid : + let x \def 0 + 1 in x + 2 = x + 2. + intros. + clearbody x. + simplify. + generalize in \vdash (? ? (? % ?) (? % ?)). + intros. + reflexivity. + qed. + diff --git a/helm/software/matita/tests/coercions.ma b/helm/software/matita/tests/coercions.ma new file mode 100644 index 000000000..20b15cd26 --- /dev/null +++ b/helm/software/matita/tests/coercions.ma @@ -0,0 +1,64 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/coercions/". +include "legacy/coq.ma". + +inductive pos: Set \def +| one : pos +| next : pos \to pos. + +inductive nat:Set \def +| O : nat +| S : nat \to nat. + +inductive int: Set \def +| positive: nat \to int +| negative : nat \to int. + +inductive empty : Set \def . + +let rec pos2nat x \def + match x with + [ one \Rightarrow (S O) + | (next z) \Rightarrow S (pos2nat z)]. + +definition nat2int \def \lambda x. positive x. + +coercion cic:/matita/tests/coercions/pos2nat.con. + +coercion cic:/matita/tests/coercions/nat2int.con. + +definition fst \def \lambda x,y:int.x. + +theorem a: fst O one = fst (positive O) (next one). +reflexivity. +qed. + +definition double: + \forall f:int \to int. pos \to int +\def + \lambda f:int \to int. \lambda x : pos .f (nat2int x). + +definition double1: + \forall f:int \to int. pos \to int +\def + \lambda f:int \to int. \lambda x : pos .f (pos2nat x). + +definition double2: + \forall f:int \to int. pos \to int +\def + \lambda f:int \to int. \lambda x : pos .f (nat2int (pos2nat x)). + + diff --git a/helm/software/matita/tests/comments.ma b/helm/software/matita/tests/comments.ma new file mode 100644 index 000000000..41e8e9bb3 --- /dev/null +++ b/helm/software/matita/tests/comments.ma @@ -0,0 +1,36 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/comments/". +include "legacy/coq.ma". + +(* commento che va nell'ast, ma non viene contato + come step perche' non e' un executable +*) + +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +theorem a:0=0. + +(* nota *) +(** + + +apply Prop. +*) +reflexivity. +(* commenti che non devono essere colorati perche' + non c'e' nulla di eseguibile dopo di loro +*) +qed. diff --git a/helm/software/matita/tests/constructor.ma b/helm/software/matita/tests/constructor.ma new file mode 100644 index 000000000..7ea26d43c --- /dev/null +++ b/helm/software/matita/tests/constructor.ma @@ -0,0 +1,23 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/constructor". +include "legacy/coq.ma". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". + + +theorem stupid: 1 = 1. +constructor 1. +qed. diff --git a/helm/software/matita/tests/continuationals.ma b/helm/software/matita/tests/continuationals.ma new file mode 100644 index 000000000..f45061bad --- /dev/null +++ b/helm/software/matita/tests/continuationals.ma @@ -0,0 +1,80 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/test/continuationals/". +include "legacy/coq.ma". + +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +alias id "trans_equal" = "cic:/Coq/Init/Logic/trans_equal.con". +alias id "refl_equal" = "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)". +alias id "Z" = "cic:/Coq/ZArith/BinInt/Z.ind#xpointer(1/1)". + +theorem semicolon: \forall p:Prop.p\to p\land p. +intros (p); split; assumption. +qed. + +theorem branch:\forall x:nat.x=x. +intros (n); +elim n +[ reflexivity; +| reflexivity ]. +qed. + +theorem pos:\forall x:Z.x=x. +intros (n); +elim n; +[ 3: reflexivity; +| 2: reflexivity; +| reflexivity ] +qed. + +theorem dot:\forall x:Z.x=x. +intros (x). +elim x. +reflexivity. reflexivity. reflexivity. +qed. + +theorem dot_slice:\forall x:Z.x=x. +intros (x). +elim x; +[ elim x. reflexivity. reflexivity. reflexivity; +| reflexivity +| reflexivity ]; +qed. + +theorem focus:\forall x:Z.x=x. +intros (x); elim x. +focus 16 17; + reflexivity; +unfocus. +reflexivity. +qed. + +theorem skip:\forall x:nat.x=x. +intros (x). +apply trans_equal; +[ 2: apply (refl_equal nat x); +| skip +| reflexivity +] +qed. + +theorem skip_focus:\forall x:nat.x=x. +intros (x). +apply trans_equal; +[ focus 18; apply (refl_equal nat x); unfocus; +| skip +| reflexivity ] +qed. diff --git a/helm/software/matita/tests/contradiction.ma b/helm/software/matita/tests/contradiction.ma new file mode 100644 index 000000000..305a862cf --- /dev/null +++ b/helm/software/matita/tests/contradiction.ma @@ -0,0 +1,31 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/contradiction". +include "legacy/coq.ma". +alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". +alias id "not" = "cic:/Coq/Init/Logic/not.con". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". + + + +theorem stupid: \forall a:Prop. a \to not a \to 0 = 2. +intros. +letin H \def (H1 H). +contradiction. +qed. + + + diff --git a/helm/software/matita/tests/cut.ma b/helm/software/matita/tests/cut.ma new file mode 100644 index 000000000..a30fe2fab --- /dev/null +++ b/helm/software/matita/tests/cut.ma @@ -0,0 +1,25 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/cut". +include "legacy/coq.ma". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". + +theorem stupid: 3 = 3. + cut (3 = 3). + assumption. + reflexivity. +qed. + diff --git a/helm/software/matita/tests/decompose.ma b/helm/software/matita/tests/decompose.ma new file mode 100644 index 000000000..fe72f710a --- /dev/null +++ b/helm/software/matita/tests/decompose.ma @@ -0,0 +1,28 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/decompose". +include "legacy/coq.ma". +alias symbol "and" (instance 0) = "Coq's logical and". +alias symbol "or" (instance 0) = "Coq's logical or". + + + +theorem stupid: + \forall a,b,c:Prop. + (a \land c \lor b \land c) \to (c \land (b \lor a)). + intros.decompose H.split.assumption.right.assumption. + split.assumption.left.assumption.qed. + + diff --git a/helm/software/matita/tests/demodulation_coq.ma b/helm/software/matita/tests/demodulation_coq.ma new file mode 100644 index 000000000..aa9d5f185 --- /dev/null +++ b/helm/software/matita/tests/demodulation_coq.ma @@ -0,0 +1,52 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/demodulation/". + +include "legacy/coq.ma". + +alias num = "natural number". +alias symbol "times" = "Coq's natural times". +alias symbol "plus" = "Coq's natural plus". +alias symbol "eq" = "Coq's leibnitz's equality". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". + + +theorem p0 : \forall m:nat. m+O = m. +intro. demodulate. + +theorem p: \forall m.1*m = m. +intros.demodulate.reflexivity. +qed. + +theorem p2: \forall x,y:nat.(S x)*y = (y+x*y). +intros.demodulate.reflexivity. +qed. + +theorem p1: \forall x,y:nat.(S ((S x)*y+x))=(S x)+(y*x+y). +intros.demodulate.reflexivity. +qed. + +theorem p3: \forall x,y:nat. (x+y)*(x+y) = x*x + 2*(x*y) + (y*y). +intros.demodulate.reflexivity. +qed. + +theorem p4: \forall x:nat. (x+1)*(x-1)=x*x - 1. +intro. +apply (nat_case x) +[simplify.reflexivity +|intro.demodulate.reflexivity] +qed. + diff --git a/helm/software/matita/tests/demodulation_matita.ma b/helm/software/matita/tests/demodulation_matita.ma new file mode 100644 index 000000000..0f4827e46 --- /dev/null +++ b/helm/software/matita/tests/demodulation_matita.ma @@ -0,0 +1,33 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/demodulation_matita/". + +include "nat/minus.ma". + +theorem p2: \forall x,y:nat. x+x = (S(S O))*x. +intros.demodulate.reflexivity. +qed. + +theorem p4: \forall x:nat. (x+(S O))*(x-(S O))=x*x - (S O). +intro. +apply (nat_case x) +[simplify.reflexivity +|intro.demodulate.reflexivity] +qed. + +theorem p5: \forall x,y:nat. (x+y)*(x+y) = x*x + (S(S O))*(x*y) + (y*y). +intros.demodulate.reflexivity. +qed. + diff --git a/helm/software/matita/tests/discriminate.ma b/helm/software/matita/tests/discriminate.ma new file mode 100644 index 000000000..d8e4bf2e2 --- /dev/null +++ b/helm/software/matita/tests/discriminate.ma @@ -0,0 +1,40 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/discriminate". +include "legacy/coq.ma". +alias id "not" = "cic:/Coq/Init/Logic/not.con". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". + +inductive foo: Prop \def I_foo: foo. + +theorem stupid: + 1 = 0 \to (\forall p:Prop. p \to not p). + intros. + generalize in match I_foo. + discriminate H. +qed. + +inductive bar_list (A:Set): Set \def + | bar_nil: bar_list A + | bar_cons: A \to bar_list A \to bar_list A. + +alias id "False" = "cic:/Coq/Init/Logic/False.ind#xpointer(1/1)". +theorem stupid2: + \forall A:Set.\forall x:A.\forall l:bar_list A. + bar_nil A = bar_cons A x l \to False. + intros. + discriminate H. +qed. diff --git a/helm/software/matita/tests/elim.ma b/helm/software/matita/tests/elim.ma new file mode 100644 index 000000000..67d7fada1 --- /dev/null +++ b/helm/software/matita/tests/elim.ma @@ -0,0 +1,80 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/elim". +include "legacy/coq.ma". + +inductive stupidtype: Set \def + | Base : stupidtype + | Next : stupidtype \to stupidtype + | Pair : stupidtype \to stupidtype \to stupidtype. + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "exists" (instance 0) = "Coq's exists". +alias symbol "or" (instance 0) = "Coq's logical or". +alias num (instance 0) = "natural number". +alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". +alias id "refl_equal" = "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)". + +theorem serious: + \forall a:stupidtype. + a = Base + \lor + (\exists b:stupidtype.a = Next b) + \lor + (\exists c,d:stupidtype.a = Pair c d). +intros. +elim a. +clear a.left.left. + reflexivity. +clear H.clear a.left.right. + exists.exact s.reflexivity. +clear H.clear H1.clear a.right. + exists.exact s.exists.exact s1.reflexivity. +qed. + +theorem t: 0=0 \to stupidtype. + intros; constructor 1. +qed. + +(* In this test "elim t" should open a new goal 0=0 and put it in the *) +(* goallist so that the THEN tactical closes it using reflexivity. *) +theorem foo: let ax \def refl_equal ? 0 in t ax = t ax. + elim t; reflexivity. +qed. + +(* This test shows a bug where elim opens a new unus{ed,eful} goal *) + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". + +inductive sum (n:nat) : nat \to nat \to Set \def + k: \forall x,y. n = x + y \to sum n x y. + +theorem t': \forall x,y. \forall H: sum x y O. + match H with [ (k a b p) \Rightarrow a ] = x. + intros. + cut (y = y \to O = O \to match H with [ (k a b p) \Rightarrow a] = x). + apply Hcut; reflexivity. + apply + (sum_ind ? + (\lambda a,b,K. y=a \to O=b \to + match K with [ (k a b p) \Rightarrow a ] = x) + ? ? ? H). + goal 16. + simplify. intros. + generalize in match H1. + rewrite < H2; rewrite < H3.intro. + rewrite > H4.auto. +qed. diff --git a/helm/software/matita/tests/fguidi.ma b/helm/software/matita/tests/fguidi.ma new file mode 100644 index 000000000..c6eb2a9d8 --- /dev/null +++ b/helm/software/matita/tests/fguidi.ma @@ -0,0 +1,114 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/fguidi/". +include "legacy/coq.ma". + +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +alias id "le" = "cic:/matita/fguidi/le.ind#xpointer(1/1)". +alias id "False_ind" = "cic:/Coq/Init/Logic/False_ind.con". +alias id "I" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1/1)". +alias id "ex_intro" = "cic:/Coq/Init/Logic/ex.ind#xpointer(1/1/1)". +alias id "False" = "cic:/Coq/Init/Logic/False.ind#xpointer(1/1)". +alias id "True" = "cic:/Coq/Init/Logic/True.ind#xpointer(1/1)". + +alias symbol "and" (instance 0) = "Coq's logical and". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "exists" (instance 0) = "Coq's exists". + +definition is_S: nat \to Prop \def + \lambda n. match n with + [ O \Rightarrow False + | (S n) \Rightarrow True + ]. + +definition pred: nat \to nat \def + \lambda n. match n with + [ O \Rightarrow O + | (S n) \Rightarrow n + ]. + +theorem eq_gen_S_O: \forall x. (S x = O) \to \forall P:Prop. P. +intros. apply False_ind. cut (is_S O). auto paramodulation. elim H. exact I. +qed. + +theorem eq_gen_S_O_cc: (\forall P:Prop. P) \to \forall x. (S x = O). +intros. auto. +qed. + +theorem eq_gen_S_S: \forall m,n. (S m) = (S n) \to m = n. +intros. cut ((pred (S m)) = (pred (S n))). +assumption. elim H. auto paramodulation. +qed. + +theorem eq_gen_S_S_cc: \forall m,n. m = n \to (S m) = (S n). +intros. elim H. auto paramodulation. +qed. + +inductive le: nat \to nat \to Prop \def + le_zero: \forall n. (le O n) + | le_succ: \forall m, n. (le m n) \to (le (S m) (S n)). + +theorem le_refl: \forall x. (le x x). +intros. elim x. auto paramodulation. auto paramodulation. +qed. + +theorem le_gen_x_O_aux: \forall x, y. (le x y) \to (y =O) \to + (x = O). +intros 3. elim H. auto paramodulation. apply eq_gen_S_O. exact n1. auto paramodulation. +qed. + +theorem le_gen_x_O: \forall x. (le x O) \to (x = O). +intros. apply le_gen_x_O_aux. exact O. auto paramodulation. auto paramodulation. +qed. + +theorem le_gen_x_O_cc: \forall x. (x = O) \to (le x O). +intros. elim H. auto paramodulation. +qed. + +theorem le_gen_S_x_aux: \forall m,x,y. (le y x) \to (y = S m) \to + (\exists n. x = (S n) \land (le m n)). +intros 4. elim H. +apply eq_gen_S_O. exact m. elim H1. auto paramodulation. +cut (n = m). elim Hcut. apply ex_intro. exact n1. auto paramodulation. auto. (* paramodulation non trova la prova *) +qed. + +theorem le_gen_S_x: \forall m,x. (le (S m) x) \to + (\exists n. x = (S n) \land (le m n)). +intros. apply le_gen_S_x_aux. exact (S m). auto paramodulation. auto paramodulation. +qed. + +theorem le_gen_S_x_cc: \forall m,x. (\exists n. x = (S n) \land (le m n)) \to + (le (S m) x). +intros. elim H. elim H1. cut ((S x1) = x). elim Hcut. auto paramodulation. elim H2. auto paramodulation. +qed. + +theorem le_gen_S_S: \forall m,n. (le (S m) (S n)) \to (le m n). +intros. +lapply le_gen_S_x to H using H0. elim H0. elim H1. +lapply eq_gen_S_S to H2 using H4. rewrite > H4. assumption. +qed. + +theorem le_gen_S_S_cc: \forall m,n. (le m n) \to (le (S m) (S n)). +intros. auto paramodulation. +qed. + +(* +theorem le_trans: \forall x,y. (le x y) \to \forall z. (le y z) \to (le x z). +intros 1. elim x; clear H. clear x. +auto paramodulation. +fwd H1 [H]. decompose H. +*) diff --git a/helm/software/matita/tests/first.ma b/helm/software/matita/tests/first.ma new file mode 100644 index 000000000..4fca7b199 --- /dev/null +++ b/helm/software/matita/tests/first.ma @@ -0,0 +1,37 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/first/". + +inductive nat : Set \def + | O : nat + | S : nat \to nat. + +inductive eq (A:Set): A \to A \to Prop \def + refl: \forall x:A.eq A x x. + +inductive list (A:Set) : Set \def + | nil : list A + | cons : A \to list A \to list A. + +let rec list_len (A:Set) (l:list A) on l \def + match l with + [ nil \Rightarrow O + | (cons a tl) \Rightarrow S (list_len A tl)]. + +theorem stupid: \forall A:Set.eq ? (list_len A (nil ?)) O. +intros. +normalize. +apply refl. +qed. diff --git a/helm/software/matita/tests/fix_betareduction.ma b/helm/software/matita/tests/fix_betareduction.ma new file mode 100644 index 000000000..82f0b1cf6 --- /dev/null +++ b/helm/software/matita/tests/fix_betareduction.ma @@ -0,0 +1,26 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/fix_betareduction/". + +alias id "eq" = "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1)". +alias id "n" = "cic:/Suresnes/BDD/canonicite/Canonicity_BDT/n.con". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +theorem a: + (\forall p: nat \to Prop. + \forall n: nat. p n \to p n ) \to (eq nat n n). +intro. +apply (H (\lambda n:nat.(eq nat n n))). +reflexivity. +qed. diff --git a/helm/software/matita/tests/fold.ma b/helm/software/matita/tests/fold.ma new file mode 100644 index 000000000..a8cee1021 --- /dev/null +++ b/helm/software/matita/tests/fold.ma @@ -0,0 +1,26 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/fold". +include "legacy/coq.ma". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". +theorem t: \forall x:nat. 0+x=x. + intro. + simplify in match (0+x) in \vdash (? ? % ?). + fold simplify (0 + x) in \vdash (? ? % ?). + reflexivity. +qed. diff --git a/helm/software/matita/tests/generalize.ma b/helm/software/matita/tests/generalize.ma new file mode 100644 index 000000000..68492baa3 --- /dev/null +++ b/helm/software/matita/tests/generalize.ma @@ -0,0 +1,37 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/generalize". +include "legacy/coq.ma". + +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". +alias id "plus_comm" = "cic:/Coq/Arith/Plus/plus_comm.con". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". + +(* This tests is for the case of a pattern that contains metavariables *) +theorem t: \forall x. x + 4 = 4 + x. + intro. + generalize in match (S ?). + intro; apply plus_comm. +qed. + +(* This test used to fail because x was used in the wrong context *) +(* Once this was fixed it still did not work since apply is not *) +(* able to solve a goal that ends in a product. *) +theorem test2: \forall x. 4 + x = x + 4. + generalize in match 4. + exact plus_comm. +qed. diff --git a/helm/software/matita/tests/interactive/automatic_insertion.ma b/helm/software/matita/tests/interactive/automatic_insertion.ma new file mode 100644 index 000000000..56212bdc5 --- /dev/null +++ b/helm/software/matita/tests/interactive/automatic_insertion.ma @@ -0,0 +1,17 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/xxx". + +theorem t: And True (eq nat O O). split. exact (refl_equal nat O). exact I. qed. \ No newline at end of file diff --git a/helm/software/matita/tests/interactive/drop.ma b/helm/software/matita/tests/interactive/drop.ma new file mode 100644 index 000000000..b8718cdb8 --- /dev/null +++ b/helm/software/matita/tests/interactive/drop.ma @@ -0,0 +1,8 @@ +set "baseuri" "cic:/matita/tests/drop". + +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "leibnitz's equality". +alias symbol "plus" (instance 0) = "natural plus". +theorem a : O + 1 = 1. +drop. diff --git a/helm/software/matita/tests/interactive/grafite.ma b/helm/software/matita/tests/interactive/grafite.ma new file mode 100644 index 000000000..aaf570091 --- /dev/null +++ b/helm/software/matita/tests/interactive/grafite.ma @@ -0,0 +1,34 @@ +set "baseuri" "cic:/matita/tests/grafite/". + +(* commento *) +(** hint. *) + +inductive pippo : Type \def + | a : Type \to pippo + | b : Prop \to pippo + | c : Set \to pippo. + +definition pollo : Set \to Set \def + \lambda a:Set.a. + +inductive paolo : Prop \def t:paolo. + +theorem comeno : \forall p:pippo.pippo. +intros.assumption. +qed. + +definition f : pippo \to paolo \def + \lambda x:pippo. + match x with + [ (a z) \Rightarrow t + | (b z) \Rightarrow t + | (c z) \Rightarrow t ]. + +record w : Type \def { + mario : Prop; + pippo : Set +}. + +whelp locate pippo. + +print "coercions". diff --git a/helm/software/matita/tests/interactive/test5.ma b/helm/software/matita/tests/interactive/test5.ma new file mode 100644 index 000000000..e48cc827e --- /dev/null +++ b/helm/software/matita/tests/interactive/test5.ma @@ -0,0 +1,7 @@ +set "baseuri" "cic:/matita/tests/interactive/test5/". + +whelp instance + \lambda A:Set. + \lambda f: A \to A \to A. + \forall x,y : A. + f x y = f y x. diff --git a/helm/software/matita/tests/interactive/test6.ma b/helm/software/matita/tests/interactive/test6.ma new file mode 100644 index 000000000..4afdd3741 --- /dev/null +++ b/helm/software/matita/tests/interactive/test6.ma @@ -0,0 +1,7 @@ +set "baseuri" "cic:/matita/tests/interactive/test6/". + +whelp instance + \lambda A:Set. + \lambda f:A \to A \to A. + \forall x,y,z:A. + f x (f y z) = f (f x y) z. diff --git a/helm/software/matita/tests/interactive/test7.ma b/helm/software/matita/tests/interactive/test7.ma new file mode 100644 index 000000000..d7347ed9f --- /dev/null +++ b/helm/software/matita/tests/interactive/test7.ma @@ -0,0 +1,7 @@ +set "baseuri" "cic:/matita/tests/interactive/test7/". + +whelp instance + \lambda A:Set. + \lambda r:A \to A \to Prop. + \forall x:A. + r x x. diff --git a/helm/software/matita/tests/interactive/test_instance.ma b/helm/software/matita/tests/interactive/test_instance.ma new file mode 100644 index 000000000..7e02c0fff --- /dev/null +++ b/helm/software/matita/tests/interactive/test_instance.ma @@ -0,0 +1,16 @@ +set "baseuri" "cic:/matita/tests/interactive/instance/". + +whelp instance \lambda A:Set.\lambda P:A \to A \to Prop.\forall x:A. P x x. +whelp instance \lambda A:Set.\lambda P:A \to A \to Prop.\forall x,y:A. P x y \to P y x. +whelp instance \lambda A:Set.\lambda P:A \to A \to Prop.\forall x,y,z:A. P x y \to P y z \to P y z. +whelp instance \lambda A:Set.\lambda f:A \to A \to A. \forall x,y:A. f x y = f y x. +whelp instance \lambda A:Set.\lambda r : A \to A \to Prop. \forall x,y,z:A. r x y \to r y z \to r x z. + + +whelp instance \lambda A:Set.\lambda R:A \to A \to Prop.\forall x:A.\forall y:A.(R x y) \to \forall z:A.(R x z) \to \exists u:A.(R y u) \land (R z u). + +whelp instance λA:Set.λR:A→A→Prop.∀x:A.∀y:A.(R x y)→∀z:A.(R x z)→∃u:A.(R y u)∧(R z u). + +whelp instance \lambda A:Set. \lambda R:A\to A\to Prop. confluence A R. + +whelp instance \lambda A:Set. \lambda f:A\to A\to A. \lambda g:A\to A\to A. \forall x,y,z : A . f x (g y z) = g (f x y ) (f x z). diff --git a/helm/software/matita/tests/inversion.ma b/helm/software/matita/tests/inversion.ma new file mode 100644 index 000000000..3e49e0668 --- /dev/null +++ b/helm/software/matita/tests/inversion.ma @@ -0,0 +1,61 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/inversion_sum/". +include "legacy/coq.ma". + + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". + +inductive sum (n:nat) : nat \to nat \to Set \def + k: \forall x,y. n = x + y \to sum n x y. + + + + +theorem t: \forall x,y. \forall H: sum x y O. + match H with [ (k a b p) \Rightarrow a ] = x. + intros. + inversion H. + + (* + cut (y = y \to O = O \to match H with [ (k a b p) \Rightarrow a] = x). + apply Hcut; reflexivity. + apply + (sum_ind ? + (\lambda a,b,K. y=a \to O=b \to + match K with [ (k a b p) \Rightarrow a ] = x) + ? ? ? H). + goal 16.*) + simplify. intros. + generalize in match H1. + rewrite < H2; rewrite < H3.intro. + rewrite > H4.auto. +qed. + +theorem t1: \forall x,y. sum x y O \to x = y. +intros. + +(* +cut y=y \to O=O \to x = y. +apply Hcut.reflexivity. reflexivity. +apply (sum_ind ? (\lambda a,b,K. y=a \to O=b \to x=a) ? ? ? s).*) + +(*apply (sum_ind ? (\lambda a,b,K. y = a \to O = b \to x = a) ? ? ? s).*) +inversion s. +intros.simplify. +intros. +rewrite > H. rewrite < H2. auto. +qed. diff --git a/helm/software/matita/tests/inversion2.ma b/helm/software/matita/tests/inversion2.ma new file mode 100644 index 000000000..65dc75d40 --- /dev/null +++ b/helm/software/matita/tests/inversion2.ma @@ -0,0 +1,63 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/inversion/". +include "legacy/coq.ma". + +inductive nat : Set \def + O : nat + | S : nat \to nat. + + +inductive le (n:nat) : nat \to Prop \def + leO : le n n + | leS : \forall m. le n m \to le n (S m). + +theorem le_inv: + \forall n,m. + \forall P: nat -> nat -> Prop. + ? -> ? -> le n m -> P n m. +[7: + intros; + inversion H; + [ apply x + | simplify; + apply x1 + ] +| skip +| skip +| skip +| skip +| skip +| skip +] +qed. + +inductive ledx : nat \to nat \to Prop \def + ledxO : \forall n. ledx n n + | ledxS : \forall m.\forall n. ledx n m \to ledx n (S m). + + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". + +theorem test_inversion: \forall n. le n O \to n=O. + intros. + inversion H. + (* cut n=n \to O=O \to n=O. + apply Hcut; reflexivity. *) + (* elim H. BUG DI UNSHARING *) + (*apply (ledx_ind (\lambda x.\lambda y. n=x \to O=y \to x=y) ? ? ? ? H).*) + simplify. intros. reflexivity. + simplify. intros. discriminate H3. +qed. diff --git a/helm/software/matita/tests/letrec.ma b/helm/software/matita/tests/letrec.ma new file mode 100644 index 000000000..55933cd31 --- /dev/null +++ b/helm/software/matita/tests/letrec.ma @@ -0,0 +1,25 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/letrec/". + + +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". + +let rec plus n m \def + match n with + [ O \Rightarrow m + | (S x) \Rightarrow S (plus x m) ]. diff --git a/helm/software/matita/tests/match_inference.ma b/helm/software/matita/tests/match_inference.ma new file mode 100644 index 000000000..0e27ce409 --- /dev/null +++ b/helm/software/matita/tests/match_inference.ma @@ -0,0 +1,52 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/match_inference/". + +inductive pos: Set \def +| one : pos +| next : pos \to pos. + +inductive nat:Set \def +| O : nat +| S : nat \to nat. + +definition pos2nat : pos \to nat \def + \lambda x:pos . match x with + [ one \Rightarrow O + | (next z) \Rightarrow O]. + +inductive empty (x:nat) : nat \to Set \def . + +definition empty2nat : (empty O O) \to nat \def + \lambda x : (empty O O). S (match x in empty with []). + +inductive le (n:nat) : nat \to Prop \def + | le_n : le n n + | le_S : \forall m:nat. le n m \to le n (S m). + +inductive True : Prop \def + I : True. + +definition r : True \def + match (le_n O) with + [ le_n \Rightarrow I + | (le_S y p') \Rightarrow I ]. + +inductive Prod (A,B:Set): Set \def +pair : A \to B \to Prod A B. + +definition fst : \forall A,B:Set. (Prod A B) \to A \def +\lambda A,B:Set. \lambda p:(Prod A B). match p with +[(pair a b) \Rightarrow a]. diff --git a/helm/software/matita/tests/metasenv_ordering.ma b/helm/software/matita/tests/metasenv_ordering.ma new file mode 100644 index 000000000..fc354e6ae --- /dev/null +++ b/helm/software/matita/tests/metasenv_ordering.ma @@ -0,0 +1,139 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/metasenv_ordering". + +include "legacy/coq.ma". + +alias num (instance 0) = "natural number". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". + +(* REWRITE *) + +theorem th1 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 2 = 2. + intros. split; split; + [ reflexivity + | rewrite > H; + [ reflexivity | exact nat | exact (0=0) | exact Type ] + ] +qed. + +theorem th2 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 3 = 3. + intros. split. split. + focus 13. + rewrite > (H ?); [reflexivity | exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +theorem th3 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 4 = 4. + intros. split. split. + focus 13. + rewrite > (H ? ?); [reflexivity | exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +theorem th4 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 5 = 5. + intros. split. split. + focus 13. + rewrite > (H ? ? ?); [reflexivity | exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +(* APPLY *) + +theorem th5 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 6 = 6. + intros. split. split. + focus 13. + apply H; [exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +theorem th6 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 7 = 7. + intros. split. split. + focus 13. + apply (H ?); [exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +theorem th7 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 8 = 8. + intros. split. split. + focus 13. + apply (H ? ?); [exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +theorem th8 : + \forall P:Prop. + \forall H:(\forall G1: Set. \forall G2:Prop. \forall G3 : Type. 1 = 0). + 1 = 1 \land 1 = 0 \land 9 = 9. + intros. split. split. + focus 13. + apply (H ? ? ?); [exact nat | exact (0=0) | exact Type]. + unfocus. + reflexivity. + reflexivity. +qed. + +(* ELIM *) + +theorem th9: + \forall P,Q,R,S : Prop. R \to S \to \forall E:(R \to S \to P \land Q). P \land Q. + intros (P Q R S r s H). + elim (H ? ?); [split; assumption | exact r | exact s]. + qed. + +theorem th10: + \forall P,Q,R,S : Prop. R \to S \to \forall E:(R \to S \to P \land Q). P \land Q. + intros (P Q R S r s H). + elim (H ?); [split; assumption | exact r | exact s]. + qed. + +theorem th11: + \forall P,Q,R,S : Prop. R \to S \to \forall E:(R \to S \to P \land Q). P \land Q. + intros (P Q R S r s H). + elim H; [split; assumption | exact r | exact s]. + qed. diff --git a/helm/software/matita/tests/mysql_escaping.ma b/helm/software/matita/tests/mysql_escaping.ma new file mode 100644 index 000000000..bd0eb8d5a --- /dev/null +++ b/helm/software/matita/tests/mysql_escaping.ma @@ -0,0 +1,17 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/mysql_escaping/". + +theorem a' : Prop \to Prop.intros.assumption.qed. diff --git a/helm/software/matita/tests/paramodulation.ma b/helm/software/matita/tests/paramodulation.ma new file mode 100644 index 000000000..311b9455a --- /dev/null +++ b/helm/software/matita/tests/paramodulation.ma @@ -0,0 +1,32 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/paramodulation". +include "legacy/coq.ma". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". +alias num (instance 0) = "natural number". +alias symbol "times" (instance 0) = "Coq's natural times". + +theorem para1: + \forall n,m,n1,m1:nat. + n=m \to n1 = m1 \to (n + n1) = (m + m1). +intros. auto paramodulation. +qed. + +theorem para2: + \forall n:nat. n + n = 2 * n. +intros. auto paramodulation. +qed. diff --git a/helm/software/matita/tests/record.ma b/helm/software/matita/tests/record.ma new file mode 100644 index 000000000..ed9ecfed8 --- /dev/null +++ b/helm/software/matita/tests/record.ma @@ -0,0 +1,39 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/record/". + +record empty : Type \def {}. + +inductive True : Prop \def I: True. + +record pippo : Type \def +{ +a: Set ; +b: a \to Prop; +c: \forall x:a.(b x) \to a \to Type +}. + +record pluto (A, B:Set) : Type \def { +d: A \to B \to Prop; +e: \forall y:A.\forall z:B. (d y z) \to A \to B; +mario: \forall y:A.\forall z:B. \forall h:(d y z). \forall i : B \to Prop. + i (e y z h y) +}. + +record paperino: Prop \def { + paolo : Type; + pippo : paolo \to paolo; + piero : True +}. diff --git a/helm/software/matita/tests/replace.ma b/helm/software/matita/tests/replace.ma new file mode 100644 index 000000000..2b174af64 --- /dev/null +++ b/helm/software/matita/tests/replace.ma @@ -0,0 +1,39 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/replace/". +include "legacy/coq.ma". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". +alias symbol "times" (instance 0) = "Coq's natural times". +alias id "mult_n_O" = "cic:/Coq/Init/Peano/mult_n_O.con". +alias id "plus_n_O" = "cic:/Coq/Init/Peano/plus_n_O.con". + +theorem t: \forall x:nat. x * (x + 0) = (0 + x) * (x + x * 0). + intro. + replace in \vdash (? ? (? ? %) (? % %)) with x. + reflexivity. + rewrite < (mult_n_O x). + rewrite < (plus_n_O x). + reflexivity. + reflexivity. + auto. +qed. + +(* This test tests "replace in match t" where t contains some metavariables *) +theorem t2: 2 + (3 * 4) = (5 + 5) + 2 * 2. + replace in match (5+?) with (6 + 4); [reflexivity | reflexivity]. +qed. diff --git a/helm/software/matita/tests/rewrite.ma b/helm/software/matita/tests/rewrite.ma new file mode 100644 index 000000000..580ad13ed --- /dev/null +++ b/helm/software/matita/tests/rewrite.ma @@ -0,0 +1,64 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/rewrite/". +include "legacy/coq.ma". + +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias symbol "plus" (instance 0) = "Coq's natural plus". +alias id "plus_n_O" = "cic:/Coq/Init/Peano/plus_n_O.con". + +theorem a: + \forall a,b:nat. + a = b \to b + a + b + a= (\lambda j.((\lambda w.((\lambda x.x + b + w + j) a)) b)) a. +intros. +rewrite < H in \vdash (? ? ? ((\lambda j.((\lambda w.%) ?)) ?)). + +rewrite < H in \vdash (? ? % ?). + +simplify in \vdash (? ? ? ((\lambda _.((\lambda _.%) ?)) ?)). + +rewrite < H in \vdash (? ? ? (% ?)). +simplify. +reflexivity. +qed. + +theorem t: \forall n. 0=0 \to n = n + 0. + intros. + apply plus_n_O. +qed. + +(* In this test "rewrite < t" should open a new goal 0=0 and put it in *) +(* the goallist so that the THEN tactical closes it using reflexivity. *) +theorem foo: \forall n. n = n + 0. + intros. + rewrite < t; reflexivity. +qed. + +theorem test_rewrite_in_hyp: + \forall n,m. n + 0 = m \to m = n + 0 \to n=m \land m+0=n+0. + intros. + rewrite < plus_n_O in H. + rewrite > plus_n_O in H1. + split; [ exact H | exact H1]. +qed. + +theorem test_rewrite_in_hyp2: + \forall n,m. n + 0 = m \to n + 0 = m \to n=m \land n+0=m. + intros. + rewrite < plus_n_O in H H1 \vdash (? ? %). + split; [ exact H | exact H1]. +qed. diff --git a/helm/software/matita/tests/second.ma b/helm/software/matita/tests/second.ma new file mode 100644 index 000000000..450c67671 --- /dev/null +++ b/helm/software/matita/tests/second.ma @@ -0,0 +1,24 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/second/". +alias id "nat" = "cic:/matita/tests/first/nat.ind#xpointer(1/1)". +alias id "O" = "cic:/matita/tests/first/nat.ind#xpointer(1/1/1)". +alias id "eq" = "cic:/matita/tests/first/eq.ind#xpointer(1/1)". +alias id "refl" = "cic:/matita/tests/first/eq.ind#xpointer(1/1/1)". + +theorem ultrastupid : eq nat O O. +apply refl. +qed. + diff --git a/helm/software/matita/tests/simpl.ma b/helm/software/matita/tests/simpl.ma new file mode 100644 index 000000000..898122869 --- /dev/null +++ b/helm/software/matita/tests/simpl.ma @@ -0,0 +1,39 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/simpl/". +include "legacy/coq.ma". + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +alias id "plus" = "cic:/Coq/Init/Peano/plus.con". +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +alias id "not" = "cic:/Coq/Init/Logic/not.con". +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias id "plus_comm" = "cic:/Coq/Arith/Plus/plus_comm.con". + +theorem t: let f \def \lambda x,y. x y in f (\lambda x.S x) O = S O. + intros. simplify. change in \vdash (? ? (? ? %) ?) with O. + reflexivity. qed. + +theorem X: \forall x:nat. let myplus \def plus x in myplus (S O) = S x. + intros. simplify. change in \vdash (? ? (% ?) ?) with (plus x). + +rewrite > plus_comm. reflexivity. qed. + +theorem R: \forall x:nat. let uno \def x + O in S O + uno = 1 + x. + intros. simplify. + change in \vdash (? ? (? %) ?) with (x + O). + rewrite > plus_comm. reflexivity. qed. + diff --git a/helm/software/matita/tests/test2.ma b/helm/software/matita/tests/test2.ma new file mode 100644 index 000000000..92d9a5330 --- /dev/null +++ b/helm/software/matita/tests/test2.ma @@ -0,0 +1,26 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/test2/". +include "legacy/coq.ma". + +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +alias symbol "and" (instance 0) = "Coq's logical and". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +theorem a:\forall x:nat.x=x\land x=x. +intro. +split. +reflexivity. +reflexivity. +qed. diff --git a/helm/software/matita/tests/test3.ma b/helm/software/matita/tests/test3.ma new file mode 100644 index 000000000..cdf54906d --- /dev/null +++ b/helm/software/matita/tests/test3.ma @@ -0,0 +1,31 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/test3/". +include "legacy/coq.ma". + +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +theorem a:\forall x.x=x. +alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)". +[ exact nat. +| intro. reflexivity. +] +qed. +alias num (instance 0) = "natural number". +alias symbol "times" (instance 0) = "Coq's natural times". + +theorem b:\forall p:nat. p * 0=0. +intro. +auto. +qed. diff --git a/helm/software/matita/tests/test4.ma b/helm/software/matita/tests/test4.ma new file mode 100644 index 000000000..6c3b7ec6f --- /dev/null +++ b/helm/software/matita/tests/test4.ma @@ -0,0 +1,38 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/test4/". +include "legacy/coq.ma". + + +(* commento che va nell'ast, ma non viene contato + come step perche' non e' un executable +*) + +alias num (instance 0) = "natural number". +alias symbol "eq" (instance 0) = "Coq's leibnitz's equality". +theorem a:0=0. + +(* nota *) +(** + + +apply Prop. +*) +apply cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1). + +(* commenti che non devono essere colorati perche' + non c'e' nulla di eseguibile dopo di loro +*) +qed. diff --git a/helm/software/matita/tests/third.ma b/helm/software/matita/tests/third.ma new file mode 100644 index 000000000..124cdc121 --- /dev/null +++ b/helm/software/matita/tests/third.ma @@ -0,0 +1,24 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/tests/third/". +alias id "nat" = "cic:/matita/tests/first/nat.ind#xpointer(1/1)". +alias id "O" = "cic:/matita/tests/first/nat.ind#xpointer(1/1/1)". +alias id "eq" = "cic:/matita/tests/first/eq.ind#xpointer(1/1)". +alias id "ultrastupid" = "cic:/matita/tests/second/ultrastupid.con". + +theorem iperstupid : eq nat O O. +exact ultrastupid. +qed. + diff --git a/helm/software/matita/tests/unfold.ma b/helm/software/matita/tests/unfold.ma new file mode 100644 index 000000000..99f3931c2 --- /dev/null +++ b/helm/software/matita/tests/unfold.ma @@ -0,0 +1,41 @@ +(**************************************************************************) +(* ___ *) +(* ||M|| *) +(* ||A|| A project by Andrea Asperti *) +(* ||T|| *) +(* ||I|| Developers: *) +(* ||T|| The HELM team. *) +(* ||A|| http://helm.cs.unibo.it *) +(* \ / *) +(* \ / This file is distributed under the terms of the *) +(* v GNU General Public License Version 2 *) +(* *) +(**************************************************************************) + +set "baseuri" "cic:/matita/unfold". + +include "legacy/coq.ma". + +alias symbol "plus" (instance 0) = "Coq's natural plus". +definition myplus \def \lambda x,y. x+y. + +alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)". +lemma lem: \forall n. S (n + n) = (S n) + n. + intro; reflexivity. +qed. + +theorem trivial: \forall n. S (myplus n n) = myplus (S n) n. + unfold myplus in \vdash (\forall _.(? ? ? %)). + intro. + unfold myplus. + rewrite > lem. + reflexivity. +qed. + +(* This test needs to parse "uno" in the context of the hypothesis H, + not in the context of the goal. *) +alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)". +theorem t: let uno \def S O in uno + uno = S uno \to uno=uno. + intros. unfold uno in H. + reflexivity. +qed.