From: Stefano Zacchiroli Date: Thu, 12 Jan 2006 10:51:15 +0000 (+0000) Subject: test branch X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=commitdiff_plain;h=792b5d29ebae8f917043d9dd226692919b5d6ca1 test branch --- diff --git a/helm/matita/.depend b/helm/matita/.depend new file mode 100644 index 000000000..06c32e01d --- /dev/null +++ b/helm/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/matita/.ocamlinit b/helm/matita/.ocamlinit new file mode 100644 index 000000000..1585f71b2 --- /dev/null +++ b/helm/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/matita/AUTHORS b/helm/matita/AUTHORS new file mode 100644 index 000000000..a2da427a5 --- /dev/null +++ b/helm/matita/AUTHORS @@ -0,0 +1,5 @@ +Andrea Asperti +Luca Padovani +Enrico Tassi +Claudio Sacerdoti Coen +Stefano Zacchiroli diff --git a/helm/matita/LICENSE b/helm/matita/LICENSE new file mode 100644 index 000000000..7665cd2ce --- /dev/null +++ b/helm/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/matita/Makefile.in b/helm/matita/Makefile.in new file mode 100644 index 000000000..0614bda3d --- /dev/null +++ b/helm/matita/Makefile.in @@ -0,0 +1,350 @@ +export SHELL=/bin/bash + +NULL = + +MAKEFLAGS+=--no-print-directory +OCAMLPATH = ../ocaml/METAS/ +OCAMLFIND = OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH @OCAMLFIND@ +CAMLP4O = @CAMLP4O@ +LABLGLADECC = @LABLGLADECC@ +REQUIRES = @FINDLIB_REQUIRES@ +CREQUIRES = @FINDLIB_CREQUIRES@ +DEPREQUIRES = @FINDLIB_DEPREQUIRES@ +CLEANREQUIRES = @FINDLIB_CLEANREQUIRES@ +MAKEREQUIRES = @FINDLIB_MAKEREQUIRES@ +HAVE_OCAMLOPT = @HAVE_OCAMLOPT@ + +OCAML_FLAGS = -pp $(CAMLP4O) +PKGS = -package "$(REQUIRES)" +CPKGS = -package "$(CREQUIRES)" +DEPPKGS = -package "$(DEPREQUIRES)" +CLEANPKGS = -package "$(CLEANREQUIRES)" +MAKEPKGS = -package "$(MAKEREQUIRES)" +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) +DEPCMOS = $(CCMOS) +CLEANCMOS = $(CCMOS) +MAKECMOS = \ + buildTimeConf.cmo \ + matitamakeLib.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: 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 + +matita.conf.xml.sample: matita.conf.xml.sample.in + autoconf + ./configure + @echo + @echo "WARNING: The configuration sample file has changed!" + @echo + +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)) +DEPCMXS = $(patsubst %.cmo,%.cmx,$(DEPCMOS)) +CLEANCMXS = $(patsubst %.cmo,%.cmx,$(CLEANCMOS)) +MAKECMXS = $(patsubst %.cmo,%.cmx,$(MAKECMOS)) +LIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(REQUIRES)) +LIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(REQUIRES)) +CLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(CREQUIRES)) +CLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(CREQUIRES)) +DEPLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(DEPREQUIRES)) +DEPLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(DEPREQUIRES)) +CLEANLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(CLEANREQUIRES)) +CLEANLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(CLEANREQUIRES)) +MAKELIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MAKEREQUIRES)) +MAKELIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MAKEREQUIRES)) +.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: $(LIB_DEPS) $(CMOS) matita.ml + $(OCAMLC) $(PKGS) -linkpkg -o $@ $(CMOS) matita.ml +matita.opt: $(LIBX_DEPS) $(CMXS) matita.ml + $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml + +dump_moo: buildTimeConf.cmo dump_moo.ml + $(OCAMLC) $(PKGS) -linkpkg -o $@ $^ +dump_moo.opt: buildTimeConf.cmx dump_moo.ml + $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $^ + +matitac: $(CLIB_DEPS) $(CCMOS) $(MAINCMOS) matitac.ml + $(OCAMLC) $(CPKGS) -linkpkg -o $@ $(CCMOS) $(MAINCMOS) matitac.ml +matitac.opt: $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) matitac.ml + $(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml + +matitatop: matitatop.ml $(CLIB_DEPS) $(CCMOS) + $(OCAMLC) $(CPKGS) -linkpkg -o $@ toplevellib.cma $(CCMOS) $< + +# matitadep: matitadep.ml $(DEPLIB_DEPS) $(DEPCMOS) +# $(OCAMLC) $(DEPPKGS) -linkpkg -o $@ $(DEPCMOS) $< +# matitadep.opt: matitadep.ml $(DEPLIB_DEPS) $(DEPCMXS) +# $(OCAMLOPT) $(DEPPKGS) -linkpkg -o $@ $(DEPCMXS) $< +matitadep: matitac + @test -f $@ || ln -s $< $@ +matitadep.opt: matitac.opt + @test -f $@ || ln -s $< $@ + +# matitaclean: matitaclean.ml $(CLEANLIB_DEPS) $(CLEANCMOS) +# $(OCAMLC) $(CLEANPKGS) -linkpkg -o $@ $(CLEANCMOS) $< +# matitaclean.opt: matitaclean.ml $(CLEANLIB_DEPS) $(CLEANCMXS) +# $(OCAMLOPT) $(CLEANPKGS) -linkpkg -o $@ $(CLEANCMXS) $< +matitaclean: matitac + @test -f $@ || ln -s $< $@ +matitaclean.opt: matitac.opt + @test -f $@ || ln -s $< $@ + +# matitamake: matitamake.ml $(MAKECMOS) +# $(OCAMLC) $(MAKEPKGS) -linkpkg -o $@ $(MAKECMOS) $< +# matitamake.opt: matitamake.ml $(MAKECMXS) +# $(OCAMLOPT) $(MAKEPKGS) -linkpkg -o $@ $(MAKECMXS) $< +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 + -cd $* && make -k clean.opt opt +%-cleantests: matitaclean + -cd $* && make clean +%-cleantests-opt: matitaclean.opt + -cd $* && make clean.opt + +# {{{ Distribution stuff + +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: $(STATIC_LINK) matitadep.ml $(DEPLIB_DEPS) $(DEPCMXS) +# $(STATIC_LINK) $(STATIC_CLIBS) -- \ +# $(OCAMLOPT) $(DEPPKGS) -linkpkg -o $@ $(DEPCMXS) $< \ +# $(STATIC_EXTRA_CLIBS) +# strip $@ +matitadep.opt.static: matitac.opt.static + @test -f $@ || ln -s $< $@ +# matitaclean.opt.static: $(STATIC_LINK) matitaclean.ml $(CLEANLIB_DEPS) $(CLEANCMXS) +# $(STATIC_LINK) $(STATIC_CLIBS) -- \ +# $(OCAMLOPT) $(CLEANPKGS) -linkpkg -o $@ $(CLEANCMXS) $< \ +# $(STATIC_EXTRA_CLIBS) +# strip $@ +matitaclean.opt.static: matitac.opt.static + @test -f $@ || ln -s $< $@ +# matitamake.opt.static: $(STATIC_LINK) matitamake.ml $(MAKECMXS) +# $(STATIC_LINK) $(STATIC_CLIBS) -- \ +# $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(MAKECMXS) $< \ +# $(STATIC_EXTRA_CLIBS) +# strip $@ +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 config.log config.status Makefile buildTimeConf.ml + rm -f matita.glade.bak matita.gladep.bak + rm -rf autom4te.cache/ + rm -f configure 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 + $(OCAMLC) $(PKGS) -c $< +%.cmo %.cmi: %.ml + $(OCAMLC) $(PKGS) -c $< +%.cmx: %.ml + $(OCAMLOPT) $(PKGS) -c $< +%.annot: %.ml + $(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 new file mode 100644 index 000000000..83e5f3c18 --- /dev/null +++ b/helm/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/matita/applyTransformation.mli b/helm/matita/applyTransformation.mli new file mode 100644 index 000000000..8e023aea6 --- /dev/null +++ b/helm/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/matita/buildTimeConf.ml.in b/helm/matita/buildTimeConf.ml.in new file mode 100644 index 000000000..debafe003 --- /dev/null +++ b/helm/matita/buildTimeConf.ml.in @@ -0,0 +1,56 @@ +(* 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 coq_notation_script = runtime_base_dir ^ "/coq.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 new file mode 100644 index 000000000..949f8c5cb --- /dev/null +++ b/helm/matita/buildTimeConf.mli @@ -0,0 +1,51 @@ +(* 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 coq_notation_script : string +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 new file mode 100644 index 000000000..d3125efb7 --- /dev/null +++ b/helm/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/matita/configure.ac b/helm/matita/configure.ac new file mode 100644 index 000000000..1075d605d --- /dev/null +++ b/helm/matita/configure.ac @@ -0,0 +1,136 @@ +AC_INIT(matitaTypes.ml) + +# Distribution settings (i.e. settings to be manipulated before a release) +DEBUG_DEFAULT="true" +RT_BASE_DIR_DEFAULT="`pwd`" +MATITA_VERSION="0.0.1" +# End of distribution settings + +AC_CHECK_PROG(HAVE_OCAMLC, ocamlc, yes, no) +if test $HAVE_OCAMLC = "no"; then + AC_MSG_ERROR(could not find ocamlc) +fi +AC_CHECK_PROG(HAVE_OCAMLOPT, ocamlopt, yes, no) +if test $HAVE_OCAMLOPT = "no"; then + AC_MSG_WARN(could not find ocamlopt: native code compilation disabled) +fi +AC_CHECK_PROG(HAVE_OCAMLFIND, ocamlfind, yes, no) +if test $HAVE_OCAMLFIND = "yes"; then + OCAMLFIND="ocamlfind" +else + AC_MSG_ERROR(could not find ocamlfind) +fi +AC_CHECK_PROG(HAVE_LABLGLADECC, lablgladecc2, yes, no) +if test $HAVE_LABLGLADECC = "yes"; then + LABLGLADECC="lablgladecc2" +else + AC_MSG_ERROR(could not find lablgladecc2) +fi +AC_CHECK_PROG(HAVE_CAMLP4O, camlp4o, yes, no) +if test $HAVE_CAMLP4O = "yes"; then + CAMLP4O="camlp4o" +else + AC_MSG_ERROR(could not find camlp4o) +fi +FINDLIB_COMREQUIRES="\ +helm-cic_disambiguation \ +helm-grafite \ +helm-grafite_engine \ +helm-grafite_parser \ +helm-hgdome \ +helm-tactics \ +" +FINDLIB_CLEANREQUIRES="$FINDLIB_COMREQUIRES" +FINDLIB_DEPREQUIRES="$FINDLIB_COMREQUIRES" +FINDLIB_MAKEREQUIRES=" \ +helm-registry \ +helm-extlib \ +" +FINDLIB_CREQUIRES=" \ +$FINDLIB_COMREQUIRES \ +helm-paramodulation \ +" +FINDLIB_REQUIRES="\ +$FINDLIB_CREQUIRES \ +lablgtk2.glade \ +lablgtkmathview \ +lablgtksourceview \ +helm-xmldiff \ +helm-paramodulation \ +" +for r in $FINDLIB_REQUIRES +do + AC_MSG_CHECKING(for $r ocaml library) + if OCAMLPATH=../ocaml/METAS $OCAMLFIND query $r &> /dev/null; then + AC_MSG_RESULT(yes) + else + AC_MSG_ERROR(could not find $r ocaml library) + fi +done + +OCAMLFIND_COMMANDS="" +# AC_CHECK_PROG(HAVE_OCAMLC_OPT, ocamlc.opt, yes, no) +# if test $HAVE_OCAMLC_OPT = "yes"; then +# if test "$OCAMLFIND_COMMANDS" = ""; then +# OCAMLFIND_COMMANDS="ocamlc=ocamlc.opt" +# else +# OCAMLFIND_COMMANDS="$OCAMLFIND_COMMANDS ocamlc=ocamlc.opt" +# fi +# fi +# AC_CHECK_PROG(HAVE_OCAMLOPT_OPT, ocamlopt.opt, yes, no) +# if test $HAVE_OCAMLOPT_OPT = "yes"; then +# if test "$OCAMLFIND_COMMANDS" = ""; then +# OCAMLFIND_COMMANDS="ocamlopt=ocamlopt.opt" +# else +# OCAMLFIND_COMMANDS="$OCAMLFIND_COMMANDS ocamlopt=ocamlopt.opt" +# fi +# fi +if test "$OCAMLFIND_COMMANDS" != ""; then + OCAMLFIND="OCAMLFIND_COMMANDS='$OCAMLFIND_COMMANDS' $OCAMLFIND" +fi + +AC_MSG_CHECKING(--enable-debug argument) +AC_ARG_ENABLE(debug, + [ --enable-debug Turn on debugging], + [GIVEN="yes"; + case "${enableval}" in + yes) DEBUG=true ;; + no) DEBUG=false ;; + *) AC_MSG_ERROR(bad value ${enableval} for --enable-debug) ;; + esac], + [GIVEN="no"; DEBUG="$DEBUG_DEFAULT"]) +MSG=$GIVEN +if test "$DEBUG" = "true"; then + MSG="$MSG, debugging enabled." +else + MSG="$MSG, debugging disabled." +fi +AC_MSG_RESULT($MSG) + +AC_MSG_CHECKING(--with-runtime-dir argument) +AC_ARG_WITH(runtime-dir, + [ --with-runtime-dir Runtime directory (current working directory if not given)], + [ RT_BASE_DIR="${withval}" ], + [ RT_BASE_DIR="$RT_BASE_DIR_DEFAULT" ]) +AC_MSG_RESULT($RT_BASE_DIR) + +AC_SUBST(CAMLP4O) +AC_SUBST(DEBUG) +AC_SUBST(TRANSFORMER_MODULE) +AC_SUBST(FINDLIB_REQUIRES) +AC_SUBST(FINDLIB_CREQUIRES) +AC_SUBST(FINDLIB_DEPREQUIRES) +AC_SUBST(FINDLIB_CLEANREQUIRES) +AC_SUBST(FINDLIB_MAKEREQUIRES) +AC_SUBST(HAVE_OCAMLOPT) +AC_SUBST(LABLGLADECC) +AC_SUBST(OCAMLFIND) +AC_SUBST(RT_BASE_DIR) +AC_SUBST(MATITA_VERSION) + +AC_OUTPUT([ + matita.conf.xml.sample + buildTimeConf.ml + Makefile + gtkmathview.matita.conf.xml +]) diff --git a/helm/matita/contribs/LAMBDA-TYPES/Makefile b/helm/matita/contribs/LAMBDA-TYPES/Makefile new file mode 100644 index 000000000..5b2b2fa40 --- /dev/null +++ b/helm/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/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma b/helm/matita/contribs/LAMBDA-TYPES/lref_map_defs.ma new file mode 100644 index 000000000..572618808 --- /dev/null +++ b/helm/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/matita/contribs/LAMBDA-TYPES/terms_defs.ma b/helm/matita/contribs/LAMBDA-TYPES/terms_defs.ma new file mode 100644 index 000000000..cf7848abe --- /dev/null +++ b/helm/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/matita/contribs/LAMBDA-TYPES/tlt_defs.ma b/helm/matita/contribs/LAMBDA-TYPES/tlt_defs.ma new file mode 100644 index 000000000..390c067cc --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/Makefile new file mode 100644 index 000000000..489b2c135 --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_defs.ma new file mode 100644 index 000000000..17a53f64f --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_eq.ma new file mode 100644 index 000000000..cfcb57293 --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/class_le.ma new file mode 100644 index 000000000..a688ec63b --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_defs.ma new file mode 100644 index 000000000..c840fbdaf --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/coa_props.ma new file mode 100644 index 000000000..6c004073e --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_data.ma new file mode 100644 index 000000000..ed0afab4f --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/domain_defs.ma new file mode 100644 index 000000000..68cbd01fa --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/iff.ma new file mode 100644 index 000000000..9a9491923 --- /dev/null +++ b/helm/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/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma b/helm/matita/contribs/PREDICATIVE-TOPOLOGY/subset_defs.ma new file mode 100644 index 000000000..5d872040a --- /dev/null +++ b/helm/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/matita/core_notation.moo b/helm/matita/core_notation.moo new file mode 100644 index 000000000..c30e5142c --- /dev/null +++ b/helm/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/matita/dictionary-matita.xml b/helm/matita/dictionary-matita.xml new file mode 100644 index 000000000..35903486b --- /dev/null +++ b/helm/matita/dictionary-matita.xml @@ -0,0 +1,15 @@ + + + + + + + + + + + + + + + diff --git a/helm/matita/dist/Makefile b/helm/matita/dist/Makefile new file mode 100644 index 000000000..669137bf2 --- /dev/null +++ b/helm/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/matita/dist/fill_db.sh b/helm/matita/dist/fill_db.sh new file mode 100755 index 000000000..1ae28d336 --- /dev/null +++ b/helm/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/matita/dist/static_link/Makefile b/helm/matita/dist/static_link/Makefile new file mode 100644 index 000000000..5a02bb3b7 --- /dev/null +++ b/helm/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/matita/dist/static_link/static_link.ml b/helm/matita/dist/static_link/static_link.ml new file mode 100644 index 000000000..8b1d57668 --- /dev/null +++ b/helm/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/matita/dump_moo.ml b/helm/matita/dump_moo.ml new file mode 100644 index 000000000..05c21d40d --- /dev/null +++ b/helm/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/matita/gtkmathview.matita.conf.xml.in b/helm/matita/gtkmathview.matita.conf.xml.in new file mode 100644 index 000000000..0a33ae6d0 --- /dev/null +++ b/helm/matita/gtkmathview.matita.conf.xml.in @@ -0,0 +1,15 @@ + + +
+ @RT_BASE_DIR@/dictionary-matita.xml +
+
+
+
+
+ normal +
+
+
+
+ diff --git a/helm/matita/icons/matita-bulb-high.png b/helm/matita/icons/matita-bulb-high.png new file mode 100644 index 000000000..03b6e7f86 Binary files /dev/null and b/helm/matita/icons/matita-bulb-high.png differ diff --git a/helm/matita/icons/matita-bulb-low.png b/helm/matita/icons/matita-bulb-low.png new file mode 100644 index 000000000..f97302e48 Binary files /dev/null and b/helm/matita/icons/matita-bulb-low.png differ diff --git a/helm/matita/icons/matita-bulb-medium.png b/helm/matita/icons/matita-bulb-medium.png new file mode 100644 index 000000000..d3d449f93 Binary files /dev/null and b/helm/matita/icons/matita-bulb-medium.png differ diff --git a/helm/matita/icons/matita-folder.png b/helm/matita/icons/matita-folder.png new file mode 100644 index 000000000..ec0cc0839 Binary files /dev/null and b/helm/matita/icons/matita-folder.png differ diff --git a/helm/matita/icons/matita-object.png b/helm/matita/icons/matita-object.png new file mode 100644 index 000000000..fe89a30e8 Binary files /dev/null and b/helm/matita/icons/matita-object.png differ diff --git a/helm/matita/icons/matita-theory.png b/helm/matita/icons/matita-theory.png new file mode 100644 index 000000000..389152ef3 Binary files /dev/null and b/helm/matita/icons/matita-theory.png differ diff --git a/helm/matita/icons/matita.png b/helm/matita/icons/matita.png new file mode 100644 index 000000000..342bcb44c Binary files /dev/null and b/helm/matita/icons/matita.png differ diff --git a/helm/matita/icons/matita_medium.png b/helm/matita/icons/matita_medium.png new file mode 100644 index 000000000..335688af2 Binary files /dev/null and b/helm/matita/icons/matita_medium.png differ diff --git a/helm/matita/icons/matita_small.png b/helm/matita/icons/matita_small.png new file mode 100644 index 000000000..cfb017b0f Binary files /dev/null and b/helm/matita/icons/matita_small.png differ diff --git a/helm/matita/icons/meegg.png b/helm/matita/icons/meegg.png new file mode 100644 index 000000000..4c2be73fb Binary files /dev/null and b/helm/matita/icons/meegg.png differ diff --git a/helm/matita/icons/whelp.png b/helm/matita/icons/whelp.png new file mode 100644 index 000000000..5597d51e6 Binary files /dev/null and b/helm/matita/icons/whelp.png differ diff --git a/helm/matita/icons/whelp.svg b/helm/matita/icons/whelp.svg new file mode 100644 index 000000000..c1da66f6d --- /dev/null +++ b/helm/matita/icons/whelp.svg @@ -0,0 +1,221 @@ + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + h + + e + + l + + p + + W + + + diff --git a/helm/matita/library/Makefile b/helm/matita/library/Makefile new file mode 100644 index 000000000..fd278eb40 --- /dev/null +++ b/helm/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/matita/library/Q/q.ma b/helm/matita/library/Q/q.ma new file mode 100644 index 000000000..340154979 --- /dev/null +++ b/helm/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/matita/library/Z/compare.ma b/helm/matita/library/Z/compare.ma new file mode 100644 index 000000000..4a5025975 --- /dev/null +++ b/helm/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/matita/library/Z/times.ma b/helm/matita/library/Z/times.ma new file mode 100644 index 000000000..e5e1cdb45 --- /dev/null +++ b/helm/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/matita/library/Z/z.ma b/helm/matita/library/Z/z.ma new file mode 100644 index 000000000..ea50a2cd9 --- /dev/null +++ b/helm/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/matita/library/datatypes/bool.ma b/helm/matita/library/datatypes/bool.ma new file mode 100644 index 000000000..3292e6789 --- /dev/null +++ b/helm/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/matita/library/datatypes/compare.ma b/helm/matita/library/datatypes/compare.ma new file mode 100644 index 000000000..c4fd119a5 --- /dev/null +++ b/helm/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/matita/library/datatypes/constructors.ma b/helm/matita/library/datatypes/constructors.ma new file mode 100644 index 000000000..2ac1cb376 --- /dev/null +++ b/helm/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/matita/library/higher_order_defs/functions.ma b/helm/matita/library/higher_order_defs/functions.ma new file mode 100644 index 000000000..a1b54c80c --- /dev/null +++ b/helm/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/matita/library/higher_order_defs/ordering.ma b/helm/matita/library/higher_order_defs/ordering.ma new file mode 100644 index 000000000..c2b351d7a --- /dev/null +++ b/helm/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/matita/library/higher_order_defs/relations.ma b/helm/matita/library/higher_order_defs/relations.ma new file mode 100644 index 000000000..029b229dc --- /dev/null +++ b/helm/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/matita/library/legacy/coq.ma b/helm/matita/library/legacy/coq.ma new file mode 100644 index 000000000..ea1f5935d --- /dev/null +++ b/helm/matita/library/legacy/coq.ma @@ -0,0 +1,44 @@ +set "baseuri" "cic:/matita/legacy/". + +(* 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 new file mode 100644 index 000000000..ffa2c8ef9 --- /dev/null +++ b/helm/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/matita/library/list/sort.ma b/helm/matita/library/list/sort.ma new file mode 100644 index 000000000..939cecede --- /dev/null +++ b/helm/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/matita/library/logic/connectives.ma b/helm/matita/library/logic/connectives.ma new file mode 100644 index 000000000..4cbea3529 --- /dev/null +++ b/helm/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/matita/library/logic/equality.ma b/helm/matita/library/logic/equality.ma new file mode 100644 index 000000000..b87dc6c95 --- /dev/null +++ b/helm/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/matita/library/nat/chinese_reminder.ma b/helm/matita/library/nat/chinese_reminder.ma new file mode 100644 index 000000000..30cc7440f --- /dev/null +++ b/helm/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/matita/library/nat/compare.ma b/helm/matita/library/nat/compare.ma new file mode 100644 index 000000000..264731580 --- /dev/null +++ b/helm/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/matita/library/nat/congruence.ma b/helm/matita/library/nat/congruence.ma new file mode 100644 index 000000000..af744cf34 --- /dev/null +++ b/helm/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/matita/library/nat/count.ma b/helm/matita/library/nat/count.ma new file mode 100644 index 000000000..20913fa60 --- /dev/null +++ b/helm/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/matita/library/nat/div_and_mod.ma b/helm/matita/library/nat/div_and_mod.ma new file mode 100644 index 000000000..e9831f82a --- /dev/null +++ b/helm/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/matita/library/nat/exp.ma b/helm/matita/library/nat/exp.ma new file mode 100644 index 000000000..11d84f74c --- /dev/null +++ b/helm/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/matita/library/nat/factorial.ma b/helm/matita/library/nat/factorial.ma new file mode 100644 index 000000000..14217bbcb --- /dev/null +++ b/helm/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/matita/library/nat/factorization.ma b/helm/matita/library/nat/factorization.ma new file mode 100644 index 000000000..6a3094303 --- /dev/null +++ b/helm/matita/library/nat/factorization.ma @@ -0,0 +1,613 @@ +(**************************************************************************) +(* ___ *) +(* ||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 new file mode 100644 index 000000000..cc18a8bb9 --- /dev/null +++ b/helm/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/matita/library/nat/gcd.ma b/helm/matita/library/nat/gcd.ma new file mode 100644 index 000000000..65f61b581 --- /dev/null +++ b/helm/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/matita/library/nat/le_arith.ma b/helm/matita/library/nat/le_arith.ma new file mode 100644 index 000000000..a76183063 --- /dev/null +++ b/helm/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/matita/library/nat/lt_arith.ma b/helm/matita/library/nat/lt_arith.ma new file mode 100644 index 000000000..b8339f374 --- /dev/null +++ b/helm/matita/library/nat/lt_arith.ma @@ -0,0 +1,217 @@ +(**************************************************************************) +(* ___ *) +(* ||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 (? ? %).apply H.apply H2. +intros.assumption. +intro.apply False_ind.apply (not_le_Sn_n (f y)). +rewrite < H1 in \vdash (? ? %).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 new file mode 100644 index 000000000..0abed5ad3 --- /dev/null +++ b/helm/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/matita/library/nat/minus.ma b/helm/matita/library/nat/minus.ma new file mode 100644 index 000000000..710418d72 --- /dev/null +++ b/helm/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/matita/library/nat/nat.ma b/helm/matita/library/nat/nat.ma new file mode 100644 index 000000000..a75032d71 --- /dev/null +++ b/helm/matita/library/nat/nat.ma @@ -0,0 +1,106 @@ +(**************************************************************************) +(* ___ *) +(* ||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. +intros.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 new file mode 100644 index 000000000..5330f52ad --- /dev/null +++ b/helm/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/matita/library/nat/ord.ma b/helm/matita/library/nat/ord.ma new file mode 100644 index 000000000..24874c08a --- /dev/null +++ b/helm/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/matita/library/nat/orders.ma b/helm/matita/library/nat/orders.ma new file mode 100644 index 000000000..6ec0c9992 --- /dev/null +++ b/helm/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/matita/library/nat/permutation.ma b/helm/matita/library/nat/permutation.ma new file mode 100644 index 000000000..3e987e9e8 --- /dev/null +++ b/helm/matita/library/nat/permutation.ma @@ -0,0 +1,740 @@ +(**************************************************************************) +(* ___ *) +(* ||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. +(* uffa: lo ha espanso troppo *) +change with (invert_permut n f (f (invert_permut n f m)) = invert_permut n f m). +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 new file mode 100644 index 000000000..d595dad19 --- /dev/null +++ b/helm/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/matita/library/nat/primes.ma b/helm/matita/library/nat/primes.ma new file mode 100644 index 000000000..50b7d1221 --- /dev/null +++ b/helm/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/matita/library/nat/primes1.ma b/helm/matita/library/nat/primes1.ma new file mode 100644 index 000000000..3ec61ee4a --- /dev/null +++ b/helm/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/matita/library/nat/relevant_equations.ma b/helm/matita/library/nat/relevant_equations.ma new file mode 100644 index 000000000..f4cf43775 --- /dev/null +++ b/helm/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/matita/library/nat/sigma_and_pi.ma b/helm/matita/library/nat/sigma_and_pi.ma new file mode 100644 index 000000000..4f5f6cba0 --- /dev/null +++ b/helm/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/matita/library/nat/times.ma b/helm/matita/library/nat/times.ma new file mode 100644 index 000000000..2ae5ffd74 --- /dev/null +++ b/helm/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/matita/library/nat/totient.ma b/helm/matita/library/nat/totient.ma new file mode 100644 index 000000000..24c3920ed --- /dev/null +++ b/helm/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/matita/matita.conf.xml.sample.in b/helm/matita/matita.conf.xml.sample.in new file mode 100644 index 000000000..ee9aae13b --- /dev/null +++ b/helm/matita/matita.conf.xml.sample.in @@ -0,0 +1,36 @@ + + +

+ ~ + + +
+
+ true + true + cic:/matita/ + $(user.home)/.matita + $(user.name) + + false +
+
+ + mowgli.cs.unibo.it + helm + matita +
+
+ $(user.home)/.matita/getter/cache + /projects/helm/xml/dtd + + cic:/ + file:///projects/helm/library/coq_contribs/ + legacy + + + cic:/matita/ + file://$(user.home)/.matita/xml/matita/ + +
+ diff --git a/helm/matita/matita.glade b/helm/matita/matita.glade new file mode 100644 index 000000000..436dd7b26 --- /dev/null +++ b/helm/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/matita/matita.gtkrc b/helm/matita/matita.gtkrc new file mode 100644 index 000000000..91081c311 --- /dev/null +++ b/helm/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/matita/matita.lang b/helm/matita/matita.lang new file mode 100644 index 000000000..0c181ee44 --- /dev/null +++ b/helm/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/matita/matita.ma.templ b/helm/matita/matita.ma.templ new file mode 100644 index 000000000..ec1bc8006 --- /dev/null +++ b/helm/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/matita/matita.ml b/helm/matita/matita.ml new file mode 100644 index 000000000..016d69336 --- /dev/null +++ b/helm/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 _ = Paramodulation.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 new file mode 100644 index 000000000..ce34e404c --- /dev/null +++ b/helm/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/matita/matitaEngine.ml b/helm/matita/matitaEngine.ml new file mode 100644 index 000000000..f0d8ee46c --- /dev/null +++ b/helm/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/matita/matitaEngine.mli b/helm/matita/matitaEngine.mli new file mode 100644 index 000000000..a3c54dea6 --- /dev/null +++ b/helm/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/matita/matitaExcPp.ml b/helm/matita/matitaExcPp.ml new file mode 100644 index 000000000..28f25fd5c --- /dev/null +++ b/helm/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/matita/matitaExcPp.mli b/helm/matita/matitaExcPp.mli new file mode 100644 index 000000000..9d8c7739f --- /dev/null +++ b/helm/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/matita/matitaGtkMisc.ml b/helm/matita/matitaGtkMisc.ml new file mode 100644 index 000000000..553406635 --- /dev/null +++ b/helm/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/matita/matitaGtkMisc.mli b/helm/matita/matitaGtkMisc.mli new file mode 100644 index 000000000..1affd2a39 --- /dev/null +++ b/helm/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/matita/matitaGui.ml b/helm/matita/matitaGui.ml new file mode 100644 index 000000000..03e50588f --- /dev/null +++ b/helm/matita/matitaGui.ml @@ -0,0 +1,1278 @@ +(* 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 := + (fun 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 new file mode 100644 index 000000000..8c9064e1d --- /dev/null +++ b/helm/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/matita/matitaGuiTypes.mli b/helm/matita/matitaGuiTypes.mli new file mode 100644 index 000000000..1b9d17cad --- /dev/null +++ b/helm/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/matita/matitaInit.ml b/helm/matita/matitaInit.ml new file mode 100644 index 000000000..fec223b00 --- /dev/null +++ b/helm/matita/matitaInit.ml @@ -0,0 +1,223 @@ +(* 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 + +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 tilde_expand_key k = + try + Helm_registry.set k (HExtlib.tilde_expand (Helm_registry.get k)) + with Helm_registry.Key_not_found _ -> () + +let load_configuration init_status = + if not (already_configured [ConfigurationFile] init_status) then + begin + Helm_registry.load_from BuildTimeConf.matita_conf; + 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; + tilde_expand_key "matita.basedir"; + tilde_expand_key "user.home"; + 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 + 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_bool "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 registry_defaults = + [ + "db.nodb", "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 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"); + "-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)"); + "-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 + set_registry_values registry_defaults; + 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 + [ 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 + diff --git a/helm/matita/matitaInit.mli b/helm/matita/matitaInit.mli new file mode 100644 index 000000000..9d8671299 --- /dev/null +++ b/helm/matita/matitaInit.mli @@ -0,0 +1,37 @@ +(* 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 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 new file mode 100644 index 000000000..3c4997aec --- /dev/null +++ b/helm/matita/matitaMathView.ml @@ -0,0 +1,1103 @@ +(* 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)); + let name = "sequent_viewer.xml" in + HLog.debug ("load_sequent: dumping MathML to ./" ^ name); + ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()); + 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 + | _ -> + let name = "cic_browser.xml" in + HLog.debug ("cic_browser: dumping MathML to ./" ^ name); + ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()); + 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 new file mode 100644 index 000000000..ea0c077d8 --- /dev/null +++ b/helm/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/matita/matitaMisc.ml b/helm/matita/matitaMisc.ml new file mode 100644 index 000000000..0c4329e55 --- /dev/null +++ b/helm/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/matita/matitaMisc.mli b/helm/matita/matitaMisc.mli new file mode 100644 index 000000000..170a87c9b --- /dev/null +++ b/helm/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/matita/matitaScript.ml b/helm/matita/matitaScript.ml new file mode 100644 index 000000000..4c53f113b --- /dev/null +++ b/helm/matita/matitaScript.ml @@ -0,0 +1,818 @@ +(* 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 + +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 eval_with_engine + guistuff lexicon_status grafite_status user_goal parsed_text st += + try + eval_with_engine guistuff lexicon_status grafite_status user_goal parsed_text + st + with + | DependenciesParser.UnableToInclude what + | GrafiteEngine.IncludedFileNotCompiled what as exc -> + let compile_needed_and_go_on d = + let target = 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 + eval_with_engine guistuff lexicon_status grafite_status user_goal + parsed_text st + in + let do_nothing () = [], 0 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 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; + GrafiteParser.parse_statement (Ulexing.from_utf8_string text) + ~include_paths lexicon_status, 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 <- Some (Continuationals.Stack.find_goal p.stack) + | _ -> 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_and_executable 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.LNone loc + | 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_and_executable lexicon_status next + | GrafiteParser.LSome (GrafiteAst.Executable (loc, ex)) -> false + in + try + is_there_and_executable 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 new file mode 100644 index 000000000..8eb6d8dd9 --- /dev/null +++ b/helm/matita/matitaScript.mli @@ -0,0 +1,102 @@ +(* 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 + +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 new file mode 100644 index 000000000..13543dbb6 --- /dev/null +++ b/helm/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/matita/matitaTypes.mli b/helm/matita/matitaTypes.mli new file mode 100644 index 000000000..be77c4435 --- /dev/null +++ b/helm/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/matita/matitac.ml b/helm/matita/matitac.ml new file mode 100644 index 000000000..5599ba646 --- /dev/null +++ b/helm/matita/matitac.ml @@ -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/ + *) + +(* $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 new file mode 100644 index 000000000..3567c33f0 --- /dev/null +++ b/helm/matita/matitacLib.ml @@ -0,0 +1,265 @@ +(* 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_bool "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 new file mode 100644 index 000000000..636c51d57 --- /dev/null +++ b/helm/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/matita/matitaclean.ml b/helm/matita/matitaclean.ml new file mode 100644 index 000000000..826a4a282 --- /dev/null +++ b/helm/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/matita/matitaclean.mli b/helm/matita/matitaclean.mli new file mode 100644 index 000000000..45d57a886 --- /dev/null +++ b/helm/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/matita/matitadep.ml b/helm/matita/matitadep.ml new file mode 100644 index 000000000..48011c0b5 --- /dev/null +++ b/helm/matita/matitadep.ml @@ -0,0 +1,93 @@ +(* 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.load_configuration_file (); + MatitaInit.parse_cmdline (); + 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 new file mode 100644 index 000000000..45d57a886 --- /dev/null +++ b/helm/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/matita/matitamake.ml b/helm/matita/matitamake.ml new file mode 100644 index 000000000..9eab0f6d8 --- /dev/null +++ b/helm/matita/matitamake.ml @@ -0,0 +1,162 @@ +(* 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.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 new file mode 100644 index 000000000..8eba26fb0 --- /dev/null +++ b/helm/matita/matitamakeLib.ml @@ -0,0 +1,299 @@ +(* 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 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 = if nodb then ["NODB=true"] else [] 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 new file mode 100644 index 000000000..4aaab47b1 --- /dev/null +++ b/helm/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/matita/matitatop.ml b/helm/matita/matitatop.ml new file mode 100644 index 000000000..0aba1e9b5 --- /dev/null +++ b/helm/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/matita/scripts/README b/helm/matita/scripts/README new file mode 100644 index 000000000..d48449056 --- /dev/null +++ b/helm/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/matita/scripts/bench.sql b/helm/matita/scripts/bench.sql new file mode 100644 index 000000000..a45508548 --- /dev/null +++ b/helm/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/matita/scripts/crontab b/helm/matita/scripts/crontab new file mode 100644 index 000000000..4b4c1e80a --- /dev/null +++ b/helm/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/matita/scripts/crontab.sh b/helm/matita/scripts/crontab.sh new file mode 100644 index 000000000..5ad50de5e --- /dev/null +++ b/helm/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/matita/scripts/insert.awk b/helm/matita/scripts/insert.awk new file mode 100644 index 000000000..d62a6a3ec --- /dev/null +++ b/helm/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/matita/scripts/profile_svn.sh b/helm/matita/scripts/profile_svn.sh new file mode 100755 index 000000000..eca457ecc --- /dev/null +++ b/helm/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/matita/scripts/public_html/bench.php b/helm/matita/scripts/public_html/bench.php new file mode 100644 index 000000000..2ee540825 --- /dev/null +++ b/helm/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/matita/scripts/public_html/common.php b/helm/matita/scripts/public_html/common.php new file mode 100644 index 000000000..f2a9be030 --- /dev/null +++ b/helm/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/matita/scripts/public_html/composequery.php b/helm/matita/scripts/public_html/composequery.php new file mode 100644 index 000000000..49a943e47 --- /dev/null +++ b/helm/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/matita/scripts/public_html/index.html b/helm/matita/scripts/public_html/index.html new file mode 100644 index 000000000..12fd7be9f --- /dev/null +++ b/helm/matita/scripts/public_html/index.html @@ -0,0 +1,15 @@ + + + + + + + +

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 new file mode 100644 index 000000000..e7db764d8 --- /dev/null +++ b/helm/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/matita/scripts/public_html/style.css b/helm/matita/scripts/public_html/style.css new file mode 100644 index 000000000..dc2df470d --- /dev/null +++ b/helm/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/matita/scripts/shell_adder.php b/helm/matita/scripts/shell_adder.php new file mode 100755 index 000000000..a13005e55 --- /dev/null +++ b/helm/matita/scripts/shell_adder.php @@ -0,0 +1,6 @@ + diff --git a/helm/matita/scripts/shell_time2cents.php b/helm/matita/scripts/shell_time2cents.php new file mode 100755 index 000000000..4914fc24f --- /dev/null +++ b/helm/matita/scripts/shell_time2cents.php @@ -0,0 +1,4 @@ + diff --git a/helm/matita/template_makefile.in b/helm/matita/template_makefile.in new file mode 100644 index 000000000..8cbef1fd1 --- /dev/null +++ b/helm/matita/template_makefile.in @@ -0,0 +1,28 @@ +SRC=$(shell find @ROOT@ -name "*.ma" -a -type f) +TODO=$(SRC:%.ma=%.mo) + +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 new file mode 100644 index 000000000..34d4d120c --- /dev/null +++ b/helm/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/matita/tests/absurd.ma b/helm/matita/tests/absurd.ma new file mode 100644 index 000000000..fe789a00f --- /dev/null +++ b/helm/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/matita/tests/apply.ma b/helm/matita/tests/apply.ma new file mode 100644 index 000000000..abd4a9407 --- /dev/null +++ b/helm/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/matita/tests/assumption.ma b/helm/matita/tests/assumption.ma new file mode 100644 index 000000000..ef84002ac --- /dev/null +++ b/helm/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/matita/tests/bad_tests/Makefile b/helm/matita/tests/bad_tests/Makefile new file mode 100644 index 000000000..7620894f2 --- /dev/null +++ b/helm/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/matita/tests/bad_tests/auto.log b/helm/matita/tests/bad_tests/auto.log new file mode 100644 index 000000000..a66efc52d --- /dev/null +++ b/helm/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:/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 new file mode 100755 index 000000000..c7bd62492 --- /dev/null +++ b/helm/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/matita/tests/bad_tests/baseuri.log b/helm/matita/tests/bad_tests/baseuri.log new file mode 100644 index 000000000..9185479df --- /dev/null +++ b/helm/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/matita/tests/bad_tests/baseuri.ma b/helm/matita/tests/bad_tests/baseuri.ma new file mode 100644 index 000000000..0e06223fa --- /dev/null +++ b/helm/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/matita/tests/change.ma b/helm/matita/tests/change.ma new file mode 100644 index 000000000..b2ae3b7a0 --- /dev/null +++ b/helm/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/matita/tests/clear.ma b/helm/matita/tests/clear.ma new file mode 100644 index 000000000..5aaf6c0d6 --- /dev/null +++ b/helm/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/matita/tests/clearbody.ma b/helm/matita/tests/clearbody.ma new file mode 100644 index 000000000..ca4b9316e --- /dev/null +++ b/helm/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/matita/tests/coercions.ma b/helm/matita/tests/coercions.ma new file mode 100644 index 000000000..20b15cd26 --- /dev/null +++ b/helm/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/matita/tests/comments.ma b/helm/matita/tests/comments.ma new file mode 100644 index 000000000..41e8e9bb3 --- /dev/null +++ b/helm/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/matita/tests/constructor.ma b/helm/matita/tests/constructor.ma new file mode 100644 index 000000000..7ea26d43c --- /dev/null +++ b/helm/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/matita/tests/continuationals.ma b/helm/matita/tests/continuationals.ma new file mode 100644 index 000000000..f45061bad --- /dev/null +++ b/helm/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/matita/tests/contradiction.ma b/helm/matita/tests/contradiction.ma new file mode 100644 index 000000000..305a862cf --- /dev/null +++ b/helm/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/matita/tests/cut.ma b/helm/matita/tests/cut.ma new file mode 100644 index 000000000..a30fe2fab --- /dev/null +++ b/helm/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/matita/tests/decompose.ma b/helm/matita/tests/decompose.ma new file mode 100644 index 000000000..fe72f710a --- /dev/null +++ b/helm/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/matita/tests/discriminate.ma b/helm/matita/tests/discriminate.ma new file mode 100644 index 000000000..d8e4bf2e2 --- /dev/null +++ b/helm/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/matita/tests/elim.ma b/helm/matita/tests/elim.ma new file mode 100644 index 000000000..67d7fada1 --- /dev/null +++ b/helm/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/matita/tests/fguidi.ma b/helm/matita/tests/fguidi.ma new file mode 100644 index 000000000..c6eb2a9d8 --- /dev/null +++ b/helm/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/matita/tests/first.ma b/helm/matita/tests/first.ma new file mode 100644 index 000000000..4fca7b199 --- /dev/null +++ b/helm/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/matita/tests/fix_betareduction.ma b/helm/matita/tests/fix_betareduction.ma new file mode 100644 index 000000000..82f0b1cf6 --- /dev/null +++ b/helm/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/matita/tests/fold.ma b/helm/matita/tests/fold.ma new file mode 100644 index 000000000..a8cee1021 --- /dev/null +++ b/helm/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/matita/tests/generalize.ma b/helm/matita/tests/generalize.ma new file mode 100644 index 000000000..68492baa3 --- /dev/null +++ b/helm/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/matita/tests/interactive/automatic_insertion.ma b/helm/matita/tests/interactive/automatic_insertion.ma new file mode 100644 index 000000000..56212bdc5 --- /dev/null +++ b/helm/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/matita/tests/interactive/drop.ma b/helm/matita/tests/interactive/drop.ma new file mode 100644 index 000000000..b8718cdb8 --- /dev/null +++ b/helm/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/matita/tests/interactive/grafite.ma b/helm/matita/tests/interactive/grafite.ma new file mode 100644 index 000000000..aaf570091 --- /dev/null +++ b/helm/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/matita/tests/interactive/test5.ma b/helm/matita/tests/interactive/test5.ma new file mode 100644 index 000000000..e48cc827e --- /dev/null +++ b/helm/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/matita/tests/interactive/test6.ma b/helm/matita/tests/interactive/test6.ma new file mode 100644 index 000000000..4afdd3741 --- /dev/null +++ b/helm/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/matita/tests/interactive/test7.ma b/helm/matita/tests/interactive/test7.ma new file mode 100644 index 000000000..d7347ed9f --- /dev/null +++ b/helm/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/matita/tests/interactive/test_instance.ma b/helm/matita/tests/interactive/test_instance.ma new file mode 100644 index 000000000..7e02c0fff --- /dev/null +++ b/helm/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/matita/tests/inversion.ma b/helm/matita/tests/inversion.ma new file mode 100644 index 000000000..3e49e0668 --- /dev/null +++ b/helm/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/matita/tests/inversion2.ma b/helm/matita/tests/inversion2.ma new file mode 100644 index 000000000..65dc75d40 --- /dev/null +++ b/helm/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/matita/tests/letrec.ma b/helm/matita/tests/letrec.ma new file mode 100644 index 000000000..55933cd31 --- /dev/null +++ b/helm/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/matita/tests/match_inference.ma b/helm/matita/tests/match_inference.ma new file mode 100644 index 000000000..0e27ce409 --- /dev/null +++ b/helm/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/matita/tests/metasenv_ordering.ma b/helm/matita/tests/metasenv_ordering.ma new file mode 100644 index 000000000..fc354e6ae --- /dev/null +++ b/helm/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/matita/tests/mysql_escaping.ma b/helm/matita/tests/mysql_escaping.ma new file mode 100644 index 000000000..bd0eb8d5a --- /dev/null +++ b/helm/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/matita/tests/paramodulation.ma b/helm/matita/tests/paramodulation.ma new file mode 100644 index 000000000..311b9455a --- /dev/null +++ b/helm/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/matita/tests/record.ma b/helm/matita/tests/record.ma new file mode 100644 index 000000000..ed9ecfed8 --- /dev/null +++ b/helm/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/matita/tests/replace.ma b/helm/matita/tests/replace.ma new file mode 100644 index 000000000..2b174af64 --- /dev/null +++ b/helm/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/matita/tests/rewrite.ma b/helm/matita/tests/rewrite.ma new file mode 100644 index 000000000..580ad13ed --- /dev/null +++ b/helm/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/matita/tests/second.ma b/helm/matita/tests/second.ma new file mode 100644 index 000000000..450c67671 --- /dev/null +++ b/helm/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/matita/tests/simpl.ma b/helm/matita/tests/simpl.ma new file mode 100644 index 000000000..65e9d48a4 --- /dev/null +++ b/helm/matita/tests/simpl.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 *) +(* *) +(**************************************************************************) + +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 a : + \forall A:Set. + \forall x,y : A. + not (x = y) \to not(y = x). +intros. +unfold not. (* simplify. *) +intro. apply H. +symmetry. +exact H1. +qed. + +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 new file mode 100644 index 000000000..92d9a5330 --- /dev/null +++ b/helm/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/matita/tests/test3.ma b/helm/matita/tests/test3.ma new file mode 100644 index 000000000..cdf54906d --- /dev/null +++ b/helm/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/matita/tests/test4.ma b/helm/matita/tests/test4.ma new file mode 100644 index 000000000..6c3b7ec6f --- /dev/null +++ b/helm/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/matita/tests/third.ma b/helm/matita/tests/third.ma new file mode 100644 index 000000000..124cdc121 --- /dev/null +++ b/helm/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/matita/tests/unfold.ma b/helm/matita/tests/unfold.ma new file mode 100644 index 000000000..99f3931c2 --- /dev/null +++ b/helm/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. diff --git a/helm/ocaml/METAS/meta.helm-acic_content.src b/helm/ocaml/METAS/meta.helm-acic_content.src new file mode 100644 index 000000000..2ffa1551b --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-cic.src b/helm/ocaml/METAS/meta.helm-cic.src new file mode 100644 index 000000000..525cc9c22 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-cic_acic.src b/helm/ocaml/METAS/meta.helm-cic_acic.src new file mode 100644 index 000000000..51afe1bda --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-cic_annotations.src b/helm/ocaml/METAS/meta.helm-cic_annotations.src new file mode 100644 index 000000000..829efba0d --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-cic_annotations.src @@ -0,0 +1,5 @@ +requires="helm-cic helm-xml" +version="0.0.1" +archive(byte)="cic_annotations.cma" +archive(native)="cic_annotations.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-cic_annotations_cache.src b/helm/ocaml/METAS/meta.helm-cic_annotations_cache.src new file mode 100644 index 000000000..f21ea6d02 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-cic_annotations_cache.src @@ -0,0 +1,5 @@ +requires="helm-cic_annotations helm-getter" +version="0.0.1" +archive(byte)="cic_annotations_cache.cma" +archive(native)="cic_annotations_cache.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-cic_cache.src b/helm/ocaml/METAS/meta.helm-cic_cache.src new file mode 100644 index 000000000..6aacb1ae2 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-cic_cache.src @@ -0,0 +1,5 @@ +requires="helm-cic helm-getter" +version="0.0.1" +archive(byte)="cic_cache.cma" +archive(native)="cic_cache.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-cic_disambiguation.src b/helm/ocaml/METAS/meta.helm-cic_disambiguation.src new file mode 100644 index 000000000..d2e467aae --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-cic_proof_checking.src b/helm/ocaml/METAS/meta.helm-cic_proof_checking.src new file mode 100644 index 000000000..223a182a9 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-cic_textual_parser.src b/helm/ocaml/METAS/meta.helm-cic_textual_parser.src new file mode 100644 index 000000000..bc4f2fcd4 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-cic_textual_parser.src @@ -0,0 +1,5 @@ +requires="helm-cic" +version="0.0.1" +archive(byte)="cic_textual_parser.cma" +archive(native)="cic_textual_parser.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-cic_unification.src b/helm/ocaml/METAS/meta.helm-cic_unification.src new file mode 100644 index 000000000..75e2d4d31 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-content_pres.src b/helm/ocaml/METAS/meta.helm-content_pres.src new file mode 100644 index 000000000..cd3d36854 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-extlib.src b/helm/ocaml/METAS/meta.helm-extlib.src new file mode 100644 index 000000000..bfee89e3d --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-getter.src b/helm/ocaml/METAS/meta.helm-getter.src new file mode 100644 index 000000000..8a7badf74 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-grafite.src b/helm/ocaml/METAS/meta.helm-grafite.src new file mode 100644 index 000000000..0ae4a09d3 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-grafite_engine.src b/helm/ocaml/METAS/meta.helm-grafite_engine.src new file mode 100644 index 000000000..c7203724c --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-grafite_parser.src b/helm/ocaml/METAS/meta.helm-grafite_parser.src new file mode 100644 index 000000000..d921b5588 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-hbugs.src b/helm/ocaml/METAS/meta.helm-hbugs.src new file mode 100644 index 000000000..3c79fd96f --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-hbugs.src @@ -0,0 +1,4 @@ +requires="pcre http lablgtk2.glade helm-thread helm-xml helm-pxp helm-tactics" +version="0.0.1" +archive(byte)="hbugs.cma" +archive(native)="hbugs.cmxa" diff --git a/helm/ocaml/METAS/meta.helm-hgdome.src b/helm/ocaml/METAS/meta.helm-hgdome.src new file mode 100644 index 000000000..d06666f43 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-hmysql.src b/helm/ocaml/METAS/meta.helm-hmysql.src new file mode 100644 index 000000000..144141e28 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-lexicon.src b/helm/ocaml/METAS/meta.helm-lexicon.src new file mode 100644 index 000000000..35ab5dd36 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-library.src b/helm/ocaml/METAS/meta.helm-library.src new file mode 100644 index 000000000..d4955e05d --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-logger.src b/helm/ocaml/METAS/meta.helm-logger.src new file mode 100644 index 000000000..5b2e8d8ff --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-mathql.src b/helm/ocaml/METAS/meta.helm-mathql.src new file mode 100644 index 000000000..df553d7d5 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-mathql.src @@ -0,0 +1,5 @@ +requires="helm-urimanager" +version="1.3" +archive(byte)="mathql.cma" +archive(native)="mathql.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-mathql_generator.src b/helm/ocaml/METAS/meta.helm-mathql_generator.src new file mode 100644 index 000000000..c4168201b --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-mathql_generator.src @@ -0,0 +1,5 @@ +requires="helm-cic helm-cic_proof_checking helm-mathql" +version="1.3" +archive(byte)="mathql_generator.cma" +archive(native)="mathql_generator.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-mathql_interpreter.src b/helm/ocaml/METAS/meta.helm-mathql_interpreter.src new file mode 100644 index 000000000..42275abf6 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-mathql_interpreter.src @@ -0,0 +1,6 @@ +requires="helm-cic postgres mysql helm-mathql helm-registry" +#natile-galax +version="1.3" +archive(byte)="mathql_interpreter.cma" +archive(native)="mathql_interpreter.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-metadata.src b/helm/ocaml/METAS/meta.helm-metadata.src new file mode 100644 index 000000000..a5b138301 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-paramodulation.src b/helm/ocaml/METAS/meta.helm-paramodulation.src new file mode 100644 index 000000000..34a25fef0 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-paramodulation.src @@ -0,0 +1,5 @@ +requires="helm-registry helm-tactics" +version="0.0.1" +archive(byte)="paramodulation.cma" +archive(native)="paramodulation.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-pxp.src b/helm/ocaml/METAS/meta.helm-pxp.src new file mode 100644 index 000000000..6949a5712 --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-pxp.src @@ -0,0 +1,5 @@ +requires="pxp-engine pxp-lex-utf8 pxp-lex-iso88591 pxp-lex-iso885915 http" +version="0.0.1" +archive(byte)="pxp.cma" +archive(native)="pxp.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-registry.src b/helm/ocaml/METAS/meta.helm-registry.src new file mode 100644 index 000000000..82d364016 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-tactics.src b/helm/ocaml/METAS/meta.helm-tactics.src new file mode 100644 index 000000000..6e704ba06 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-tex_cic_textual_parser.src b/helm/ocaml/METAS/meta.helm-tex_cic_textual_parser.src new file mode 100644 index 000000000..dec21eebd --- /dev/null +++ b/helm/ocaml/METAS/meta.helm-tex_cic_textual_parser.src @@ -0,0 +1,5 @@ +requires="helm-cic" +version="0.0.1" +archive(byte)="tex_cic_textual_parser.cma" +archive(native)="tex_cic_textual_parser.cmxa" +linkopts="" diff --git a/helm/ocaml/METAS/meta.helm-thread.src b/helm/ocaml/METAS/meta.helm-thread.src new file mode 100644 index 000000000..5253060d2 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-urimanager.src b/helm/ocaml/METAS/meta.helm-urimanager.src new file mode 100644 index 000000000..ff1874688 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-utf8_macros.src b/helm/ocaml/METAS/meta.helm-utf8_macros.src new file mode 100644 index 000000000..c2da77649 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-whelp.src b/helm/ocaml/METAS/meta.helm-whelp.src new file mode 100644 index 000000000..20ea84329 --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-xml.src b/helm/ocaml/METAS/meta.helm-xml.src new file mode 100644 index 000000000..626e644fc --- /dev/null +++ b/helm/ocaml/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/ocaml/METAS/meta.helm-xmldiff.src b/helm/ocaml/METAS/meta.helm-xmldiff.src new file mode 100644 index 000000000..9cc918307 --- /dev/null +++ b/helm/ocaml/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/ocaml/Makefile.common.in b/helm/ocaml/Makefile.common.in new file mode 100644 index 000000000..af5ecab86 --- /dev/null +++ b/helm/ocaml/Makefile.common.in @@ -0,0 +1,124 @@ +# 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_DEST_DIR = @OCAMLFIND_DEST_DIR@ +OCAMLPATH = @OCAMLFIND_META_DIR@ + +PREPROCOPTIONS = -pp camlp4o +SYNTAXOPTIONS = -syntax camlp4o +PREREQ = +OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread +OCAMLDEBUGOPTIONS = -g +OCAMLARCHIVEOPTIONS = +OCAMLFIND = OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH @OCAMLFIND@ +REQUIRES := $(shell $(OCAMLFIND) -query -format '%(requires)' helm-$(PACKAGE)) +OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(PREPROCOPTIONS) +OCAMLOPT = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(PREPROCOPTIONS) +OCAMLDEP = $(OCAMLFIND) ocamldep -package "camlp4,$(REQUIRES)" $(SYNTAXOPTIONS) +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)) + + +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) + $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ + $(IMPLEMENTATION_FILES:%.ml=%.cmo) + +$(ARCHIVE_OPT): $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(LIBRARIES_OPT) + $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ + $(IMPLEMENTATION_FILES:%.ml=%.cmx) + +prereq: $(PREREQ) +all: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(ARCHIVE) +opt: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(ARCHIVE_OPT) +world: all opt +test: test.ml $(ARCHIVE) + $(OCAMLC) $(ARCHIVE) -linkpkg -o $@ $< +test.opt: test.ml $(ARCHIVE_OPT) + $(OCAMLOPT) $(ARCHIVE_OPT) -linkpkg -o $@ $< + +depend: $(DEPEND_FILES) + $(OCAMLDEP) $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) > .depend + +$(PACKAGE).ps: .dep.dot + dot -Tps -o $@ $< + +.dep.dot: .depend + ocamldot < .depend > $@ + +%.cmi: %.mli + $(OCAMLC) -c $< +%.cmo %.cmi: %.ml + $(OCAMLC) -c $< +%.cmx: %.ml + $(OCAMLOPT) -c $< +%.annot: %.ml + $(OCAMLC) -dtypes $(PKGS) -c $< +%.ml %.mli: %.mly + $(OCAMLYACC) $< +%.ml: %.mll + $(OCAMLLEX) $< + +$(IMPLEMENTATION_FILES:%.ml=%.cmo): $(LIBRARIES) +$(IMPLEMENTATION_FILES:%.ml=%.cmx): $(LIBRARIES_OPT) + +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 + +install: + mkdir $(OCAMLFIND_DEST_DIR)/$(PACKAGE) + cp $(OBJECTS_TO_INSTALL) $(OCAMLFIND_DEST_DIR)/$(PACKAGE) + +uninstall: + cd $(OCAMLFIND_DEST_DIR)/$(PACKAGE) && rm -f $(OBJECTS_TO_INSTALL) + rmdir $(OCAMLFIND_DEST_DIR)/$(PACKAGE) + +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 + +.PHONY: all opt world backup depend install uninstall clean ocamlinit + +ifneq ($(MAKECMDGOALS), depend) + include .depend +endif + +ifeq ($(MAKECMDGOALS), all) + $(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES) +endif + +ifeq ($(MAKECMDGOALS), opt) + $(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES_OPT) +endif + +ifeq ($(MAKECMDGOALS),) + $(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES) +endif + +NULL = + diff --git a/helm/ocaml/Makefile.in b/helm/ocaml/Makefile.in new file mode 100644 index 000000000..0c2d49411 --- /dev/null +++ b/helm/ocaml/Makefile.in @@ -0,0 +1,111 @@ +# 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 \ + paramodulation \ + cic_disambiguation \ + lexicon \ + grafite_engine \ + grafite_parser \ + $(NULL) + +OCAMLFIND_DEST_DIR = @OCAMLFIND_DEST_DIR@ +OCAMLPATH = @OCAMLFIND_META_DIR@ +OCAMLFIND = OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH @OCAMLFIND@ + +METAS = $(MODULES:%=METAS/META.helm-%) METAS/META.helm-cic_disambiguation + +all: metas $(MODULES:%=%.all) +opt: metas $(MODULES:%=%.opt) +world: all opt +metas: $(METAS) +depend: $(MODULES:%=%.depend) +install: $(MODULES:%=%.install) +uninstall: $(MODULES:%=%.uninstall) +clean: $(MODULES:%=%.clean) +clean_metas: + rm -f $(METAS) +distclean: clean clean_metas + rm -f Makefile Makefile.common configure config.log config.cache config.status + +.PHONY: all opt world metas depend install uninstall clean clean_metas distclean + +%.all: + OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH $(MAKE) -C $* all +%.opt: + OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH $(MAKE) -C $* opt +%.clean: + OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH $(MAKE) -C $* clean +%.depend: + OCAMLPATH=$(OCAMLPATH):$$OCAMLPATH $(MAKE) -C $* depend + +$(MODULES:%=%.install): + cd $(@:%.install=%) && make install + export TARGET=$(OCAMLFIND_META_DIR)/$(@:%.install=META.helm-%) ; \ + cp METAS/$(@:%.install=meta.helm-%.src) $$TARGET && \ + echo "directory=\"$(OCAMLFIND_DEST_DIR)/$(@:%.install=%)\"" >> $$TARGET +$(MODULES:%=%.uninstall): + cd $(@:%.uninstall=%) && make uninstall + rm -f $(OCAMLFIND_META_DIR)/$(@:%.uninstall=META.helm-%) +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 + ./patch_deps.sh $< $@ +.clustersdep.dot: .dep.dot + USE_CLUSTERS=yes ./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/TODO b/helm/ocaml/TODO new file mode 100644 index 000000000..e69de29bb diff --git a/helm/ocaml/acic_content/.depend b/helm/ocaml/acic_content/.depend new file mode 100644 index 000000000..f6399321e --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/Makefile b/helm/ocaml/acic_content/Makefile new file mode 100644 index 000000000..cc4da3781 --- /dev/null +++ b/helm/ocaml/acic_content/Makefile @@ -0,0 +1,19 @@ +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.common diff --git a/helm/ocaml/acic_content/acic2astMatcher.ml b/helm/ocaml/acic_content/acic2astMatcher.ml new file mode 100644 index 000000000..d62786cc7 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/acic2astMatcher.mli b/helm/ocaml/acic_content/acic2astMatcher.mli new file mode 100644 index 000000000..0a9ec6a6b --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/acic2content.ml b/helm/ocaml/acic_content/acic2content.ml new file mode 100644 index 000000000..8f3b13cfd --- /dev/null +++ b/helm/ocaml/acic_content/acic2content.ml @@ -0,0 +1,994 @@ +(* 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 teid = get_id te 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 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 new file mode 100644 index 000000000..e1dfb82de --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationEnv.ml b/helm/ocaml/acic_content/cicNotationEnv.ml new file mode 100644 index 000000000..32d4f0df5 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationEnv.mli b/helm/ocaml/acic_content/cicNotationEnv.mli new file mode 100644 index 000000000..d4f87097e --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationPp.ml b/helm/ocaml/acic_content/cicNotationPp.ml new file mode 100644 index 000000000..5dc6fd821 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationPp.mli b/helm/ocaml/acic_content/cicNotationPp.mli new file mode 100644 index 000000000..57a4d6b82 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationPt.ml b/helm/ocaml/acic_content/cicNotationPt.ml new file mode 100644 index 000000000..a66aa5feb --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationUtil.ml b/helm/ocaml/acic_content/cicNotationUtil.ml new file mode 100644 index 000000000..8e487ed11 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/cicNotationUtil.mli b/helm/ocaml/acic_content/cicNotationUtil.mli new file mode 100644 index 000000000..5d309d68f --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/content.ml b/helm/ocaml/acic_content/content.ml new file mode 100644 index 000000000..22733dcaa --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/content.mli b/helm/ocaml/acic_content/content.mli new file mode 100644 index 000000000..c1122b8f2 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/content2cic.ml b/helm/ocaml/acic_content/content2cic.ml new file mode 100644 index 000000000..9acea81fa --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/content2cic.mli b/helm/ocaml/acic_content/content2cic.mli new file mode 100644 index 000000000..9bb6509cc --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/contentPp.ml b/helm/ocaml/acic_content/contentPp.ml new file mode 100644 index 000000000..ca89fad7d --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/contentPp.mli b/helm/ocaml/acic_content/contentPp.mli new file mode 100644 index 000000000..a160ab1ff --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/termAcicContent.ml b/helm/ocaml/acic_content/termAcicContent.ml new file mode 100644 index 000000000..fddd777f7 --- /dev/null +++ b/helm/ocaml/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/ocaml/acic_content/termAcicContent.mli b/helm/ocaml/acic_content/termAcicContent.mli new file mode 100644 index 000000000..1fd57e0d0 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/.depend b/helm/ocaml/cic/.depend new file mode 100644 index 000000000..a35156331 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/Makefile b/helm/ocaml/cic/Makefile new file mode 100644 index 000000000..4e36af019 --- /dev/null +++ b/helm/ocaml/cic/Makefile @@ -0,0 +1,19 @@ +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.common diff --git a/helm/ocaml/cic/cic.ml b/helm/ocaml/cic/cic.ml new file mode 100644 index 000000000..64825e505 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/cicParser.ml b/helm/ocaml/cic/cicParser.ml new file mode 100644 index 000000000..317bcb9f0 --- /dev/null +++ b/helm/ocaml/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,[]) + | _ -> + 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 new file mode 100644 index 000000000..9472b4c54 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/cicUniv.ml b/helm/ocaml/cic/cicUniv.ml new file mode 100644 index 000000000..669025ffe --- /dev/null +++ b/helm/ocaml/cic/cicUniv.ml @@ -0,0 +1,949 @@ +(* 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 + +(*****************************************************************************) +(** 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 + +(*****************************************************************************) +(** 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 +;; + + +(*****************************************************************************) +(** _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 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',l' + + +(*****************************************************************************) +(** World interface **) +(*****************************************************************************) + +type universe_graph = bag + +let empty_ugraph = empty_bag + +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 = + begin_spending (); + let rc = add_eq ~fast u v b in + end_spending(); + rc + +let add_ge ?(fast=(!fast_implementation)) u v b = + begin_spending (); + let rc = add_ge ~fast u v b in + end_spending(); + rc + +let add_gt ?(fast=(!fast_implementation)) u v b = + begin_spending (); + let rc = add_gt ~fast u v b in + end_spending(); + rc + +(*****************************************************************************) +(** END: Decomment this for performance comparisons **) +(*****************************************************************************) + +let merge_ugraphs u v = + (* this sucks *) + let merge_brutal u v = + if u = empty_bag then v + else if v = empty_bag then u + else + 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 + merge_brutal u v + + +(*****************************************************************************) +(** 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 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'' (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 + +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, !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 = + MAL.fold + (fun universe entry map -> + MAL.add (recons_univ universe) (recons_entry entry) map) + graph MAL.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 new file mode 100644 index 000000000..be8c28bf3 --- /dev/null +++ b/helm/ocaml/cic/cicUniv.mli @@ -0,0 +1,152 @@ +(* 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: + universe_graph -> universe_graph -> 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 new file mode 100644 index 000000000..7c6e3eabe --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/cicUtil.mli b/helm/ocaml/cic/cicUtil.mli new file mode 100644 index 000000000..b6fd7459d --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/deannotate.ml b/helm/ocaml/cic/deannotate.ml new file mode 100644 index 000000000..f04f5aa10 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/deannotate.mli b/helm/ocaml/cic/deannotate.mli new file mode 100644 index 000000000..89b18d2d6 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/discrimination_tree.ml b/helm/ocaml/cic/discrimination_tree.ml new file mode 100644 index 000000000..0bef85a8c --- /dev/null +++ b/helm/ocaml/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 + let t = subterm_at_pos pos' term in 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 new file mode 100644 index 000000000..61631f478 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/helmLibraryObjects.ml b/helm/ocaml/cic/helmLibraryObjects.ml new file mode 100644 index 000000000..3038582ab --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/helmLibraryObjects.mli b/helm/ocaml/cic/helmLibraryObjects.mli new file mode 100644 index 000000000..677879899 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/libraryObjects.ml b/helm/ocaml/cic/libraryObjects.ml new file mode 100644 index 000000000..cc04322fa --- /dev/null +++ b/helm/ocaml/cic/libraryObjects.ml @@ -0,0 +1,116 @@ +(* 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 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 new file mode 100644 index 000000000..f87065980 --- /dev/null +++ b/helm/ocaml/cic/libraryObjects.mli @@ -0,0 +1,44 @@ +(* 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 + +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 new file mode 100644 index 000000000..c0e4bb2be --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/path_indexing.mli b/helm/ocaml/cic/path_indexing.mli new file mode 100644 index 000000000..899901618 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/test.ml b/helm/ocaml/cic/test.ml new file mode 100644 index 000000000..e15468f99 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/unshare.ml b/helm/ocaml/cic/unshare.ml new file mode 100644 index 000000000..e198bcd49 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic/unshare.mli b/helm/ocaml/cic/unshare.mli new file mode 100644 index 000000000..5582abcbf --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/.depend b/helm/ocaml/cic_acic/.depend new file mode 100644 index 000000000..3fc1e0dce --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/Makefile b/helm/ocaml/cic_acic/Makefile new file mode 100644 index 000000000..a7f1e19cf --- /dev/null +++ b/helm/ocaml/cic_acic/Makefile @@ -0,0 +1,12 @@ +PACKAGE = cic_acic +PREDICATES = + +INTERFACE_FILES = \ + eta_fixing.mli \ + doubleTypeInference.mli \ + cic2acic.mli \ + cic2Xml.mli \ + $(NULL) +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../Makefile.common diff --git a/helm/ocaml/cic_acic/cic2Xml.ml b/helm/ocaml/cic_acic/cic2Xml.ml new file mode 100644 index 000000000..7e97dea6f --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/cic2Xml.mli b/helm/ocaml/cic_acic/cic2Xml.mli new file mode 100644 index 000000000..22c5669df --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/cic2acic.ml b/helm/ocaml/cic_acic/cic2acic.ml new file mode 100644 index 000000000..8540e0e64 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/cic2acic.mli b/helm/ocaml/cic_acic/cic2acic.mli new file mode 100644 index 000000000..e6379283d --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/doubleTypeInference.ml b/helm/ocaml/cic_acic/doubleTypeInference.ml new file mode 100644 index 000000000..30a8f5c29 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/doubleTypeInference.mli b/helm/ocaml/cic_acic/doubleTypeInference.mli new file mode 100644 index 000000000..892e09f8a --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/eta_fixing.ml b/helm/ocaml/cic_acic/eta_fixing.ml new file mode 100644 index 000000000..22d26e1bd --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_acic/eta_fixing.mli b/helm/ocaml/cic_acic/eta_fixing.mli new file mode 100644 index 000000000..c6c68119d --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/.depend b/helm/ocaml/cic_disambiguation/.depend new file mode 100644 index 000000000..ca4124461 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/Makefile b/helm/ocaml/cic_disambiguation/Makefile new file mode 100644 index 000000000..729590da5 --- /dev/null +++ b/helm/ocaml/cic_disambiguation/Makefile @@ -0,0 +1,27 @@ + +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.common +OCAMLARCHIVEOPTIONS += -linkall + +disambiguateTypes.cmi: disambiguateTypes.mli + $(OCAMLC) -c -rectypes $< +disambiguateTypes.cmo: disambiguateTypes.ml disambiguateTypes.cmi + $(OCAMLC) -c -rectypes $< +disambiguateTypes.cmx: disambiguateTypes.ml disambiguateTypes.cmi + $(OCAMLOPT) -c -rectypes $< + diff --git a/helm/ocaml/cic_disambiguation/disambiguate.ml b/helm/ocaml/cic_disambiguation/disambiguate.ml new file mode 100644 index 000000000..667c50770 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/disambiguate.mli b/helm/ocaml/cic_disambiguation/disambiguate.mli new file mode 100644 index 000000000..a2cc0d0e7 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/disambiguateChoices.ml b/helm/ocaml/cic_disambiguation/disambiguateChoices.ml new file mode 100644 index 000000000..bdbc93179 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/disambiguateChoices.mli b/helm/ocaml/cic_disambiguation/disambiguateChoices.mli new file mode 100644 index 000000000..0ad498106 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/disambiguateTypes.ml b/helm/ocaml/cic_disambiguation/disambiguateTypes.ml new file mode 100644 index 000000000..4a2e43a20 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/disambiguateTypes.mli b/helm/ocaml/cic_disambiguation/disambiguateTypes.mli new file mode 100644 index 000000000..4f4b3c3ec --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/doc/precedence.txt b/helm/ocaml/cic_disambiguation/doc/precedence.txt new file mode 100644 index 000000000..09efea853 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/number_notation.ml b/helm/ocaml/cic_disambiguation/number_notation.ml new file mode 100644 index 000000000..2b3ce2d60 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/tests/aliases.txt b/helm/ocaml/cic_disambiguation/tests/aliases.txt new file mode 100644 index 000000000..12b09fff1 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_disambiguation/tests/eq.txt b/helm/ocaml/cic_disambiguation/tests/eq.txt new file mode 100644 index 000000000..6a826fc71 --- /dev/null +++ b/helm/ocaml/cic_disambiguation/tests/eq.txt @@ -0,0 +1 @@ +\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 new file mode 100644 index 000000000..87bb0159b --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/.depend b/helm/ocaml/cic_proof_checking/.depend new file mode 100644 index 000000000..06b9188a0 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/Makefile b/helm/ocaml/cic_proof_checking/Makefile new file mode 100644 index 000000000..3fbe90ddb --- /dev/null +++ b/helm/ocaml/cic_proof_checking/Makefile @@ -0,0 +1,39 @@ + +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.common + +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 new file mode 100644 index 000000000..22845725a --- /dev/null +++ b/helm/ocaml/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_univ uri = + try + (* the object should be in the cacheOfCookedObjects *) + let o,u,l = Cache.find_cooked uri in + o,(CicUniv.merge_ugraphs base_univ u),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_univ u),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_univ uri = + let o,g,_ = get_cooked_obj_with_univlist ?trust base_univ 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_univ uri = + try + let o,u,_ = Cache.find_cooked uri in + CheckedObj (o,(CicUniv.merge_ugraphs base_univ u)) + 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 u base_univ ) + 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_univ uri = + try + (* the object should be in the cacheOfCookedObjects *) + let o,u,_ = Cache.find_cooked uri in + o,(CicUniv.merge_ugraphs base_univ u) + 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_univ u) +;; + +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 new file mode 100644 index 000000000..55566a614 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicLogger.ml b/helm/ocaml/cic_proof_checking/cicLogger.ml new file mode 100644 index 000000000..5921c61b0 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicLogger.mli b/helm/ocaml/cic_proof_checking/cicLogger.mli new file mode 100644 index 000000000..408bc8879 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicMiniReduction.ml b/helm/ocaml/cic_proof_checking/cicMiniReduction.ml new file mode 100644 index 000000000..5c88713c5 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicMiniReduction.mli b/helm/ocaml/cic_proof_checking/cicMiniReduction.mli new file mode 100644 index 000000000..c923c6acf --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicPp.ml b/helm/ocaml/cic_proof_checking/cicPp.ml new file mode 100644 index 000000000..53f52272a --- /dev/null +++ b/helm/ocaml/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) -> + "[" ^ 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 + "{" ^ + String.concat " ; " ( + List.map + (function (uri,t) -> UriManager.name_of_uri uri ^ ":=" ^ pp t l) + exp_named_subst + ) ^ "}" +;; + +let ppterm t = + pp t [] +;; + +(* ppinductiveType (typename, inductive, arity, cons) *) +(* 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 new file mode 100644 index 000000000..e84ae4fed --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicReduction.ml b/helm/ocaml/cic_proof_checking/cicReduction.ml new file mode 100644 index 000000000..b7592f0fa --- /dev/null +++ b/helm/ocaml/cic_proof_checking/cicReduction.ml @@ -0,0 +1,1137 @@ +(* 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 CicReductionInternalError;; +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 + val to_stack : Cic.term -> stack_term + val to_stack_list : Cic.term list -> stack_term list + val to_env : Cic.term -> env_term + val to_ens : Cic.term -> ens_term + val from_stack : + unwind: + (int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> Cic.term) -> + stack_term -> Cic.term + val from_stack_list : + unwind: + (int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> Cic.term) -> + stack_term list -> Cic.term list + val from_env : env_term -> Cic.term + val from_ens : ens_term -> Cic.term + val stack_to_env : + reduce: + (int * env_term list * ens_term Cic.explicit_named_substitution * + Cic.term * stack_term list -> Cic.term) -> + unwind: + (int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> Cic.term) -> + stack_term -> env_term + val compute_to_env : + reduce: + (int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * + stack_term list -> Cic.term) -> + unwind: + (int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> Cic.term) -> + int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> env_term + val compute_to_stack : + reduce: + (int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * + stack_term list -> Cic.term) -> + unwind: + (int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> Cic.term) -> + int -> env_term list -> ens_term Cic.explicit_named_substitution -> + Cic.term -> stack_term + end +;; + +module CallByNameStrategy = + struct + type stack_term = Cic.term + type env_term = Cic.term + type ens_term = Cic.term + let to_stack v = v + let to_stack_list l = l + let to_env v = v + let to_ens v = v + let from_stack ~unwind v = v + let from_stack_list ~unwind l = l + let from_env v = v + let from_ens v = v + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens t = unwind k e ens t + let compute_to_env ~reduce ~unwind k e ens t = unwind k e ens t + end +;; + +module CallByValueStrategy = + struct + type stack_term = Cic.term + type env_term = Cic.term + type ens_term = Cic.term + let to_stack v = v + let to_stack_list l = l + let to_env v = v + let to_ens v = v + let from_stack ~unwind v = v + let from_stack_list ~unwind l = l + let from_env v = v + let from_ens v = v + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[]) + let compute_to_env ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[]) + end +;; + +module CallByValueStrategyByNameOnConstants = + struct + type stack_term = Cic.term + type env_term = Cic.term + type ens_term = Cic.term + let to_stack v = v + let to_stack_list l = l + let to_env v = v + let to_ens v = v + let from_stack ~unwind v = v + let from_stack_list ~unwind l = l + let from_env v = v + let from_ens v = v + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens = + function + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[]) + let compute_to_env ~reduce ~unwind k e ens = + function + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[]) + end +;; + +module LazyCallByValueStrategy = + struct + type stack_term = Cic.term lazy_t + type env_term = Cic.term lazy_t + type ens_term = Cic.term lazy_t + let to_stack v = lazy v + let to_stack_list l = List.map to_stack l + let to_env v = lazy v + let to_ens v = lazy v + let from_stack ~unwind v = Lazy.force v + let from_stack_list ~unwind l = List.map (from_stack ~unwind) l + let from_env v = Lazy.force v + let from_ens v = Lazy.force v + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[])) + let compute_to_env ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[])) + end +;; + +module LazyCallByValueStrategyByNameOnConstants = + struct + type stack_term = Cic.term lazy_t + type env_term = Cic.term lazy_t + type ens_term = Cic.term lazy_t + let to_stack v = lazy v + let to_stack_list l = List.map to_stack l + let to_env v = lazy v + let to_ens v = lazy v + let from_stack ~unwind v = Lazy.force v + let from_stack_list ~unwind l = List.map (from_stack ~unwind) l + let from_env v = Lazy.force v + let from_ens v = Lazy.force v + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens t = + lazy ( + match t with + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[])) + let compute_to_env ~reduce ~unwind k e ens t = + lazy ( + match t with + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[])) + end +;; + +module LazyCallByNameStrategy = + struct + type stack_term = Cic.term lazy_t + type env_term = Cic.term lazy_t + type ens_term = Cic.term lazy_t + let to_stack v = lazy v + let to_stack_list l = List.map to_stack l + let to_env v = lazy v + let to_ens v = lazy v + let from_stack ~unwind v = Lazy.force v + let from_stack_list ~unwind l = List.map (from_stack ~unwind) l + let from_env v = Lazy.force v + let from_ens v = Lazy.force v + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens t = lazy (unwind k e ens t) + let compute_to_env ~reduce ~unwind k e ens t = lazy (unwind k e ens t) + end +;; + +module + LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns += + struct + type stack_term = reduce:bool -> Cic.term + type env_term = reduce:bool -> Cic.term + type ens_term = reduce:bool -> Cic.term + let to_stack v = + let value = lazy v in + fun ~reduce -> Lazy.force value + let to_stack_list l = List.map to_stack l + let to_env v = + let value = lazy v in + fun ~reduce -> Lazy.force value + let to_ens v = + let value = lazy v in + fun ~reduce -> Lazy.force value + let from_stack ~unwind v = (v ~reduce:false) + let from_stack_list ~unwind l = List.map (from_stack ~unwind) l + let from_env v = (v ~reduce:true) + let from_ens v = (v ~reduce:true) + let stack_to_env ~reduce ~unwind v = v + let compute_to_stack ~reduce ~unwind k e ens t = + let svalue = + lazy ( + match t with + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[]) + ) in + let lvalue = + lazy (unwind k e ens t) + in + fun ~reduce -> + if reduce then Lazy.force svalue else Lazy.force lvalue + let compute_to_env ~reduce ~unwind k e ens t = + let svalue = + lazy ( + match t with + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[]) + ) in + let lvalue = + lazy (unwind k e ens t) + in + fun ~reduce -> + if reduce then Lazy.force svalue else Lazy.force lvalue + end +;; + +module ClosuresOnStackByValueFromEnvOrEnsStrategy = + struct + type stack_term = + int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term + type env_term = Cic.term + type ens_term = Cic.term + let to_stack v = (0,[],[],v) + let to_stack_list l = List.map to_stack l + let to_env v = v + let to_ens v = v + let from_stack ~unwind (k,e,ens,t) = unwind k e ens t + let from_stack_list ~unwind l = List.map (from_stack ~unwind) l + let from_env v = v + let from_ens v = v + let stack_to_env ~reduce ~unwind (k,e,ens,t) = reduce (k,e,ens,t,[]) + let compute_to_env ~reduce ~unwind k e ens t = + unwind k e ens t + let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t) + end +;; + +module ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy = + struct + type stack_term = + int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term + type env_term = Cic.term + type ens_term = Cic.term + let to_stack v = (0,[],[],v) + let to_stack_list l = List.map to_stack l + let to_env v = v + let to_ens v = v + let from_stack ~unwind (k,e,ens,t) = unwind k e ens t + let from_stack_list ~unwind l = List.map (from_stack ~unwind) l + let from_env v = v + let from_ens v = v + let stack_to_env ~reduce ~unwind (k,e,ens,t) = + match t with + Cic.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[]) + let compute_to_env ~reduce ~unwind k e ens t = + unwind k e ens t + let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t) + end +;; + +module Reduction(RS : Strategy) = + struct + type env = RS.env_term list + type ens = RS.ens_term Cic.explicit_named_substitution + type stack = RS.stack_term list + type config = int * env * ens * Cic.term * stack + + (* k is the length of the environment e *) + (* m is the current depth inside the term *) + let unwind' m k e ens t = + let module C = Cic in + let module S = CicSubstitution in + if k = 0 && ens = [] then + t + else + let rec unwind_aux m = + function + C.Rel n as t -> + if n <= m then t else + let d = + try + Some (RS.from_env (List.nth e (n-m-1))) + with _ -> None + in + (match d with + Some t' -> + if m = 0 then t' else S.lift m t' + | None -> C.Rel (n-k) + ) + | C.Var (uri,exp_named_subst) -> +(* +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 (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 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 + ;; + + let unwind = unwind' 0;; + +(* + 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 -> Cic.term = + let module C = Cic in + let module S = CicSubstitution in + let rec reduce = + function + (k, e, _, C.Rel n, s) -> + let d = + try + Some (RS.from_env (List.nth e (n-1))) + with + _ -> + try + begin + match List.nth context (n - 1 - k) with + None -> assert false + | Some (_,C.Decl _) -> None + | Some (_,C.Def (x,_)) -> Some (S.lift (n - k) x) + end + with + _ -> None + in + (match d with + Some t' -> reduce (0,[],[],t',s) + | None -> + if s = [] then + C.Rel (n-k) + else C.Appl (C.Rel (n-k)::(RS.from_stack_list ~unwind s)) + ) + | (k, e, ens, (C.Var (uri,exp_named_subst) as t), s) -> + if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then + reduce (0, [], [], RS.from_ens (List.assq uri ens), s) + else + ( 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,_,_,_) -> + let t' = unwind k e ens t in + if s = [] then t' else + C.Appl (t'::(RS.from_stack_list ~unwind s)) + | C.Variable (_,Some body,_,_,_) -> + let ens' = push_exp_named_subst k e ens exp_named_subst in + reduce (0, [], ens', body, s) + ) + | (k, e, ens, (C.Meta (n,l) as t), s) -> + (try + let (_, term,_) = CicUtil.lookup_subst n subst in + reduce (k, e, ens,CicSubstitution.subst_meta l term,s) + with CicUtil.Subst_not_found _ -> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))) + | (k, e, _, (C.Sort _ as t), s) -> t (* s should be empty *) + | (k, e, _, (C.Implicit _ as t), s) -> t (* s should be empty *) + | (k, e, ens, C.Cast (te,ty), s) -> + reduce (k, e, ens, te, s) (* s should be empty *) + | (k, e, ens, (C.Prod _ as t), s) -> + unwind k e ens t (* s should be empty *) + | (k, e, ens, (C.Lambda (_,_,t) as t'), []) -> unwind k e ens t' + | (k, e, ens, C.Lambda (_,_,t), p::s) -> + reduce (k+1, (RS.stack_to_env ~reduce ~unwind p)::e, ens, t,s) + | (k, e, ens, C.LetIn (_,m,t), 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) + (* CSC: Old Dead Code + | (k, e, ens, C.Appl ((C.Lambda _ as he)::tl), s) + | (k, e, ens, C.Appl ((C.Const _ as he)::tl), s) + | (k, e, ens, C.Appl ((C.MutCase _ as he)::tl), s) + | (k, e, ens, C.Appl ((C.Fix _ as he)::tl), s) -> + (* strict evaluation, but constants are NOT unfolded *) + let red = + function + C.Const _ as t -> unwind k e ens t + | t -> reduce (k,e,ens,t,[]) + in + let tl' = List.map red tl in + reduce (k, e, ens, he , List.append tl' s) + | (k, e, ens, C.Appl l, s) -> + C.Appl (List.append (List.map (unwind k e ens) l) s) + *) + | (k, e, ens, (C.Const (uri,exp_named_subst) as t), s) when delta=false-> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s)) + | (k, e, ens, (C.Const (uri,exp_named_subst) as t), s) -> + (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,_,_,_) -> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s)) + | C.Variable _ -> raise ReferenceToVariable + | C.CurrentProof (_,_,body,_,_,_) -> + let ens' = push_exp_named_subst k e ens exp_named_subst in + (* constants are closed *) + reduce (0, [], ens', body, s) + | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition + ) + | (k, e, ens, (C.MutInd _ as t),s) -> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s)) + | (k, e, ens, (C.MutConstruct _ as t),s) -> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s)) + | (k, e, ens, (C.MutCase (mutind,i,_,term,pl) as t),s) -> + let decofix = + function + C.CoFix (i,fl) -> + let (_,_,body) = List.nth fl i in + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) + fl + body + in + (* the term is the result of a reduction; *) + (* so it is already unwinded. *) + reduce (0,[],[],body',[]) + | C.Appl (C.CoFix (i,fl) :: tl) -> + let (_,_,body) = List.nth fl i in + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) + fl + body + in + (* the term is the result of a reduction; *) + (* so it is already unwinded. *) + reduce (0,[],[],body',RS.to_stack_list tl) + | t -> t + in + (match decofix (reduce (k,e,ens,term,[])) with + C.MutConstruct (_,_,j,_) -> + reduce (k, e, ens, (List.nth pl (j-1)), s) + | C.Appl (C.MutConstruct (_,_,j,_) :: tl) -> + let (arity, r) = + let o,_ = + CicEnvironment.get_cooked_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 num_to_eat = r in + let rec eat_first = + function + (0,l) -> l + | (n,he::tl) when n > 0 -> eat_first (n - 1, tl) + | _ -> raise (Impossible 5) + in + eat_first (num_to_eat,tl) + in + (* ts are already unwinded because they are a sublist of tl *) + reduce (k, e, ens, (List.nth pl (j-1)), (RS.to_stack_list ts)@s) + | C.Cast _ | C.Implicit _ -> + raise (Impossible 2) (* we don't trust our whd ;-) *) + | _ -> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s)) + ) + | (k, e, ens, (C.Fix (i,fl) as t), s) -> + let (_,recindex,_,body) = List.nth fl i in + let recparam = + try + Some (RS.from_stack ~unwind (List.nth s recindex)) + with + _ -> None + in + (match recparam with + Some recparam -> + (match reduce (0,[],[],recparam,[]) with + (* match recparam with *) + C.MutConstruct _ + | C.Appl ((C.MutConstruct _)::_) -> + (* OLD + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl))) + fl + body + in + reduce (k, e, ens, body', s) *) + (* NEW *) + let leng = List.length fl in + let fl' = + let unwind_fl (name,recindex,typ,body) = + (name,recindex,unwind k e ens typ, + unwind' leng k e ens body) + in + List.map unwind_fl fl + in + let new_env = + let counter = ref 0 in + let rec build_env e = + if !counter = leng then e + else + (incr counter ; + build_env ((RS.to_env (C.Fix (!counter -1, fl')))::e)) + in + build_env e + in + reduce (k+leng, new_env, ens, body, s) + | _ -> + let t' = unwind k e ens t in + if s = [] then t' else + C.Appl (t'::(RS.from_stack_list ~unwind s)) + ) + | None -> + let t' = unwind k e ens t in + if s = [] then t' else + C.Appl (t'::(RS.from_stack_list ~unwind s)) + ) + | (k, e, ens, (C.CoFix (i,fl) as t),s) -> + let t' = unwind k e ens t in + if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s)) + and push_exp_named_subst k e ens = + function + [] -> ens + | (uri,t)::tl -> + push_exp_named_subst k e ((uri,RS.to_ens (unwind k e ens t))::ens) tl + in + reduce + ;; + (* + let rec whd context t = + try + reduce context (0, [], [], t, []) + with Not_found -> + debug_print (lazy (CicPp.ppterm t)) ; + raise Not_found + ;; + *) + + let rec whd ?(delta=true) ?(subst=[]) context t = + 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(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 + begin + debug t1 [t2] "PREWHD"; + (* + (match t1 with + Cic.Meta _ -> + debug_print (lazy (CicPp.ppterm t1)); + debug_print (lazy (CicPp.ppterm (whd ~subst context t1))); + debug_print (lazy (CicPp.ppterm t2)); + debug_print (lazy (CicPp.ppterm (whd ~subst context t2))) + | _ -> ()); *) + 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 + end + 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 new file mode 100644 index 000000000..e3619053d --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicSubstitution.ml b/helm/ocaml/cic_proof_checking/cicSubstitution.ml new file mode 100644 index 000000000..372c66fb8 --- /dev/null +++ b/helm/ocaml/cic_proof_checking/cicSubstitution.ml @@ -0,0 +1,427 @@ +(* 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 = +(* +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 + substaux 1 +;; + +(* 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 new file mode 100644 index 000000000..21a1f5d0e --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicTypeChecker.ml b/helm/ocaml/cic_proof_checking/cicTypeChecker.ml new file mode 100644 index 000000000..cd742d4cd --- /dev/null +++ b/helm/ocaml/cic_proof_checking/cicTypeChecker.ml @@ -0,0 +1,2167 @@ +(* 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")) + 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 new file mode 100644 index 000000000..e9419171e --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicUnivUtils.ml b/helm/ocaml/cic_proof_checking/cicUnivUtils.ml new file mode 100644 index 000000000..cd1aeba32 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/cicUnivUtils.mli b/helm/ocaml/cic_proof_checking/cicUnivUtils.mli new file mode 100644 index 000000000..eb55a47eb --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/doc/inductive.txt b/helm/ocaml/cic_proof_checking/doc/inductive.txt new file mode 100644 index 000000000..f2e49d398 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/freshNamesGenerator.ml b/helm/ocaml/cic_proof_checking/freshNamesGenerator.ml new file mode 100755 index 000000000..99c9e4d76 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/freshNamesGenerator.mli b/helm/ocaml/cic_proof_checking/freshNamesGenerator.mli new file mode 100644 index 000000000..b90c0f2f5 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/utilities/Makefile b/helm/ocaml/cic_proof_checking/utilities/Makefile new file mode 100644 index 000000000..2cd98f894 --- /dev/null +++ b/helm/ocaml/cic_proof_checking/utilities/Makefile @@ -0,0 +1,15 @@ +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) +opt: $(UTILITIES_OPT) +%: %.ml + $(OCAMLC) -o $@ $< +%.opt: %.ml + $(OCAMLOPT) -o $@ $< +clean: + rm -f $(UTILITIES) $(UTILITIES_OPT) *.cm[iox] *.o + diff --git a/helm/ocaml/cic_proof_checking/utilities/create_environment.ml b/helm/ocaml/cic_proof_checking/utilities/create_environment.ml new file mode 100644 index 000000000..8a8524d24 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/utilities/list_uris.ml b/helm/ocaml/cic_proof_checking/utilities/list_uris.ml new file mode 100644 index 000000000..90ea51616 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_proof_checking/utilities/parse_library.ml b/helm/ocaml/cic_proof_checking/utilities/parse_library.ml new file mode 100644 index 000000000..1d65291cb --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_unification/.depend b/helm/ocaml/cic_unification/.depend new file mode 100644 index 000000000..a442c1d4d --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_unification/Makefile b/helm/ocaml/cic_unification/Makefile new file mode 100644 index 000000000..3db00fe5c --- /dev/null +++ b/helm/ocaml/cic_unification/Makefile @@ -0,0 +1,12 @@ +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.common diff --git a/helm/ocaml/cic_unification/cicMetaSubst.ml b/helm/ocaml/cic_unification/cicMetaSubst.ml new file mode 100644 index 000000000..afd74d756 --- /dev/null +++ b/helm/ocaml/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 + 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 new file mode 100644 index 000000000..96f87205f --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_unification/cicMkImplicit.ml b/helm/ocaml/cic_unification/cicMkImplicit.ml new file mode 100644 index 000000000..36679223c --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_unification/cicMkImplicit.mli b/helm/ocaml/cic_unification/cicMkImplicit.mli new file mode 100644 index 000000000..476270144 --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_unification/cicRefine.ml b/helm/ocaml/cic_unification/cicRefine.ml new file mode 100644 index 000000000..f03752d10 --- /dev/null +++ b/helm/ocaml/cic_unification/cicRefine.ml @@ -0,0 +1,1379 @@ +(* 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]) ]) as t 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'@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 + newt, subst, metasenv, ugraph) + | 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 new file mode 100644 index 000000000..224a7586c --- /dev/null +++ b/helm/ocaml/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/ocaml/cic_unification/cicUnification.ml b/helm/ocaml/cic_unification/cicUnification.ml new file mode 100644 index 000000000..b1ef27f4e --- /dev/null +++ b/helm/ocaml/cic_unification/cicUnification.ml @@ -0,0 +1,750 @@ +(* 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 + fo_unif_l + test_equality_only subst metasenv (lr1, lr2) ugraph) + | (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 new file mode 100644 index 000000000..e1a6c2899 --- /dev/null +++ b/helm/ocaml/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/ocaml/clusters.dot b/helm/ocaml/clusters.dot new file mode 100644 index 000000000..3d22c6479 --- /dev/null +++ b/helm/ocaml/clusters.dot @@ -0,0 +1,58 @@ +// 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; + paramodulation; + 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/configure.ac b/helm/ocaml/configure.ac new file mode 100644 index 000000000..357d1018f --- /dev/null +++ b/helm/ocaml/configure.ac @@ -0,0 +1,60 @@ +AC_INIT(Makefile.in) + +AC_CHECK_PROG(HAVE_OCAMLC, ocamlc, yes, no) +if test $HAVE_OCAMLC = "no"; then + AC_MSG_ERROR(could not find ocamlc in PATH, please make sure ocaml is installed) +fi + +AC_CHECK_PROG(HAVE_OCAMLFIND, ocamlfind, yes, no) +if test $HAVE_OCAMLFIND = "no"; then + AC_MSG_ERROR(could not find ocamlfind in PATH, please make sure findlib is installed) +else + OCAMLFIND=ocamlfind +fi + +OCAMLFIND_COMMANDS="" +AC_CHECK_PROG(HAVE_OCAMLC_OPT, ocamlc.opt, yes, no) +if test $HAVE_OCAMLC_OPT = "yes"; then + if test "$OCAMLFIND_COMMANDS" = ""; then + OCAMLFIND_COMMANDS="ocamlc=ocamlc.opt" + else + OCAMLFIND_COMMANDS="$OCAMLFIND_COMMANDS ocamlc=ocamlc.opt" + fi +fi +AC_CHECK_PROG(HAVE_OCAMLOPT_OPT, ocamlopt.opt, yes, no) +if test $HAVE_OCAMLOPT_OPT = "yes"; then + if test "$OCAMLFIND_COMMANDS" = ""; then + OCAMLFIND_COMMANDS="ocamlopt=ocamlopt.opt" + else + OCAMLFIND_COMMANDS="$OCAMLFIND_COMMANDS ocamlopt=ocamlopt.opt" + fi +fi +AC_CHECK_PROG(HAVE_OCAMLDEP_OPT, ocamldep.opt, yes, no) +if test $HAVE_OCAMLDEP_OPT = "yes"; then + if test "$OCAMLFIND_COMMANDS" = ""; then + OCAMLFIND_COMMANDS="ocamldep=ocamldep.opt" + else + OCAMLFIND_COMMANDS="$OCAMLFIND_COMMANDS ocamldep=ocamldep.opt" + fi +fi +if test "$OCAMLFIND_COMMANDS" != ""; then + OCAMLFIND="OCAMLFIND_COMMANDS='$OCAMLFIND_COMMANDS' $OCAMLFIND" +fi + +AC_MSG_CHECKING("where to install the library") +OCAMLFIND_DEST_DIR="/public/sacerdot/prova" +AC_MSG_RESULT($OCAMLFIND_DEST_DIR) + +AC_MSG_CHECKING("where to install the META files") +OCAMLFIND_META_DIR=`pwd`/METAS +AC_MSG_RESULT($OCAMLFIND_META_DIR) + +AC_SUBST(OCAMLFIND) +AC_SUBST(OCAMLFIND_DEST_DIR) +AC_SUBST(OCAMLFIND_META_DIR) + +AC_OUTPUT([ + Makefile + Makefile.common +]) + diff --git a/helm/ocaml/content_pres/.depend b/helm/ocaml/content_pres/.depend new file mode 100644 index 000000000..60e25ecd8 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/Makefile b/helm/ocaml/content_pres/Makefile new file mode 100644 index 000000000..642e3ce0e --- /dev/null +++ b/helm/ocaml/content_pres/Makefile @@ -0,0 +1,58 @@ +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 + $(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.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 new file mode 100644 index 000000000..8b992e041 --- /dev/null +++ b/helm/ocaml/content_pres/box.ml @@ -0,0 +1,152 @@ +(* 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 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 new file mode 100644 index 000000000..56c086964 --- /dev/null +++ b/helm/ocaml/content_pres/box.mli @@ -0,0 +1,78 @@ +(* 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 pp_attr: attr -> string + diff --git a/helm/ocaml/content_pres/boxPp.ml b/helm/ocaml/content_pres/boxPp.ml new file mode 100644 index 000000000..7a2fa9912 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/boxPp.mli b/helm/ocaml/content_pres/boxPp.mli new file mode 100644 index 000000000..6b7c3cec8 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/cicNotationLexer.ml b/helm/ocaml/content_pres/cicNotationLexer.ml new file mode 100644 index 000000000..8848a3ce5 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/cicNotationLexer.mli b/helm/ocaml/content_pres/cicNotationLexer.mli new file mode 100644 index 000000000..cd5f0876d --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/cicNotationParser.ml b/helm/ocaml/content_pres/cicNotationParser.ml new file mode 100644 index 000000000..5750ad816 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/cicNotationParser.mli b/helm/ocaml/content_pres/cicNotationParser.mli new file mode 100644 index 000000000..e25968bbb --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/cicNotationPres.ml b/helm/ocaml/content_pres/cicNotationPres.ml new file mode 100644 index 000000000..6412c3f0c --- /dev/null +++ b/helm/ocaml/content_pres/cicNotationPres.ml @@ -0,0 +1,429 @@ +(* 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 +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 = + 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 = `Right) + || (child_prec = curr_prec && + child_assoc = Gramext.RightA && + child_pos = `Left)) + then (* parens should be added *) +(* (prerr_endline "adding parens"; + prerr_endline (Printf.sprintf "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d" + child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos + child_pos) curr_prec); *) + 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]) + 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 new file mode 100644 index 000000000..04411df2b --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/content2pres.ml b/helm/ocaml/content_pres/content2pres.ml new file mode 100644 index 000000000..948eb7b9a --- /dev/null +++ b/helm/ocaml/content_pres/content2pres.ml @@ -0,0 +1,817 @@ +(* 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 -> + B.Action + ([None,"type","toggle"], + [(make_concl ~attrs:[Some "helm", "xref", p.Con.proof_id] + "proof of" ac); 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_h [Some "helm", "xref", id] + (((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_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 new file mode 100644 index 000000000..793c31a4f --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/content2presMatcher.ml b/helm/ocaml/content_pres/content2presMatcher.ml new file mode 100644 index 000000000..7e080ea69 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/content2presMatcher.mli b/helm/ocaml/content_pres/content2presMatcher.mli new file mode 100644 index 000000000..86b97b6d8 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/mpresentation.ml b/helm/ocaml/content_pres/mpresentation.ml new file mode 100644 index 000000000..1aa5db129 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/mpresentation.mli b/helm/ocaml/content_pres/mpresentation.mli new file mode 100644 index 000000000..8252517a6 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/renderingAttrs.ml b/helm/ocaml/content_pres/renderingAttrs.ml new file mode 100644 index 000000000..cc692abe9 --- /dev/null +++ b/helm/ocaml/content_pres/renderingAttrs.ml @@ -0,0 +1,50 @@ +(* 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 keyword_attributes = function + | `MathML -> [ None, "mathcolor", "blue" ] + | `BoxML -> [ None, "color", "blue" ] + +let builtin_symbol_attributes = function + | `MathML -> [ None, "mathcolor", "blue" ] + | `BoxML -> [ None, "color", "blue" ] + +let object_keyword_attributes = function + | `MathML -> [ None, "mathcolor", "red" ] + | `BoxML -> [ None, "color", "red" ] + +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 new file mode 100644 index 000000000..64323598b --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/sequent2pres.ml b/helm/ocaml/content_pres/sequent2pres.ml new file mode 100644 index 000000000..88c804b7d --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/sequent2pres.mli b/helm/ocaml/content_pres/sequent2pres.mli new file mode 100644 index 000000000..615c8e35f --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/termContentPres.ml b/helm/ocaml/content_pres/termContentPres.ml new file mode 100644 index 000000000..4c8bbc7d4 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/termContentPres.mli b/helm/ocaml/content_pres/termContentPres.mli new file mode 100644 index 000000000..5ff710036 --- /dev/null +++ b/helm/ocaml/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/ocaml/content_pres/test_lexer.ml b/helm/ocaml/content_pres/test_lexer.ml new file mode 100644 index 000000000..b032d7f61 --- /dev/null +++ b/helm/ocaml/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/ocaml/daemons.dot b/helm/ocaml/daemons.dot new file mode 100644 index 000000000..93c122d8a --- /dev/null +++ b/helm/ocaml/daemons.dot @@ -0,0 +1,19 @@ + /* apps */ + subgraph applications { + node [shape=plaintext,style=filled,fillcolor=slategray2]; + DependencyAnalyzer [label="Dependency\nAnalyzer"]; + Getter; + Matita; + ProofChecker [label="Proof\nChecker"]; + Uwobo; + Whelp; + } + /* 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/deps.patch b/helm/ocaml/deps.patch new file mode 100644 index 000000000..d7f9cf8c9 --- /dev/null +++ b/helm/ocaml/deps.patch @@ -0,0 +1,11 @@ +--- .dep.dot 2005-12-19 12:07:15.000000000 +0100 ++++ .dep.dot.new 2005-12-19 12:08:10.000000000 +0100 +@@ -14,7 +14,7 @@ + "cic_unification" -> "library"; + "library" -> "metadata"; + "library" -> "cic_acic"; +-"metadata" -> "cic_proof_checking"; ++"metadata" -> "cic"; + "metadata" -> "hmysql"; + "grafite" -> "content_pres"; + "content_pres" -> "utf8_macros"; diff --git a/helm/ocaml/extlib/.depend b/helm/ocaml/extlib/.depend new file mode 100644 index 000000000..b11273f7a --- /dev/null +++ b/helm/ocaml/extlib/.depend @@ -0,0 +1,10 @@ +hExtlib.cmo: hExtlib.cmi +hExtlib.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 new file mode 100644 index 000000000..c67778af4 --- /dev/null +++ b/helm/ocaml/extlib/Makefile @@ -0,0 +1,16 @@ +PACKAGE = extlib +PREDICATES = + +INTERFACE_FILES = \ + 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.common diff --git a/helm/ocaml/extlib/hExtlib.ml b/helm/ocaml/extlib/hExtlib.ml new file mode 100644 index 000000000..15a459cdc --- /dev/null +++ b/helm/ocaml/extlib/hExtlib.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$ *) + +(** PROFILING *) + +(* we should use a key in te registry, but we can't see the registry.. *) +let profiling_enabled = true + +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 = 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 + aux "" 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 new file mode 100644 index 000000000..aed9b2406 --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/hLog.ml b/helm/ocaml/extlib/hLog.ml new file mode 100644 index 000000000..4ad2b5ba4 --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/hLog.mli b/helm/ocaml/extlib/hLog.mli new file mode 100644 index 000000000..6847ce32d --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/hMarshal.ml b/helm/ocaml/extlib/hMarshal.ml new file mode 100644 index 000000000..c57886819 --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/hMarshal.mli b/helm/ocaml/extlib/hMarshal.mli new file mode 100644 index 000000000..90ce20def --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/patternMatcher.ml b/helm/ocaml/extlib/patternMatcher.ml new file mode 100644 index 000000000..c1b436a97 --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/patternMatcher.mli b/helm/ocaml/extlib/patternMatcher.mli new file mode 100644 index 000000000..2201ddf7f --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/trie.ml b/helm/ocaml/extlib/trie.ml new file mode 100644 index 000000000..f60b2d45c --- /dev/null +++ b/helm/ocaml/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/ocaml/extlib/trie.mli b/helm/ocaml/extlib/trie.mli new file mode 100644 index 000000000..b95157fd0 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/.depend b/helm/ocaml/getter/.depend new file mode 100644 index 000000000..9f77a2458 --- /dev/null +++ b/helm/ocaml/getter/.depend @@ -0,0 +1,30 @@ +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 new file mode 100644 index 000000000..6512190cd --- /dev/null +++ b/helm/ocaml/getter/.ocamlinit @@ -0,0 +1,3 @@ +#use "topfind";; +#require "helm-getter";; +Helm_registry.load_from "sample.conf.xml";; diff --git a/helm/ocaml/getter/Makefile b/helm/ocaml/getter/Makefile new file mode 100644 index 000000000..9ebca237a --- /dev/null +++ b/helm/ocaml/getter/Makefile @@ -0,0 +1,20 @@ + +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.common + diff --git a/helm/ocaml/getter/http_getter.ml b/helm/ocaml/getter/http_getter.ml new file mode 100644 index 000000000..61930a4aa --- /dev/null +++ b/helm/ocaml/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 = Lazy.force Http_getter_env.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 new file mode 100644 index 000000000..4bbc447bd --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_common.ml b/helm/ocaml/getter/http_getter_common.ml new file mode 100644 index 000000000..a29a44de2 --- /dev/null +++ b/helm/ocaml/getter/http_getter_common.ml @@ -0,0 +1,168 @@ +(* + * 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 + (Lazy.force Http_getter_env.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 new file mode 100644 index 000000000..d1bc66f76 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_const.ml b/helm/ocaml/getter/http_getter_const.ml new file mode 100644 index 000000000..8103efcfa --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_const.mli b/helm/ocaml/getter/http_getter_const.mli new file mode 100644 index 000000000..d532313f0 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_env.ml b/helm/ocaml/getter/http_getter_env.ml new file mode 100644 index 000000000..7a3891b98 --- /dev/null +++ b/helm/ocaml/getter/http_getter_env.ml @@ -0,0 +1,114 @@ +(* + * 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 (normalize_dir (Helm_registry.get "getter.dtd_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)) + (Lazy.force dtd_dir) (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 ()) + diff --git a/helm/ocaml/getter/http_getter_env.mli b/helm/ocaml/getter/http_getter_env.mli new file mode 100644 index 000000000..6a0f0f50a --- /dev/null +++ b/helm/ocaml/getter/http_getter_env.mli @@ -0,0 +1,52 @@ +(* 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 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 *) + diff --git a/helm/ocaml/getter/http_getter_logger.ml b/helm/ocaml/getter/http_getter_logger.ml new file mode 100644 index 000000000..1d774c102 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_logger.mli b/helm/ocaml/getter/http_getter_logger.mli new file mode 100644 index 000000000..d39fe739d --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_misc.ml b/helm/ocaml/getter/http_getter_misc.ml new file mode 100644 index 000000000..45403effa --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_misc.mli b/helm/ocaml/getter/http_getter_misc.mli new file mode 100644 index 000000000..e9b013ebd --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_storage.ml b/helm/ocaml/getter/http_getter_storage.ml new file mode 100644 index 000000000..fc6f415ac --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_storage.mli b/helm/ocaml/getter/http_getter_storage.mli new file mode 100644 index 000000000..24fc329c9 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_types.ml b/helm/ocaml/getter/http_getter_types.ml new file mode 100644 index 000000000..fb0c30e83 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_wget.ml b/helm/ocaml/getter/http_getter_wget.ml new file mode 100644 index 000000000..2052e7bd5 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/http_getter_wget.mli b/helm/ocaml/getter/http_getter_wget.mli new file mode 100644 index 000000000..5d28df185 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/mkindexes.pl b/helm/ocaml/getter/mkindexes.pl new file mode 100755 index 000000000..3107846aa --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/sample.conf.xml b/helm/ocaml/getter/sample.conf.xml new file mode 100644 index 000000000..54cdc2557 --- /dev/null +++ b/helm/ocaml/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/ocaml/getter/test.ml b/helm/ocaml/getter/test.ml new file mode 100644 index 000000000..6fa236fd0 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite/.depend b/helm/ocaml/grafite/.depend new file mode 100644 index 000000000..dc225e221 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite/Makefile b/helm/ocaml/grafite/Makefile new file mode 100644 index 000000000..182cd4561 --- /dev/null +++ b/helm/ocaml/grafite/Makefile @@ -0,0 +1,13 @@ +PACKAGE = grafite +PREDICATES = + +INTERFACE_FILES = \ + grafiteAstPp.mli \ + grafiteMarshal.mli \ + $(NULL) +IMPLEMENTATION_FILES = \ + grafiteAst.ml \ + $(INTERFACE_FILES:%.mli=%.ml) + + +include ../Makefile.common diff --git a/helm/ocaml/grafite/grafiteAst.ml b/helm/ocaml/grafite/grafiteAst.ml new file mode 100644 index 000000000..c9567155d --- /dev/null +++ b/helm/ocaml/grafite/grafiteAst.ml @@ -0,0 +1,167 @@ +(* 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 = + [ `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 new file mode 100644 index 000000000..6abfa4dd6 --- /dev/null +++ b/helm/ocaml/grafite/grafiteAstPp.ml @@ -0,0 +1,253 @@ +(* 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 + | `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 new file mode 100644 index 000000000..f9b3b37cc --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite/grafiteMarshal.ml b/helm/ocaml/grafite/grafiteMarshal.ml new file mode 100644 index 000000000..e786d5001 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite/grafiteMarshal.mli b/helm/ocaml/grafite/grafiteMarshal.mli new file mode 100644 index 000000000..e60ad39d8 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/.depend b/helm/ocaml/grafite_engine/.depend new file mode 100644 index 000000000..d0e9a3a86 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/Makefile b/helm/ocaml/grafite_engine/Makefile new file mode 100644 index 000000000..e72acd29c --- /dev/null +++ b/helm/ocaml/grafite_engine/Makefile @@ -0,0 +1,12 @@ +PACKAGE = grafite_engine +PREDICATES = + +INTERFACE_FILES = \ + grafiteTypes.mli \ + grafiteSync.mli \ + grafiteMisc.mli \ + grafiteEngine.mli \ + $(NULL) +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../Makefile.common diff --git a/helm/ocaml/grafite_engine/grafiteEngine.ml b/helm/ocaml/grafite_engine/grafiteEngine.ml new file mode 100644 index 000000000..c0a453c93 --- /dev/null +++ b/helm/ocaml/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 + | `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 + | `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 = + 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 + List.iter + (fun u -> prerr_endline (UriManager.string_of_uri u)) + coercions; + let status = GrafiteTypes.add_moo_content moo_content status in + let basedir = Helm_registry.get "matita.basedir" in + List.fold_left + (fun (status,lemmas) uri -> + let status,new_lemmas = + GrafiteSync.add_coercion ~basedir ~add_composites:true status uri + in + status,new_lemmas@lemmas + ) (status,[]) coercions + +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 new file mode 100644 index 000000000..ee5f3a157 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/grafiteMisc.ml b/helm/ocaml/grafite_engine/grafiteMisc.ml new file mode 100644 index 000000000..5b86293db --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/grafiteMisc.mli b/helm/ocaml/grafite_engine/grafiteMisc.mli new file mode 100644 index 000000000..833bb6360 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/grafiteSync.ml b/helm/ocaml/grafite_engine/grafiteSync.ml new file mode 100644 index 000000000..37a3132e7 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/grafiteSync.mli b/helm/ocaml/grafite_engine/grafiteSync.mli new file mode 100644 index 000000000..ce3c04250 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/grafiteTypes.ml b/helm/ocaml/grafite_engine/grafiteTypes.ml new file mode 100644 index 000000000..0c02e1b6c --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_engine/grafiteTypes.mli b/helm/ocaml/grafite_engine/grafiteTypes.mli new file mode 100644 index 000000000..a8b86c276 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/.depend b/helm/ocaml/grafite_parser/.depend new file mode 100644 index 000000000..360429635 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/Makefile b/helm/ocaml/grafite_parser/Makefile new file mode 100644 index 000000000..4b04b597e --- /dev/null +++ b/helm/ocaml/grafite_parser/Makefile @@ -0,0 +1,42 @@ +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 + $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< +print_grammar: print_grammar.ml $(PACKAGE).cma + $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< +test_dep: test_dep.ml $(PACKAGE).cma + $(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $< + +include ../Makefile.common diff --git a/helm/ocaml/grafite_parser/cicNotation2.ml b/helm/ocaml/grafite_parser/cicNotation2.ml new file mode 100644 index 000000000..015d426e7 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/cicNotation2.mli b/helm/ocaml/grafite_parser/cicNotation2.mli new file mode 100644 index 000000000..00f184b3b --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/dependenciesParser.ml b/helm/ocaml/grafite_parser/dependenciesParser.ml new file mode 100644 index 000000000..fc49de600 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/dependenciesParser.mli b/helm/ocaml/grafite_parser/dependenciesParser.mli new file mode 100644 index 000000000..882d45fb8 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/grafiteDisambiguate.ml b/helm/ocaml/grafite_parser/grafiteDisambiguate.ml new file mode 100644 index 000000000..3d6f893ee --- /dev/null +++ b/helm/ocaml/grafite_parser/grafiteDisambiguate.ml @@ -0,0 +1,288 @@ +(* 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) + | `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 new file mode 100644 index 000000000..b04aa3cde --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/grafiteDisambiguator.ml b/helm/ocaml/grafite_parser/grafiteDisambiguator.ml new file mode 100644 index 000000000..d05351cd2 --- /dev/null +++ b/helm/ocaml/grafite_parser/grafiteDisambiguator.ml @@ -0,0 +1,178 @@ +(* 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_bool "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 new file mode 100644 index 000000000..b7c85f6af --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/grafiteParser.ml b/helm/ocaml/grafite_parser/grafiteParser.ml new file mode 100644 index 000000000..90d1898ea --- /dev/null +++ b/helm/ocaml/grafite_parser/grafiteParser.ml @@ -0,0 +1,565 @@ +(* 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 "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 new file mode 100644 index 000000000..6a1980011 --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/print_grammar.ml b/helm/ocaml/grafite_parser/print_grammar.ml new file mode 100644 index 000000000..6a05865de --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/test_dep.ml b/helm/ocaml/grafite_parser/test_dep.ml new file mode 100644 index 000000000..2d0f7813f --- /dev/null +++ b/helm/ocaml/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/ocaml/grafite_parser/test_parser.ml b/helm/ocaml/grafite_parser/test_parser.ml new file mode 100644 index 000000000..2deef1bd5 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/.depend b/helm/ocaml/hbugs/.depend new file mode 100644 index 000000000..d6a85b905 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/Makefile b/helm/ocaml/hbugs/Makefile new file mode 100644 index 000000000..c38ac3e92 --- /dev/null +++ b/helm/ocaml/hbugs/Makefile @@ -0,0 +1,97 @@ + +# 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.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 new file mode 100644 index 000000000..691f9d11a --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/client.ml b/helm/ocaml/hbugs/client.ml new file mode 100644 index 000000000..93114b305 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/data/hbugs_tutor.TPL.ml b/helm/ocaml/hbugs/data/hbugs_tutor.TPL.ml new file mode 100644 index 000000000..947e351c7 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/data/tutors_index.xml b/helm/ocaml/hbugs/data/tutors_index.xml new file mode 100644 index 000000000..bd4baad45 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/doc/hbugs.dia b/helm/ocaml/hbugs/doc/hbugs.dia new file mode 100644 index 000000000..b1c4e64e2 Binary files /dev/null and b/helm/ocaml/hbugs/doc/hbugs.dia differ diff --git a/helm/ocaml/hbugs/hbugs_broker_registry.ml b/helm/ocaml/hbugs/hbugs_broker_registry.ml new file mode 100644 index 000000000..4670b5eca --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_broker_registry.mli b/helm/ocaml/hbugs/hbugs_broker_registry.mli new file mode 100644 index 000000000..ece9e07cf --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_client.ml b/helm/ocaml/hbugs/hbugs_client.ml new file mode 100644 index 000000000..c7b5fae75 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_client.mli b/helm/ocaml/hbugs/hbugs_client.mli new file mode 100644 index 000000000..0c2e93d80 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_client_gui.glade b/helm/ocaml/hbugs/hbugs_client_gui.glade new file mode 100644 index 000000000..f88a8c388 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_common.ml b/helm/ocaml/hbugs/hbugs_common.ml new file mode 100644 index 000000000..fe2ecfcae --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_common.mli b/helm/ocaml/hbugs/hbugs_common.mli new file mode 100644 index 000000000..2d51075f3 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_id_generator.ml b/helm/ocaml/hbugs/hbugs_id_generator.ml new file mode 100644 index 000000000..5b1998ac2 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_id_generator.mli b/helm/ocaml/hbugs/hbugs_id_generator.mli new file mode 100644 index 000000000..dad0c9391 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_messages.ml b/helm/ocaml/hbugs/hbugs_messages.ml new file mode 100644 index 000000000..4767b2aee --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_messages.mli b/helm/ocaml/hbugs/hbugs_messages.mli new file mode 100644 index 000000000..642c0b0e2 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_misc.ml b/helm/ocaml/hbugs/hbugs_misc.ml new file mode 100644 index 000000000..32b8e8b46 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_misc.mli b/helm/ocaml/hbugs/hbugs_misc.mli new file mode 100644 index 000000000..b0ef59719 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_tutors.ml b/helm/ocaml/hbugs/hbugs_tutors.ml new file mode 100644 index 000000000..6a73e2cc2 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_tutors.mli b/helm/ocaml/hbugs/hbugs_tutors.mli new file mode 100644 index 000000000..43cd99cce --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/hbugs_types.mli b/helm/ocaml/hbugs/hbugs_types.mli new file mode 100644 index 000000000..e3067f2e9 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/scripts/brokerctl.sh b/helm/ocaml/hbugs/scripts/brokerctl.sh new file mode 100755 index 000000000..3da998d6c --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/scripts/build_tutors.ml b/helm/ocaml/hbugs/scripts/build_tutors.ml new file mode 100755 index 000000000..9b742d84d --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/scripts/ls_tutors.ml b/helm/ocaml/hbugs/scripts/ls_tutors.ml new file mode 100755 index 000000000..5fe796ca1 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/scripts/sabba.sh b/helm/ocaml/hbugs/scripts/sabba.sh new file mode 100755 index 000000000..2031e295f --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/search_pattern_apply_tutor.ml b/helm/ocaml/hbugs/search_pattern_apply_tutor.ml new file mode 100644 index 000000000..79c94beed --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/test/HBUGS_MESSAGES.xml b/helm/ocaml/hbugs/test/HBUGS_MESSAGES.xml new file mode 100644 index 000000000..cf15dde3d --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/test/Makefile b/helm/ocaml/hbugs/test/Makefile new file mode 100644 index 000000000..0b3debf74 --- /dev/null +++ b/helm/ocaml/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/ocaml/hbugs/test/test_serialization.ml b/helm/ocaml/hbugs/test/test_serialization.ml new file mode 100644 index 000000000..1afd74379 --- /dev/null +++ b/helm/ocaml/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/ocaml/hgdome/.depend b/helm/ocaml/hgdome/.depend new file mode 100644 index 000000000..bf9c09af7 --- /dev/null +++ b/helm/ocaml/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/ocaml/hgdome/Makefile b/helm/ocaml/hgdome/Makefile new file mode 100644 index 000000000..a7bb4dbb6 --- /dev/null +++ b/helm/ocaml/hgdome/Makefile @@ -0,0 +1,11 @@ +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.common diff --git a/helm/ocaml/hgdome/domMisc.ml b/helm/ocaml/hgdome/domMisc.ml new file mode 100644 index 000000000..97a15b7f8 --- /dev/null +++ b/helm/ocaml/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/ocaml/hgdome/domMisc.mli b/helm/ocaml/hgdome/domMisc.mli new file mode 100644 index 000000000..25d642bc5 --- /dev/null +++ b/helm/ocaml/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/ocaml/hgdome/xml2Gdome.ml b/helm/ocaml/hgdome/xml2Gdome.ml new file mode 100644 index 000000000..eb6a7641c --- /dev/null +++ b/helm/ocaml/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/ocaml/hgdome/xml2Gdome.mli b/helm/ocaml/hgdome/xml2Gdome.mli new file mode 100644 index 000000000..45d0e9532 --- /dev/null +++ b/helm/ocaml/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/ocaml/hmysql/.depend b/helm/ocaml/hmysql/.depend new file mode 100644 index 000000000..e67a0660c --- /dev/null +++ b/helm/ocaml/hmysql/.depend @@ -0,0 +1,2 @@ +hMysql.cmo: hMysql.cmi +hMysql.cmx: hMysql.cmi diff --git a/helm/ocaml/hmysql/Makefile b/helm/ocaml/hmysql/Makefile new file mode 100644 index 000000000..2ae1d4e59 --- /dev/null +++ b/helm/ocaml/hmysql/Makefile @@ -0,0 +1,11 @@ +PACKAGE = hmysql +PREDICATES = + +INTERFACE_FILES = \ + hMysql.mli +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../Makefile.common diff --git a/helm/ocaml/hmysql/hMysql.ml b/helm/ocaml/hmysql/hMysql.ml new file mode 100644 index 000000000..94f3efe03 --- /dev/null +++ b/helm/ocaml/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/ocaml/hmysql/hMysql.mli b/helm/ocaml/hmysql/hMysql.mli new file mode 100644 index 000000000..a5b90593e --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/.depend b/helm/ocaml/lexicon/.depend new file mode 100644 index 000000000..452167c72 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/Makefile b/helm/ocaml/lexicon/Makefile new file mode 100644 index 000000000..0e9c09526 --- /dev/null +++ b/helm/ocaml/lexicon/Makefile @@ -0,0 +1,17 @@ +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.common diff --git a/helm/ocaml/lexicon/cicNotation.ml b/helm/ocaml/lexicon/cicNotation.ml new file mode 100644 index 000000000..1d18691ff --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/cicNotation.mli b/helm/ocaml/lexicon/cicNotation.mli new file mode 100644 index 000000000..944438df8 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/disambiguatePp.ml b/helm/ocaml/lexicon/disambiguatePp.ml new file mode 100644 index 000000000..5f6512477 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/disambiguatePp.mli b/helm/ocaml/lexicon/disambiguatePp.mli new file mode 100644 index 000000000..e8d9b94a4 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconAst.ml b/helm/ocaml/lexicon/lexiconAst.ml new file mode 100644 index 000000000..aed4b0b15 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconAstPp.ml b/helm/ocaml/lexicon/lexiconAstPp.ml new file mode 100644 index 000000000..e49a66f60 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconAstPp.mli b/helm/ocaml/lexicon/lexiconAstPp.mli new file mode 100644 index 000000000..b7ad59f3c --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconEngine.ml b/helm/ocaml/lexicon/lexiconEngine.ml new file mode 100644 index 000000000..aec759c96 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconEngine.mli b/helm/ocaml/lexicon/lexiconEngine.mli new file mode 100644 index 000000000..a2232fe28 --- /dev/null +++ b/helm/ocaml/lexicon/lexiconEngine.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/ + *) + + +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 new file mode 100644 index 000000000..7b9422db5 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconMarshal.mli b/helm/ocaml/lexicon/lexiconMarshal.mli new file mode 100644 index 000000000..930d73f8d --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconSync.ml b/helm/ocaml/lexicon/lexiconSync.ml new file mode 100644 index 000000000..d7fa27f90 --- /dev/null +++ b/helm/ocaml/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/ocaml/lexicon/lexiconSync.mli b/helm/ocaml/lexicon/lexiconSync.mli new file mode 100644 index 000000000..62d8b97f5 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/.depend b/helm/ocaml/library/.depend new file mode 100644 index 000000000..5054959da --- /dev/null +++ b/helm/ocaml/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/ocaml/library/Makefile b/helm/ocaml/library/Makefile new file mode 100644 index 000000000..74a61aed5 --- /dev/null +++ b/helm/ocaml/library/Makefile @@ -0,0 +1,19 @@ +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.common diff --git a/helm/ocaml/library/cicCoercion.ml b/helm/ocaml/library/cicCoercion.ml new file mode 100644 index 000000000..fe636ee35 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/cicCoercion.mli b/helm/ocaml/library/cicCoercion.mli new file mode 100644 index 000000000..c9eaf0aac --- /dev/null +++ b/helm/ocaml/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/ocaml/library/cicElim.ml b/helm/ocaml/library/cicElim.ml new file mode 100644 index 000000000..fb3c0655c --- /dev/null +++ b/helm/ocaml/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/ocaml/library/cicElim.mli b/helm/ocaml/library/cicElim.mli new file mode 100644 index 000000000..f1f84c92e --- /dev/null +++ b/helm/ocaml/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/ocaml/library/cicRecord.ml b/helm/ocaml/library/cicRecord.ml new file mode 100644 index 000000000..775292ccb --- /dev/null +++ b/helm/ocaml/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/ocaml/library/cicRecord.mli b/helm/ocaml/library/cicRecord.mli new file mode 100644 index 000000000..b966f317c --- /dev/null +++ b/helm/ocaml/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/ocaml/library/coercDb.ml b/helm/ocaml/library/coercDb.ml new file mode 100644 index 000000000..01065325f --- /dev/null +++ b/helm/ocaml/library/coercDb.ml @@ -0,0 +1,90 @@ +(* 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 + | t -> Term t +;; + +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 name_of_carr = function + | Uri u -> UriManager.name_of_uri u + | Sort s -> CicPp.ppsort s + | Term t -> CicPp.ppterm t + + +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 new file mode 100644 index 000000000..9e8bf5e9c --- /dev/null +++ b/helm/ocaml/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/ocaml/library/coercGraph.ml b/helm/ocaml/library/coercGraph.ml new file mode 100644 index 000000000..cd958a8f6 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/coercGraph.mli b/helm/ocaml/library/coercGraph.mli new file mode 100644 index 000000000..1923a964a --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryClean.ml b/helm/ocaml/library/libraryClean.ml new file mode 100644 index 000000000..d09769fc2 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryClean.mli b/helm/ocaml/library/libraryClean.mli new file mode 100644 index 000000000..deca8f4a7 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryDb.ml b/helm/ocaml/library/libraryDb.ml new file mode 100644 index 000000000..f04043366 --- /dev/null +++ b/helm/ocaml/library/libraryDb.ml @@ -0,0 +1,168 @@ +(* 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 owner = (Helm_registry.get "matita.owner") 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 new file mode 100644 index 000000000..39aa7c079 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryMisc.ml b/helm/ocaml/library/libraryMisc.ml new file mode 100644 index 000000000..3f1931e42 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryMisc.mli b/helm/ocaml/library/libraryMisc.mli new file mode 100644 index 000000000..e4d07faf7 --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryNoDb.ml b/helm/ocaml/library/libraryNoDb.ml new file mode 100644 index 000000000..9ac42a5ea --- /dev/null +++ b/helm/ocaml/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/ocaml/library/libraryNoDb.mli b/helm/ocaml/library/libraryNoDb.mli new file mode 100644 index 000000000..1521f456f --- /dev/null +++ b/helm/ocaml/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/ocaml/library/librarySync.ml b/helm/ocaml/library/librarySync.ml new file mode 100644 index 000000000..fe631edd2 --- /dev/null +++ b/helm/ocaml/library/librarySync.ml @@ -0,0 +1,406 @@ +(* 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 merge_coercions obj = + let module C = Cic in + let rec aux2 = (fun (u,t) -> u,aux t) + and aux = function + | C.Rel _ | C.Sort _ as t -> t + | C.Meta _ | C.Implicit _ -> assert false + | 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) + | (Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ]) as t 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 aux l) + | C.Var (uri,exp_named_subst) -> + let exp_named_subst = List.map aux2 exp_named_subst in + C.Var (uri, exp_named_subst) + | C.Const (uri,exp_named_subst) -> + let exp_named_subst = List.map aux2 exp_named_subst in + C.Const (uri, exp_named_subst) + | C.MutInd (uri,tyno,exp_named_subst) -> + let exp_named_subst = List.map aux2 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 aux2 exp_named_subst in + C.MutConstruct (uri,tyno,consno,exp_named_subst) + | C.MutCase (uri,tyno,out,te,pl) -> + let pl = List.map aux pl in + C.MutCase (uri,tyno,aux out,aux te,pl) + | C.Fix (fno, fl) -> + let fl = List.map (fun (name,idx,ty,bo)->(name,idx,aux ty,aux bo)) fl in + C.Fix (fno, fl) + | C.CoFix (fno, fl) -> + let fl = List.map (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl in + C.CoFix (fno, fl) + in + match obj with + | C.Constant (id, body, ty, params, attrs) -> + let body = + match body with + | None -> None + | Some body -> Some (aux body) + in + let ty = aux 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 (aux body) + in + let ty = aux 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 = aux arity in + let cl = List.map (fun (name, ty) -> (name,aux 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 obj + else + obj + in + let dbd = LibraryDb.instance () in + if CicEnvironment.in_library uri then + raise (AlreadyDefined uri) + else begin + typecheck_obj uri obj; (* 1 *) + 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 *) + 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 + 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 new file mode 100644 index 000000000..43ac34da3 --- /dev/null +++ b/helm/ocaml/library/librarySync.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/ + *) + +exception AlreadyDefined of UriManager.uri + +(* 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 new file mode 100644 index 000000000..c67e1fc29 --- /dev/null +++ b/helm/ocaml/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/ocaml/logger/.depend b/helm/ocaml/logger/.depend new file mode 100644 index 000000000..28268d29e --- /dev/null +++ b/helm/ocaml/logger/.depend @@ -0,0 +1,2 @@ +helmLogger.cmo: helmLogger.cmi +helmLogger.cmx: helmLogger.cmi diff --git a/helm/ocaml/logger/Makefile b/helm/ocaml/logger/Makefile new file mode 100644 index 000000000..dab9f5cb3 --- /dev/null +++ b/helm/ocaml/logger/Makefile @@ -0,0 +1,9 @@ + +PACKAGE = logger +INTERFACE_FILES = \ + helmLogger.mli +IMPLEMENTATION_FILES = \ + $(INTERFACE_FILES:%.mli=%.ml) + +include ../Makefile.common + diff --git a/helm/ocaml/logger/helmLogger.ml b/helm/ocaml/logger/helmLogger.ml new file mode 100644 index 000000000..c41674754 --- /dev/null +++ b/helm/ocaml/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/ocaml/logger/helmLogger.mli b/helm/ocaml/logger/helmLogger.mli new file mode 100644 index 000000000..633b5c3ec --- /dev/null +++ b/helm/ocaml/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/ocaml/mathql/.depend b/helm/ocaml/mathql/.depend new file mode 100644 index 000000000..e69de29bb diff --git a/helm/ocaml/mathql/Makefile b/helm/ocaml/mathql/Makefile new file mode 100644 index 000000000..17cafb431 --- /dev/null +++ b/helm/ocaml/mathql/Makefile @@ -0,0 +1,13 @@ +PACKAGE = mathql + +PREDICATES = + +INTERFACE_FILES = + +IMPLEMENTATION_FILES = mathQL.ml + +EXTRA_OBJECTS_TO_INSTALL = mathQL.ml mathQL.cmi + +EXTRA_OBJECTS_TO_CLEAN = + +include ../Makefile.common diff --git a/helm/ocaml/mathql/mathQL.ml b/helm/ocaml/mathql/mathQL.ml new file mode 100644 index 000000000..2504cfb4f --- /dev/null +++ b/helm/ocaml/mathql/mathQL.ml @@ -0,0 +1,133 @@ +(* 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://www.cs.unibo.it/helm/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +(* output data structures ***************************************************) + +type path = string list (* the name of an attribute *) + +type value = string list (* the value of an attribute *) + +type attribute = path * value (* an attribute *) + +type attribute_group = attribute list (* a group of attributes *) + +type attribute_set = attribute_group list (* the attributes of an URI *) + +type resource = string * attribute_set (* an attributed URI *) + +type resource_set = resource list (* the query result *) + +type result = resource_set + + +(* input data structures ****************************************************) + +type svar = string (* the name of a variable for a resource set *) + +type avar = string (* the name of a variable for a resource *) + +type vvar = string (* the name of a variable for an attribute value *) + +type inverse = bool + +type refine = RefineExact + | RefineSub + | RefineSuper + +type main = path + +type pattern = bool + +type exp = path * (path option) + +type exp_list = exp list + +type allbut = bool + +type xml = bool + +type source = bool + +type bin = BinFJoin (* full union - with attr handling *) + | BinFMeet (* full intersection - with attr handling *) + | BinFDiff (* full difference - with attr handling *) + +type gen = GenFJoin (* full union - with attr handling *) + | GenFMeet (* full intersection - with attr handling *) + +type test = Xor + | Or + | And + | Sub + | Meet + | Eq + | Le + | Lt + +type query = Empty + | SVar of svar + | AVar of avar + | Subj of msval + | Property of inverse * refine * path * + main * istrue * isfalse list * exp_list * + pattern * msval + | Select of avar * query * msval + | Bin of bin * query * query + | LetSVar of svar * query * query + | LetVVar of vvar * msval * query + | For of gen * avar * query * query + | Add of bool * groups * query + | If of msval * query * query + | Log of xml * source * query + | StatQuery of query + | Keep of allbut * path list * query + +and msval = False + | True + | Not of msval + | Ex of avar list * msval + | Test of test * msval * msval + | Const of string + | Set of msval list + | Proj of path option * query + | Dot of avar * path + | VVar of vvar + | StatVal of msval + | Count of msval + | Align of string * msval + +and groups = Attr of (path * msval) list list + | From of avar + +and con = pattern * path * msval + +and istrue = con list + +and isfalse = con list diff --git a/helm/ocaml/mathql_generator/.depend b/helm/ocaml/mathql_generator/.depend new file mode 100644 index 000000000..0dc5572a0 --- /dev/null +++ b/helm/ocaml/mathql_generator/.depend @@ -0,0 +1,15 @@ +mQGUtil.cmi: mQGTypes.cmo +mQueryGenerator.cmi: mQGTypes.cmo +cGMatchConclusion.cmi: mQGTypes.cmo +cGSearchPattern.cmi: mQGTypes.cmo +cGLocateInductive.cmi: mQGTypes.cmo +mQGUtil.cmo: mQGTypes.cmo mQGUtil.cmi +mQGUtil.cmx: mQGTypes.cmx mQGUtil.cmi +mQueryGenerator.cmo: mQGUtil.cmi mQGTypes.cmo mQueryGenerator.cmi +mQueryGenerator.cmx: mQGUtil.cmx mQGTypes.cmx mQueryGenerator.cmi +cGMatchConclusion.cmo: mQGTypes.cmo cGMatchConclusion.cmi +cGMatchConclusion.cmx: mQGTypes.cmx cGMatchConclusion.cmi +cGSearchPattern.cmo: mQGUtil.cmi mQGTypes.cmo cGSearchPattern.cmi +cGSearchPattern.cmx: mQGUtil.cmx mQGTypes.cmx cGSearchPattern.cmi +cGLocateInductive.cmo: mQGTypes.cmo cGLocateInductive.cmi +cGLocateInductive.cmx: mQGTypes.cmx cGLocateInductive.cmi diff --git a/helm/ocaml/mathql_generator/Makefile b/helm/ocaml/mathql_generator/Makefile new file mode 100644 index 000000000..cf8e820d9 --- /dev/null +++ b/helm/ocaml/mathql_generator/Makefile @@ -0,0 +1,15 @@ +PACKAGE = mathql_generator + +PREDICATES = + +INTERFACE_FILES = mQGUtil.mli mQueryGenerator.mli \ + cGMatchConclusion.mli cGSearchPattern.mli \ + cGLocateInductive.mli + +IMPLEMENTATION_FILES = mQGTypes.ml $(INTERFACE_FILES:%.mli=%.ml) + +EXTRA_OBJECTS_TO_INSTALL = mQGTypes.ml mQGTypes.cmi + +EXTRA_OBJECTS_TO_CLEAN = + +include ../Makefile.common diff --git a/helm/ocaml/mathql_generator/cGLocateInductive.ml b/helm/ocaml/mathql_generator/cGLocateInductive.ml new file mode 100644 index 000000000..261b29388 --- /dev/null +++ b/helm/ocaml/mathql_generator/cGLocateInductive.ml @@ -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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +exception NotAnInductiveDefinition + +let get_constraints = function + | Cic.MutInd (uri, t, _) -> + let uri = UriManager.string_of_uriref (uri, [t]) in + let constr_obj = + [(`InHypothesis, uri); (`MainHypothesis (Some 0), uri)] + in + let constr_rel = [`MainConclusion None] in + let constr_sort = [(`MainHypothesis (Some 1), MQGTypes.Prop)] in + (constr_obj, constr_rel, constr_sort) + | _ -> raise NotAnInductiveDefinition diff --git a/helm/ocaml/mathql_generator/cGLocateInductive.mli b/helm/ocaml/mathql_generator/cGLocateInductive.mli new file mode 100644 index 000000000..b6a51401e --- /dev/null +++ b/helm/ocaml/mathql_generator/cGLocateInductive.mli @@ -0,0 +1,31 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val get_constraints : Cic.term -> MQGTypes.must_restrictions + +exception NotAnInductiveDefinition diff --git a/helm/ocaml/mathql_generator/cGMatchConclusion.ml b/helm/ocaml/mathql_generator/cGMatchConclusion.ml new file mode 100644 index 000000000..0a67c2d0d --- /dev/null +++ b/helm/ocaml/mathql_generator/cGMatchConclusion.ml @@ -0,0 +1,161 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +module T = MQGTypes + +let text_of_entries out entries = + out "(** MatchConclusion: results of the term inspection **)\n"; + let text_of_entry (u, b, v) = + out (string_of_int v ^ " "); + out (if b then "$MC " else "$IC "); + out (u ^ "\n") + in List.iter text_of_entry entries + +let sort_entries entries = + let comparator (_, _, v1) (_, _, v2) = compare v1 v2 in + List.fast_sort comparator entries + +let levels_of_term metasenv context term = + let module TC = CicTypeChecker in + let module Red = CicReduction in + let degree t = + let rec degree_aux = function + | Cic.Sort _ -> 1 + | Cic.Cast (u, _) -> degree_aux u + | Cic.Prod (_, _, t) -> degree_aux t + | _ -> 2 + in + let u,_ = TC.type_of_aux' metasenv context t CicUniv.empty_ugraph in + degree_aux (Red.whd context u) + in + let entry_eq (s1, b1, v1) (s2, b2, v2) = + s1 = s2 && b1 = b2 + in + let rec entry_in e = function + | [] -> [e] + | head :: tail -> + head :: if entry_eq head e then tail else entry_in e tail + in + let inspect_uri main l uri tc v term = + let d = degree term in + entry_in (UriManager.string_of_uriref (uri, tc), main, 2 * v + d - 1) l + in + let rec inspect_term main l v term = match term with + Cic.Rel _ -> l + | Cic.Meta _ -> l + | Cic.Sort _ -> l + | Cic.Implicit _ -> l + | Cic.Var (u,exp_named_subst) -> + inspect_exp_named_subst l (succ v) exp_named_subst +(* + let l' = inspect_uri main l u [] v term in + inspect_exp_named_subst l' (succ v) exp_named_subst +*) + | Cic.Const (u,exp_named_subst) -> + let l' = inspect_uri main l u [] v term in + inspect_exp_named_subst l' (succ v) exp_named_subst + | Cic.MutInd (u, t, exp_named_subst) -> + let l' = inspect_uri main l u [t] v term in + inspect_exp_named_subst l' (succ v) exp_named_subst + | Cic.MutConstruct (u, t, c, exp_named_subst) -> + let l' = inspect_uri main l u [t; c] v term in + inspect_exp_named_subst l' (succ v) exp_named_subst + | Cic.Cast (uu, _) -> + inspect_term main l v uu + | Cic.Prod (_, uu, tt) -> + let luu = inspect_term false l (succ v) uu in + inspect_term main luu (succ v) tt + | Cic.Lambda (_, uu, tt) -> + let luu = inspect_term false l (succ v) uu in + inspect_term false luu (succ v) tt + | Cic.LetIn (_, uu, tt) -> + let luu = inspect_term false l (succ v) uu in + inspect_term false luu (succ v) tt + | Cic.Appl m -> inspect_list main l true v m + | Cic.MutCase (u, t, tt, uu, m) -> + let lu = inspect_uri main l u [t] (succ v) term in + let ltt = inspect_term false lu (succ v) tt in + let luu = inspect_term false ltt (succ v) uu in + inspect_list main luu false (succ v) m + | Cic.Fix (_, m) -> inspect_ind l (succ v) m + | Cic.CoFix (_, m) -> inspect_coind l (succ v) m + and inspect_list main l head v = function + | [] -> l + | tt :: m -> + let ltt = inspect_term main l (if head then v else v + 1) tt in + inspect_list false ltt false v m + and inspect_exp_named_subst l v = function + [] -> l + | (_,t) :: tl -> + let l' = inspect_term false l v t in + inspect_exp_named_subst l' v tl + and inspect_ind l v = function + | [] -> l + | (_, _, tt, uu) :: m -> + let ltt = inspect_term false l v tt in + let luu = inspect_term false ltt v uu in + inspect_ind luu v m + and inspect_coind l v = function + | [] -> l + | (_, tt, uu) :: m -> + let ltt = inspect_term false l v tt in + let luu = inspect_term false ltt v uu in + inspect_coind luu v m + in + let rec inspect_backbone = function + | Cic.Cast (uu, _) -> inspect_backbone uu + | Cic.Prod (_, _, tt) -> inspect_backbone tt + | Cic.LetIn (_, uu, tt) -> inspect_backbone tt + | t -> inspect_term true [] 0 t + in + inspect_backbone term + +let get_constraints e c t = + let can = sort_entries (levels_of_term e c t) in (* can restrictions *) + text_of_entries prerr_string can; flush stderr; (* logging *) + let rest_of (u, b, _) = + let p = if b then `MainConclusion None else `InConclusion in (p, u) + in + let rec split vp = function + | [], ((_, _, v) as hd) :: tl -> split v ([rest_of hd], tl) + | prev, ((_, _, ve) as hd) :: tl when vp = ve -> + split vp (rest_of hd :: prev, tl) + | p, l -> p, l + in + let rec mk_musts prev acc = function + | [] -> prev, acc + | l -> + let slice, next = split 0 ([], l) in + let acc = acc @ slice in + mk_musts (prev @ [acc]) acc next + in + mk_musts [] [] can + +let universe = [T.MainConclusion; T.InConclusion] diff --git a/helm/ocaml/mathql_generator/cGMatchConclusion.mli b/helm/ocaml/mathql_generator/cGMatchConclusion.mli new file mode 100644 index 000000000..a9fbef47f --- /dev/null +++ b/helm/ocaml/mathql_generator/cGMatchConclusion.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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val get_constraints: Cic.metasenv -> Cic.context -> Cic.term -> + MQGTypes.r_obj list list * + MQGTypes.r_obj list + +val universe : MQGTypes.universe diff --git a/helm/ocaml/mathql_generator/cGSearchPattern.ml b/helm/ocaml/mathql_generator/cGSearchPattern.ml new file mode 100644 index 000000000..1d7e85937 --- /dev/null +++ b/helm/ocaml/mathql_generator/cGSearchPattern.ml @@ -0,0 +1,197 @@ +(* 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 *) +(* 02/12/2002 *) +(* *) +(* Missing description *) +(* *) +(******************************************************************************) + +(* $Id$ *) + +module T = MQGTypes +module U = MQGUtil + +type classification = + Backbone of int + | Branch of int + | InConclusion + | InHypothesis +;; + +let soften_classification = + function + Backbone _ -> InConclusion + | Branch _ -> InHypothesis + | k -> k +;; + +let (!!) = + function + Backbone n -> `MainConclusion (Some n) + | Branch n -> `MainHypothesis (Some n) + | _ -> assert false +;; + +let (!!!) = + function + Backbone n -> `MainConclusion (Some n) + | Branch n -> `MainHypothesis (Some n) + | InConclusion -> `InConclusion + | InHypothesis -> `InHypothesis +;; + + +let (@@) (l1,l2,l3) (l1',l2',l3') = + let merge l1 l2 = + List.fold_left (fun i t -> if List.mem t l2 then i else t::i) l2 l1 + in + merge l1 l1', merge l2 l2', merge l3 l3' +;; + +let get_constraints term = + let module U = UriManager in + let module C = Cic in + let rec process_type_aux kind = + function + C.Var (uri,expl_named_subst) -> + (* andrea: this is a bug: variable are not indexedin the db + ([!!!kind, UriManager.string_of_uri uri],[],[]) @@ *) + (process_type_aux_expl_named_subst kind expl_named_subst) + | C.Rel _ -> + (match kind with + | InConclusion + | InHypothesis -> [],[],[] + | _ -> [],[!!kind],[]) + | C.Sort s -> + (match kind with + Backbone _ + | Branch _ -> + let s' = + match s with + Cic.Prop -> T.Prop + | Cic.Set -> T.Set + | Cic.Type _ -> T.Type (* TASSI: ?? *) + | Cic.CProp -> T.CProp + in + [],[],[!!kind,s'] + | _ -> [],[],[]) + | C.Meta _ -> [],[],[] (* ???? To be understood *) + | C.Implicit _ -> assert false + | C.Cast (te,_) -> + (* type ignored *) + process_type_aux kind te + | C.Prod (_,sou,ta) -> + let (source_kind,target_kind) = + match kind with + Backbone n -> (Branch 0, Backbone (n+1)) + | Branch n -> (InHypothesis, Branch (n+1)) + | k -> (k,k) + in + process_type_aux source_kind sou @@ + process_type_aux target_kind ta + | C.Lambda (_,sou,ta) -> + let kind' = soften_classification kind in + process_type_aux kind' sou @@ + process_type_aux kind' ta + | C.LetIn (_,te,ta)-> + let kind' = soften_classification kind in + process_type_aux kind' te @@ + process_type_aux kind ta + | C.Appl (he::tl) -> + let kind' = soften_classification kind in + process_type_aux kind he @@ + List.fold_left (fun i t -> i @@ process_type_aux kind' t) ([],[],[]) tl + | C.Appl _ -> assert false + | C.Const (uri,_) -> + [!!!kind, UriManager.string_of_uri uri],[],[] + | C.MutInd (uri,typeno,expl_named_subst) -> + ([!!!kind, U.string_of_uri uri ^ "#xpointer(1/" ^ + string_of_int (typeno + 1) ^ ")"],[],[]) @@ + (process_type_aux_expl_named_subst kind expl_named_subst) + | C.MutConstruct (uri,typeno,consno,expl_named_subst) -> + ([!!!kind, U.string_of_uri uri ^ "#xpointer(1/" ^ + string_of_int (typeno + 1) ^ "/" ^ string_of_int consno ^ ")"],[],[]) + @@ (process_type_aux_expl_named_subst kind expl_named_subst) + | C.MutCase (_,_,_,term,patterns) -> + (* outtype ignored *) + let kind' = soften_classification kind in + process_type_aux kind' term @@ + List.fold_left (fun i t -> i @@ process_type_aux kind' t) + ([],[],[]) patterns + | C.Fix (_,funs) -> + let kind' = soften_classification kind in + List.fold_left + (fun i (_,_,bo,ty) -> + i @@ + process_type_aux kind' bo @@ + process_type_aux kind' ty + ) ([],[],[]) funs + | C.CoFix (_,funs) -> + let kind' = soften_classification kind in + List.fold_left + (fun i (_,bo,ty) -> + i @@ + process_type_aux kind' bo @@ + process_type_aux kind' ty + ) ([],[],[]) funs + and process_type_aux_expl_named_subst kind = + List.fold_left + (fun i (_,t) -> i @@ (process_type_aux (soften_classification kind) t)) + ([],[],[]) +in + let obj_constraints,rel_constraints,sort_constraints = + process_type_aux (Backbone 0) (CicMiniReduction.letin_nf term) + in + (obj_constraints,rel_constraints,sort_constraints) +;; + +(*CSC: Debugging only *) +(* +let get_constraints term = + let res = get_constraints term in + let (objs,rels,sorts) = res in + let text_of_pos p = + U.text_of_position p ^ " " ^ U.text_of_depth p "NULL" + in + prerr_endline "Constraints on objs:" ; + List.iter + (function (p, u) -> prerr_endline (text_of_pos p ^ " " ^ u)) objs ; + prerr_endline "Constraints on Rels:" ; + List.iter (function p -> prerr_endline (text_of_pos (p:>T.full_position))) rels ; + prerr_endline "Constraints on Sorts:" ; + List.iter + (function (p, s) -> prerr_endline (text_of_pos (p:>T.full_position) ^ " " ^ U.text_of_sort s) + ) sorts ; + res +;; *) + +let universe = + [T.MainHypothesis; T.InHypothesis; T.MainConclusion; T.InConclusion] diff --git a/helm/ocaml/mathql_generator/cGSearchPattern.mli b/helm/ocaml/mathql_generator/cGSearchPattern.mli new file mode 100644 index 000000000..528283387 --- /dev/null +++ b/helm/ocaml/mathql_generator/cGSearchPattern.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 *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 02/12/2002 *) +(* *) +(* Missing description *) +(* *) +(******************************************************************************) + +val get_constraints : Cic.term -> MQGTypes.must_restrictions + +val universe : MQGTypes.universe diff --git a/helm/ocaml/mathql_generator/mQGTypes.ml b/helm/ocaml/mathql_generator/mQGTypes.ml new file mode 100644 index 000000000..9ed2ce253 --- /dev/null +++ b/helm/ocaml/mathql_generator/mQGTypes.ml @@ -0,0 +1,77 @@ +(* 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/. + *) + +(* AUTORS: Ferruccio Guidi + * Claudio Sacerdoti Coen + *) + +(* $Id$ *) + +(* low level types *********************************************************) + +type uri = string +type position = MainHypothesis + | InHypothesis + | MainConclusion + | InConclusion + | InBody +type depth = int +type sort = Set + | Prop + | Type + | CProp + +type spec = MustObj of uri list * position list * depth list + | MustSort of sort list * position list * depth list + | MustRel of position list * depth list + | OnlyObj of uri list * position list * depth list + | OnlySort of sort list * position list * depth list + | OnlyRel of position list * depth list + | Universe of position list + +(* high-level types ********************************************************) + +type optional_depth = int option + +type full_position = [ `MainHypothesis of optional_depth + | `MainConclusion of optional_depth + | `InHypothesis + | `InConclusion + | `InBody + ] + +type main_position = [ `MainHypothesis of optional_depth + | `MainConclusion of optional_depth + ] + +type r_obj = full_position * uri +type r_sort = main_position * sort +type r_rel = main_position + +type must_restrictions = (r_obj list * r_rel list * r_sort list) +type only_restrictions = + (r_obj list option * r_rel list option * r_sort list option) + +type universe = position list diff --git a/helm/ocaml/mathql_generator/mQGUtil.ml b/helm/ocaml/mathql_generator/mQGUtil.ml new file mode 100644 index 000000000..7603ab9a6 --- /dev/null +++ b/helm/ocaml/mathql_generator/mQGUtil.ml @@ -0,0 +1,150 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +module T = MQGTypes + +(* low level functions *****************************************************) + +let string_of_position p = + let ns = "http://www.cs.unibo.it/helm/schemas/schema-helm#" in + match p with + | T.MainHypothesis -> ns ^ "MainHypothesis" + | T.InHypothesis -> ns ^ "InHypothesis" + | T.MainConclusion -> ns ^ "MainConclusion" + | T.InConclusion -> ns ^ "InConclusion" + | T.InBody -> ns ^ "InBody" + +let string_of_sort = function + | T.Set -> "Set" + | T.Prop -> "Prop" + | T.Type -> "Type" + | T.CProp -> "CProp" + +let string_of_depth = string_of_int + +let mathql_of_position = function + | T.MainHypothesis -> "$MH" + | T.InHypothesis -> "$IH" + | T.MainConclusion -> "$MC" + | T.InConclusion -> "$IC" + | T.InBody -> "$IB" + +let mathql_of_sort = function + | T.Set -> "$SET" + | T.Prop -> "$PROP" + | T.Type -> "$TYPE" + | T.CProp -> "$CPROP" + +let mathql_of_depth = string_of_int + +let mathql_of_uri u = u + +let mathql_of_specs out l = + let rec iter f = function + | [] -> () + | [s] -> out "\""; out (f s); out "\"" + | s :: tail -> out "\""; out (f s); out "\", "; iter f tail + in + let txt_uri l = out "{"; iter mathql_of_uri l; out "} " in + let txt_pos l = out "{"; iter mathql_of_position l; out "} " in + let txt_sort l = out "{"; iter mathql_of_sort l; out "} " in + let txt_depth l = out "{"; iter mathql_of_depth l; out "} " in + let txt_spec = function + | T.MustObj (u, p, d) -> out "mustobj "; txt_uri u; txt_pos p; txt_depth d; out "\n" + | T.MustSort (s, p, d) -> out "mustsort "; txt_sort s; txt_pos p; txt_depth d; out "\n" + | T.MustRel ( p, d) -> out "mustrel "; txt_pos p; txt_depth d; out "\n" + | T.OnlyObj (u, p, d) -> out "onlyobj "; txt_uri u; txt_pos p; txt_depth d; out "\n" + | T.OnlySort (s, p, d) -> out "onlysort "; txt_sort s; txt_pos p; txt_depth d; out "\n" + | T.OnlyRel ( p, d) -> out "onlyrel "; txt_pos p; txt_depth d; out "\n" + | T.Universe ( p ) -> out "universe "; txt_pos p; out "\n" + in + List.iter txt_spec l + +let position_of_mathql = function + | "$MH" -> T.MainHypothesis + | "$IH" -> T.InHypothesis + | "$MC" -> T.MainConclusion + | "$IC" -> T.InConclusion + | "$IB" -> T.InBody + | _ -> raise Parsing.Parse_error + +let sort_of_mathql = function + | "$SET" -> T.Set + | "$PROP" -> T.Prop + | "$TYPE" -> T.Type + | "$CPROP" -> T.CProp + | _ -> raise Parsing.Parse_error + +let depth_of_mathql s = + try + let d = int_of_string s in + if d < 0 then raise (Failure "") else d + with Failure _ -> raise Parsing.Parse_error + +let uri_of_mathql s = s + +(* high level functions ****************************************************) + +let text_of_position = function + | `MainHypothesis _ -> "MainHypothesis" + | `MainConclusion _ -> "MainConclusion" + | `InHypothesis -> "InHypothesis" + | `InConclusion -> "InConclusion" + | `InBody -> "InBody" + +let text_of_depth pos no_depth_text = match pos with + | `MainHypothesis (Some d) + | `MainConclusion (Some d) -> string_of_int d + | _ -> no_depth_text + +let text_of_sort = function + | T.Set -> "Set" + | T.Prop -> "Prop" + | T.Type -> "Type" + | T.CProp -> "CProp" + +let is_main_position = function + | `MainHypothesis _ + | `MainConclusion _ -> true + | _ -> false + +let is_conclusion = function + | `MainConclusion _ + | `InConclusion -> true + | _ -> false + +let set_full_position pos depth = match pos with + | `MainHypothesis _ -> `MainHypothesis depth + | `MainConclusion _ -> `MainConclusion depth + | _ -> pos + +let set_main_position pos depth = match pos with + | `MainHypothesis _ -> `MainHypothesis depth + | `MainConclusion _ -> `MainConclusion depth diff --git a/helm/ocaml/mathql_generator/mQGUtil.mli b/helm/ocaml/mathql_generator/mQGUtil.mli new file mode 100644 index 000000000..065abb157 --- /dev/null +++ b/helm/ocaml/mathql_generator/mQGUtil.mli @@ -0,0 +1,69 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* low level functions *****************************************************) + +(* these functions give the string representation used in the db ----------*) + +val string_of_position : MQGTypes.position -> string +val string_of_depth : MQGTypes.depth -> string +val string_of_sort : MQGTypes.sort -> string + +(* these functions give the string representation used in MathQL ----------*) + +val mathql_of_position : MQGTypes.position -> string +val mathql_of_depth : MQGTypes.depth -> string +val mathql_of_uri : MQGTypes.uri -> string +val mathql_of_sort : MQGTypes.sort -> string + +val mathql_of_specs : (string -> unit) -> MQGTypes.spec list -> unit + +val position_of_mathql : string -> MQGTypes.position +val depth_of_mathql : string -> MQGTypes.depth +val uri_of_mathql : string -> MQGTypes.uri +val sort_of_mathql : string -> MQGTypes.sort + +(* high level functions ****************************************************) + +(* these functions give the textual representation used by umans ----------*) + +val text_of_position : MQGTypes.full_position -> string +val text_of_depth : MQGTypes.full_position -> string -> string +val text_of_sort : MQGTypes.sort -> string + +(* these functions classify the positions ---------------------------------*) + +val is_main_position : MQGTypes.full_position -> bool +val is_conclusion : MQGTypes.full_position -> bool + +(* these function apply changes to positions ------------------------------*) + +val set_full_position : MQGTypes.full_position -> MQGTypes.optional_depth -> + MQGTypes.full_position +val set_main_position : MQGTypes.main_position -> MQGTypes.optional_depth -> + MQGTypes.main_position diff --git a/helm/ocaml/mathql_generator/mQueryGenerator.ml b/helm/ocaml/mathql_generator/mQueryGenerator.ml new file mode 100644 index 000000000..784bc11dc --- /dev/null +++ b/helm/ocaml/mathql_generator/mQueryGenerator.ml @@ -0,0 +1,191 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +module M = MathQL +module T = MQGTypes +module U = MQGUtil + +(* low level functions *****************************************************) + +let locate s = + let query = + M.Property (true,M.RefineExact,["objectName"],[],[],[],[],false,(M.Const s) ) + in query + +let unreferred target_pattern source_pattern = + let query = + M.Bin (M.BinFDiff, + ( + M.Property(false,M.RefineExact,[],[],[],[],[],true,(M.Const target_pattern)) + ), ( + M.Property(false,M.RefineExact,["refObj"],["h:occurrence"],[],[],[],true,(M.Const source_pattern)) + + )) + in query + +let compose cl = + let letin = ref [] in + let must = ref [] in + let onlyobj = ref [] in + let onlysort = ref [] in + let onlyrel = ref [] in + let only = ref true in + let univ = ref [] in + let set_val = function + | [s] -> M.Const s + | l -> + let msval = M.Set (List.map (fun s -> M.Const s) l) in + if ! only then begin + let vvar = "val" ^ string_of_int (List.length ! letin) in + letin := (vvar, msval) :: ! letin; + M.VVar vvar + end else msval + in + let cons o (r, s, p, d) = + let con p = function + | [] -> [] + | l -> [(false, [p], set_val l)] + in + only := o; + con "h:occurrence" r @ + con "h:sort" (List.map U.string_of_sort s) @ + con "h:position" (List.map U.string_of_position p) @ + con "h:depth" (List.map U.string_of_depth d) + in + let property_must n c = + M.Property(true,M.RefineExact,[n],[],(cons false c),[],[],false,(M.Const "")) + in + let property_only n cl = + let rec build = function + | [] -> [] + | c :: tl -> + let r = (cons true) c in + if r = [] then build tl else r :: build tl + in + let cll = build cl in + M.Property(false,M.RefineExact,[n],[],!univ,cll,[],false,(M.Proj(None,(M.AVar "obj")))) + in + let rec aux = function + | [] -> () + | T.Universe l :: tail -> + only := true; + let l = List.map U.string_of_position l in + univ := [(false, ["h:position"], set_val l)]; aux tail + | T.MustObj(r,p,d) :: tail -> + must := property_must "refObj" (r, [], p, d) :: ! must; aux tail + | T.MustSort(s,p,d) :: tail -> + must := property_must "refSort" ([], s, p, d) :: ! must; aux tail + | T.MustRel(p,d) :: tail -> + must := property_must "refRel" ([], [], p, d) :: ! must; aux tail + | T.OnlyObj(r,p,d) :: tail -> + onlyobj := (r, [], p, d) :: ! onlyobj; aux tail + | T.OnlySort(s,p,d) :: tail -> + onlysort := ([], s, p, d) :: ! onlysort; aux tail + | T.OnlyRel(p,d) :: tail -> + onlyrel := ([], [], p, d) :: ! onlyrel; aux tail + in + let rec iter f g = function + | [] -> raise (Failure "MQueryGenerator.iter") + | [head] -> (f head) + | head :: tail -> let t = (iter f g tail) in g (f head) t + in + (* prerr_endline "(** Compose: received constraints **)"; + U.mathql_of_specs prerr_string cl; flush stderr; *) + aux cl; + let must_query = + if ! must = [] then + M.Property(false,M.RefineExact,[],[],[],[],[],true,(M.Const ".*")) + else + iter (fun x -> x) (fun x y -> M.Bin(M.BinFMeet,x,y)) ! must + in + let onlyobj_val = M.Not (M.Proj(None,(property_only "refObj" ! onlyobj))) in + let onlysort_val = M.Not (M.Proj(None,(property_only "refSort" ! onlysort))) in + let onlyrel_val = M.Not (M.Proj(None,(property_only "refRel" ! onlyrel))) in + let select_query x = + match ! onlyobj, ! onlysort, ! onlyrel with + | [], [], [] -> x + | _, [], [] -> M.Select("obj",x,onlyobj_val) + | [], _, [] -> M.Select("obj",x,onlysort_val) + | [], [], _ -> M.Select("obj",x,onlyrel_val) + | _, _, [] -> M.Select("obj",x,(M.Test(M.And,onlyobj_val,onlysort_val))) + | _, [], _ -> M.Select("obj",x,(M.Test(M.And,onlyobj_val,onlyrel_val))) + | [], _, _ -> M.Select("obj",x,(M.Test(M.And,onlysort_val,onlyrel_val))) + | _, _, _ -> M.Select("obj",x,(M.Test(M.And,(M.Test(M.And,onlyobj_val,onlysort_val)),onlyrel_val))) + in + let letin_query = + if ! letin = [] then fun x -> x + else + let f (vvar, msval) x = M.LetVVar(vvar,msval,x) in + iter f (fun x y z -> x (y z)) ! letin + in + letin_query (select_query must_query) + +(* high-level functions ****************************************************) + +let query_of_constraints u (musts_obj, musts_rel, musts_sort) + (onlys_obj, onlys_rel, onlys_sort) = + let conv = function + | `MainHypothesis None -> [T.MainHypothesis], [] + | `MainHypothesis (Some d) -> [T.MainHypothesis], [d] + | `MainConclusion None -> [T.MainConclusion], [] + | `MainConclusion (Some d) -> [T.MainConclusion], [d] + | `InHypothesis -> [T.InHypothesis], [] + | `InConclusion -> [T.InConclusion], [] + | `InBody -> [T.InBody], [] + in + let must_obj (p, u) = let p, d = conv p in T.MustObj ([u], p, d) in + let must_sort (p, s) = let p, d = conv p in T.MustSort ([s], p, d) in + let must_rel p = let p, d = conv p in T.MustRel (p, d) in + let only_obj (p, u) = let p, d = conv p in T.OnlyObj ([u], p, d) in + let only_sort (p, s) = let p, d = conv p in T.OnlySort ([s], p, d) in + let only_rel p = let p, d = conv p in T.OnlyRel (p, d) in + let must = List.map must_obj musts_obj @ + List.map must_rel musts_rel @ + List.map must_sort musts_sort + in + let only = + (match onlys_obj with + | None -> [] + | Some [] -> [T.OnlyObj ([], [], [])] + | Some l -> List.map only_obj l + ) @ + (match onlys_rel with + | None -> [] + | Some [] -> [T.OnlyRel ([], [])] + | Some l -> List.map only_rel l + ) @ + (match onlys_sort with + | None -> [] + | Some [] -> [T.OnlySort ([], [], [])] + | Some l -> List.map only_sort l + ) + in + let univ = match u with None -> [] | Some l -> [T.Universe l] in + compose (must @ only @ univ) diff --git a/helm/ocaml/mathql_generator/mQueryGenerator.mli b/helm/ocaml/mathql_generator/mQueryGenerator.mli new file mode 100644 index 000000000..decaa0ea7 --- /dev/null +++ b/helm/ocaml/mathql_generator/mQueryGenerator.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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* interface for the low-level constraints *********************************) + +val locate : string -> MathQL.query + +val unreferred : string -> string -> MathQL.query + +val compose : MQGTypes.spec list -> MathQL.query + +(* interface for the high-level constraints ********************************) + +val query_of_constraints : MQGTypes.universe option -> + MQGTypes.must_restrictions -> + MQGTypes.only_restrictions -> + MathQL.query diff --git a/helm/ocaml/mathql_interpreter/.depend b/helm/ocaml/mathql_interpreter/.depend new file mode 100644 index 000000000..186c81793 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/.depend @@ -0,0 +1,27 @@ +mQIPostgres.cmi: mQITypes.cmo +mQIMySql.cmi: mQITypes.cmo +mQIConn.cmi: mQITypes.cmo mQIMap.cmi +mQIProperty.cmi: mQITypes.cmo mQIConn.cmi +mQueryInterpreter.cmi: mQIConn.cmi +mQueryTParser.cmo: mQueryTParser.cmi +mQueryTParser.cmx: mQueryTParser.cmi +mQueryTLexer.cmo: mQueryTParser.cmi +mQueryTLexer.cmx: mQueryTParser.cmx +mQueryUtil.cmo: mQueryTParser.cmi mQueryTLexer.cmo mQueryUtil.cmi +mQueryUtil.cmx: mQueryTParser.cmx mQueryTLexer.cmx mQueryUtil.cmi +mQIUtil.cmo: mQIUtil.cmi +mQIUtil.cmx: mQIUtil.cmi +mQIPostgres.cmo: mQIPostgres.cmi +mQIPostgres.cmx: mQIPostgres.cmi +mQIMySql.cmo: mQIMySql.cmi +mQIMySql.cmx: mQIMySql.cmi +mQIMap.cmo: mQueryUtil.cmi mQIMap.cmi +mQIMap.cmx: mQueryUtil.cmx mQIMap.cmi +mQIConn.cmo: mQIPostgres.cmi mQIMySql.cmi mQIMap.cmi mQIConn.cmi +mQIConn.cmx: mQIPostgres.cmx mQIMySql.cmx mQIMap.cmx mQIConn.cmi +mQIProperty.cmo: mQIUtil.cmi mQIMap.cmi mQIConn.cmi mQIProperty.cmi +mQIProperty.cmx: mQIUtil.cmx mQIMap.cmx mQIConn.cmx mQIProperty.cmi +mQueryInterpreter.cmo: mQueryUtil.cmi mQIUtil.cmi mQIProperty.cmi mQIConn.cmi \ + mQueryInterpreter.cmi +mQueryInterpreter.cmx: mQueryUtil.cmx mQIUtil.cmx mQIProperty.cmx mQIConn.cmx \ + mQueryInterpreter.cmi diff --git a/helm/ocaml/mathql_interpreter/Makefile b/helm/ocaml/mathql_interpreter/Makefile new file mode 100644 index 000000000..bdd738135 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/Makefile @@ -0,0 +1,19 @@ +PACKAGE = mathql_interpreter + +PREDICATES = + +INTERFACE_FILES = mQueryUtil.mli mQIUtil.mli \ + mQIPostgres.mli mQIMySql.mli mQIMap.mli mQIConn.mli \ + mQIProperty.mli mQueryInterpreter.mli + +IMPLEMENTATION_FILES = mQueryTParser.ml mQueryTLexer.ml \ + mQITypes.ml $(INTERFACE_FILES:%.mli=%.ml) + +EXTRA_OBJECTS_TO_INSTALL = mQueryTLexer.cmi \ + mQueryTLexer.mll mQueryTParser.mly \ + mQITypes.ml mQITypes.cmi + +EXTRA_OBJECTS_TO_CLEAN = mQueryTParser.ml mQueryTParser.mli \ + mQueryTLexer.ml + +include ../Makefile.common diff --git a/helm/ocaml/mathql_interpreter/mQIConn.ml b/helm/ocaml/mathql_interpreter/mQIConn.ml new file mode 100644 index 000000000..270d1f9d0 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIConn.ml @@ -0,0 +1,130 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +type connection = MySQL_C of HMysql.dbd + | Postgres_C of Postgres.connection + | No_C + +type flag = Galax | Postgres | Queries | Result | Source | Times | Warn + +type handle = { + log : string -> unit; (* logging function *) + set : flag list; (* options *) + pgc : connection; (* PG connection *) + pgm : MQIMap.pg_map; (* PG conversion function *) + pga : MQIMap.pg_alias (* PG table aliases *) +} + +let tables handle p = MQIMap.get_tables handle.pgm p + +let field handle p t = MQIMap.get_field handle.pgm p t + +let resolve handle a = MQIMap.resolve handle.pga a + +let log handle = handle.log + +let set handle flag = List.mem flag handle.set + +let pgc handle = handle.pgc + +let flags handle = handle.set + +let string_of_flag = function + | Galax -> "G" + | Postgres -> "P" + | Queries -> "Q" + | Result -> "R" + | Source -> "S" + | Times -> "T" + | Warn -> "W" + +let flag_of_char = function + | 'G' -> [Galax] + | 'P' -> [Postgres] + | 'Q' -> [Queries] + | 'R' -> [Result] + | 'S' -> [Source] + | 'T' -> [Times] + | 'W' -> [Warn] + | _ -> [] + +let string_fold_left f a s = + let l = String.length s in + let rec aux b i = if i = l then b else aux (f b s.[i]) (succ i) in + aux a 0 + +let string_of_flags flags = + List.fold_left (fun s flag -> s ^ string_of_flag flag) "" flags + +let flags_of_string s = + string_fold_left (fun l c -> l @ flag_of_char c) [] s + +let init ?(flags = []) ?(log = ignore) () = + let flags = + if flags = [] then + flags_of_string (Helm_registry.get "mathql_interpreter.flags") + else + flags + in + let m, a = + let g = + if List.mem Galax flags + then MQIMap.empty_map else MQIMap.read_map + in g () + in + {log = log; set = flags; + pgc = begin + try + if List.mem Galax flags then No_C else + if List.mem Postgres flags then Postgres_C (MQIPostgres.init ()) else + MySQL_C (MQIMySql.init ()) + with Failure "mqi_connection" -> No_C + end; + pgm = m; pga = a + } + +let close handle = + match pgc handle with + | MySQL_C c -> MQIMySql.close c + | Postgres_C c -> MQIPostgres.close c + | No_C -> () + +let exec handle out table cols ct cfl = + match pgc handle with + | MySQL_C c -> MQIMySql.exec (c, out) table cols ct cfl + | Postgres_C c -> MQIPostgres.exec (c, out) table cols ct cfl + | No_C -> [] + +let connected handle = + pgc handle <> No_C + +let init_if_connected ?(flags = []) ?(log = ignore) () = + let handle = init ~flags:flags ~log:log () in + if connected handle then handle else raise (Failure "mqi connection failed") diff --git a/helm/ocaml/mathql_interpreter/mQIConn.mli b/helm/ocaml/mathql_interpreter/mQIConn.mli new file mode 100644 index 000000000..35c8b3ef0 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIConn.mli @@ -0,0 +1,65 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +type connection = MySQL_C of HMysql.dbd + | Postgres_C of Postgres.connection + | No_C + +type flag = Galax | Postgres | Queries | Result | Source | Times | Warn + +type handle = { + log : string -> unit; (* logging function *) + set : flag list; (* options *) + pgc : connection; (* PG connection *) + pgm : MQIMap.pg_map; (* PG conversion function *) + pga : MQIMap.pg_alias (* PG table aliases *) +} + +val string_of_flags : flag list -> string +val flags_of_string : string -> flag list + +val init : ?flags:(flag list) -> ?log:(string -> unit) -> unit -> handle +val close : handle -> unit +val connected : handle -> bool +val exec : handle -> (MQITypes.query -> unit) -> + MQITypes.table -> MQITypes.columns -> + string MQITypes.con_true -> string MQITypes.con_false -> + MQITypes.result + +val init_if_connected : ?flags:(flag list) -> ?log:(string -> unit) -> unit -> handle + +(* The following functions allow to read the handle internal fields. + * For exclusive use of the interpreter. + *) + +val log : handle -> string -> unit +val set : handle -> flag -> bool +val flags : handle -> flag list +val tables : handle -> MathQL.path -> MQIMap.pg_tables +val field : handle -> MathQL.path -> string -> string +val resolve : handle -> string -> string diff --git a/helm/ocaml/mathql_interpreter/mQIMap.ml b/helm/ocaml/mathql_interpreter/mQIMap.ml new file mode 100644 index 000000000..a5b6654c8 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIMap.ml @@ -0,0 +1,93 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +module U = MQueryUtil + +type pg_map = (MathQL.path * (bool * string * string option)) list + +type pg_tables = (bool * string) list + +type pg_alias = (string * string) list + +let empty_map () = [], [] + +let read_map () = + let map = Helm_registry.get "mathql_interpreter.db_map" in + let ich = open_in map in + let rec aux r s = + let d = input_line ich in + match Str.split (Str.regexp "[ \t]+") d with + | [] -> aux r s + | "#" :: _ -> aux r s + | t :: "<-" :: p -> aux ((p, (false, t, None)) :: r) s + | t :: c :: "<-" :: p -> aux ((p, (false, t, Some c)) :: r) s + | t :: "<+" :: p -> aux ((p, (true, t, None)) :: r) s + | t :: c :: "<+" :: p -> aux ((p, (true, t, Some c)) :: r) s + | [a; "->"; t] -> aux r ((a, t) :: s) + | ["->"] -> r, s + | _ -> raise (Failure "MQIMap.read_map") + in + let pgm, pga = aux [] [] in + close_in ich; + pgm, pga + +let comp c1 c2 = match c1, c2 with + | (_, t1), (_, t2) when t1 < t2 -> U.Lt + | (_, t1), (_, t2) when t1 > t2 -> U.Gt + | (b1, t), (b2, _) -> U.Eq (b1 || b2, t) + +let get_tables pgm p = + let aux l = function + | q, (b, t, _) when q = p -> U.list_join comp l [(b, t)] + | _, _ -> l + in + List.fold_left aux [] pgm + +let rec refine_tables l1 l2 = + U.list_meet comp l1 l2 + +let default_table = function + | [(_, a)] -> a + | l -> + try List.assoc true l + with Not_found -> raise (Failure "MQIMap.default_table") + +let get_field pgm p t = + let aux = function + | q, (_, u, _) when q = p && u = t -> true + | _ -> false + in + match List.filter aux pgm with + | [_, (_, _, None)] -> "" + | [_, (_, _, Some c)] -> c + | _ -> raise (Failure "MQIMap.get_field") + +let resolve pga a = + try List.assoc a pga with Not_found -> a diff --git a/helm/ocaml/mathql_interpreter/mQIMap.mli b/helm/ocaml/mathql_interpreter/mQIMap.mli new file mode 100644 index 000000000..50f5bb0fa --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIMap.mli @@ -0,0 +1,47 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +type pg_map (* mathql path map for postgres *) + +type pg_tables + +type pg_alias + +val empty_map : unit -> pg_map * pg_alias + +val read_map : unit -> pg_map * pg_alias + +val get_tables : pg_map -> MathQL.path -> pg_tables + +val refine_tables : pg_tables -> pg_tables -> pg_tables + +val default_table : pg_tables -> string + +val get_field : pg_map -> MathQL.path -> string -> string + +val resolve : pg_alias -> string -> string diff --git a/helm/ocaml/mathql_interpreter/mQIMySql.ml b/helm/ocaml/mathql_interpreter/mQIMySql.ml new file mode 100644 index 000000000..3380e1f1f --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIMySql.ml @@ -0,0 +1,96 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +let init () = + let module HR = Helm_registry in + let host = + HR.get_opt HR.get_string "mathql_interpreter.mysql_connection.host" in + let database = + HR.get_opt HR.get_string "mathql_interpreter.mysql_connection.database" in + let user = + HR.get_opt HR.get_string "mathql_interpreter.mysql_connection.user" in + let port = + HR.get_opt HR.get_int "mathql_interpreter.mysql_connection.port" in + let password = + HR.get_opt HR.get_string "mathql_interpreter.mysql_connection.password" in + try HMysql.quick_connect ?host ?database ?user ?port ?password () + with _ -> raise (Failure "mqi_connecion") + +let close c = HMysql.disconnect c + +let quote s = + let rec quote_aux s = + try + let l = String.length s in + let i = String.index s '\'' in + String.sub s 0 i ^ "\\'" ^ quote_aux (String.sub s (succ i) (l - (succ i))) + with Not_found -> s + in + "'" ^ quote_aux s ^ "'" + +let exec (c, out) q = + let g = function None -> "" | Some v -> v in + let f a = List.map g (Array.to_list a) in + out q; HMysql.map ~f:f (Mysql.exec c q) + +let exec c table cols ct cfl = + let rec iter f last sep = function + | [] -> last + | [head] -> f head + | head :: tail -> f head ^ sep ^ iter f last sep tail + in + let pg_cols = iter (fun x -> x) "" ", " cols in + let pg_msval v = iter quote "" ", " v in + let pg_con (pat, col, v) = + if col <> "" then + let f s = col ^ " regexp " ^ quote ("^" ^ s ^ "$") in + if pat then "(" ^ iter f "0" " or " v ^ ")" + else match v with + | [s] -> col ^ " = " ^ (quote s) + | v -> col ^ " in (" ^ pg_msval v ^ ")" + else "1" + in + let pg_cons l = iter pg_con "1" " and " l in + let pg_cons_not l = "not (" ^ pg_cons l ^ ")" in + let pg_cons_not_l ll = iter pg_cons_not "1" " and " ll in + let pg_where = match ct, cfl with + | [], [] -> "" + | lt, [] -> " where " ^ pg_cons lt + | [], llf -> " where " ^ pg_cons_not_l llf + | lt, llf -> " where " ^ pg_cons lt ^ " and " ^ pg_cons_not_l llf + in + if cols = [] then + let r = exec c ("select count(source) from " ^ table ^ pg_where) in + match r with + | [[s]] when int_of_string s > 0 -> [[]] + | _ -> [] + else + exec c ("select " ^ pg_cols ^ " from " ^ table ^ pg_where ^ + " order by " ^ List.hd cols ^ " asc") diff --git a/helm/ocaml/mathql_interpreter/mQIMySql.mli b/helm/ocaml/mathql_interpreter/mQIMySql.mli new file mode 100644 index 000000000..8afaf401d --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIMySql.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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val init : unit -> HMysql.dbd + +val close : HMysql.dbd -> unit + +val exec : HMysql.dbd * (MQITypes.query -> unit) -> + MQITypes.table -> MQITypes.columns -> + string MQITypes.con_true -> string MQITypes.con_false -> + MQITypes.result diff --git a/helm/ocaml/mathql_interpreter/mQIPostgres.ml b/helm/ocaml/mathql_interpreter/mQIPostgres.ml new file mode 100644 index 000000000..bef07230f --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIPostgres.ml @@ -0,0 +1,96 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +let init () = + let connection_string = + Helm_registry.get "mathql_interpreter.postgresql_connection_string" + in + try new Postgres.connection connection_string + with _ -> raise (Failure "mqi_connecion") + +let close c = c#close + +let quote s = + let rec quote_aux s = + try + let l = String.length s in + let i = String.index s '\'' in + String.sub s 0 i ^ "\\'" ^ quote_aux (String.sub s (succ i) (l - (succ i))) + with Not_found -> s + in + "'" ^ quote_aux s ^ "'" + +let exec (c, out) q = out q; (c#exec q)#get_list + +let exec c table cols ct cfl = + let rec iter f last sep = function + | [] -> last + | [head] -> f head + | head :: tail -> f head ^ sep ^ iter f last sep tail + in + let pg_cols = iter (fun x -> x) "" ", " cols in + let pg_msval v = iter quote "" ", " v in + let pg_con (pat, col, v) = + if col <> "" then + let f s = col ^ " ~ " ^ quote ("^" ^ s ^ "$") in + if pat then "(" ^ iter f "false" " or " v ^ ")" + else match v with + | [s] -> col ^ " = " ^ (quote s) + | v -> col ^ " in (" ^ pg_msval v ^ ")" + else "true" + in + let pg_cons l = iter pg_con "true" " and " l in + let pg_cons_not l = "not (" ^ pg_cons l ^ ")" in + let pg_cons_not_l ll = iter pg_cons_not "true" " and " ll in + let pg_where = match ct, cfl with + | [], [] -> "" + | lt, [] -> " where " ^ pg_cons lt + | [], llf -> " where " ^ pg_cons_not_l llf + | lt, llf -> " where " ^ pg_cons lt ^ " and " ^ pg_cons_not_l llf + in + if cols = [] then + let r = exec c ("select count(source) from " ^ table ^ pg_where) in + match r with + | [[s]] when int_of_string s > 0 -> [[]] + | _ -> [] + else + exec c ("select " ^ pg_cols ^ " from " ^ table ^ pg_where ^ + " order by " ^ List.hd cols ^ " asc") + +(* funzioni vecchie ********************************************************) +(* +let pg_name h s = + let q = "select id from registry where uri = " ^ quote s in + match exec h q with + | [[id]] -> "t" ^ id + | _ -> "" + +let get_id b = if b then ["B"] else ["F"] +*) diff --git a/helm/ocaml/mathql_interpreter/mQIPostgres.mli b/helm/ocaml/mathql_interpreter/mQIPostgres.mli new file mode 100644 index 000000000..cbbf3929d --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIPostgres.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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val init : unit -> Postgres.connection + +val close : Postgres.connection -> unit + +val exec : Postgres.connection * (MQITypes.query -> unit) -> + MQITypes.table -> MQITypes.columns -> + string MQITypes.con_true -> string MQITypes.con_false -> + MQITypes.result diff --git a/helm/ocaml/mathql_interpreter/mQIProperty.ml b/helm/ocaml/mathql_interpreter/mQIProperty.ml new file mode 100644 index 000000000..0e3e2be72 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIProperty.ml @@ -0,0 +1,103 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +module M = MathQL +module C = MQIConn +module U = MQIUtil +module A = MQIMap + +let not_supported s = + raise (Failure ("MQIProperty: feature not supported: " ^ s)) + +(* debugging ***************************************************************) + +let pg_print l = + let rec pg_record = function + | [] -> prerr_newline () + | head :: tail -> prerr_string (head ^ " "); pg_record tail + in + List.iter pg_record l + +let cl_print l = + let c_print (b, p, v) = + prerr_string (if b then "match " else "in "); + List.iter (fun x -> prerr_string ("/" ^ x)) p; + prerr_newline (); + List.iter prerr_endline v + in + List.iter c_print l + +(* Common functions ********************************************************) + +let pg_result distinct subj el res = + let compose = if distinct then List.map else fun f -> U.mql_iter (fun x -> [f x]) in + let get_name = function (p, None) -> p | (_, Some p) -> p in + let names = List.map get_name el in + let mk_grp l = + let grp = U.mql_iter2 (fun p s -> [(p, [s])]) names l in + if grp = [] then [] else [grp] + in + let mk_avs l = + if subj = "" then ("", mk_grp l) else (List.hd l, mk_grp (List.tl l)) + in + compose mk_avs res + +let get_table h mc ct cfl el = + let aux_c ts (_, p, _) = A.refine_tables ts (C.tables h p) in + let aux_e ts (p, _) = A.refine_tables ts (C.tables h p) in + let fst = C.tables h mc in + let snd = List.fold_left aux_c fst (ct @ (List.concat cfl)) in + let trd = List.fold_left aux_e snd el in + A.default_table trd + +let exec_single h mc ct cfl el table = + let conv p = C.field h p table in + let first = conv mc in + let mk_con l = List.map (fun (pat, p, v) -> (pat, conv p, v)) l in + let cons_true = mk_con ct in + let cons_false = List.map mk_con cfl in + let other_cols = List.map (fun (p, _) -> conv p) el in + let cols = if first = "" then other_cols else first :: other_cols in + let out q = if C.set h C.Queries then C.log h (q ^ "\n") in + let r = C.exec h out (C.resolve h table) cols cons_true cons_false in + pg_result false first el r + +let deadline = 100 + +let exec h refine mc ct cfl el = + if refine <> M.RefineExact then not_supported "exec"; + let table = get_table h mc ct cfl el in + let rec exec_aux ct = match ct with + | (pat, p, v) :: tail when List.length v > deadline -> + let single s = exec_aux ((pat, p, [s]) :: tail) in + U.mql_iter single v + | _ -> + exec_single h mc ct cfl el table + in exec_aux ct diff --git a/helm/ocaml/mathql_interpreter/mQIProperty.mli b/helm/ocaml/mathql_interpreter/mQIProperty.mli new file mode 100644 index 000000000..f8159aaa8 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIProperty.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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val exec: MQIConn.handle -> + MathQL.refine -> MathQL.path -> + MathQL.path MQITypes.con_true -> MathQL.path MQITypes.con_false -> + MathQL.exp_list -> MathQL.result diff --git a/helm/ocaml/mathql_interpreter/mQITypes.ml b/helm/ocaml/mathql_interpreter/mQITypes.ml new file mode 100644 index 000000000..ad4a8cb1b --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQITypes.ml @@ -0,0 +1,43 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +type 'a con = MathQL.pattern * 'a * MathQL.value + +type 'a con_true = 'a con list + +type 'a con_false = 'a con list list + +type table = string + +type columns = string list + +type result = string list list + +type query = string diff --git a/helm/ocaml/mathql_interpreter/mQIUtil.ml b/helm/ocaml/mathql_interpreter/mQIUtil.ml new file mode 100644 index 000000000..3f3fe6591 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIUtil.ml @@ -0,0 +1,155 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +(* boolean constants *******************************************************) + +let mql_false = [] + +let mql_true = [""] + +(* set theoretic operations *************************************************) + +let rec set_sub v1 v2 = + match v1, v2 with + | [], _ -> mql_true + | _, [] -> mql_false + | h1 :: _, h2 :: _ when h1 < h2 -> mql_false + | h1 :: _, h2 :: t2 when h1 > h2 -> set_sub v1 t2 + | _ :: t1, _ :: t2 -> set_sub t1 t2 + +let rec set_meet v1 v2 = + match v1, v2 with + | [], _ -> mql_false + | _, [] -> mql_false + | h1 :: t1, h2 :: _ when h1 < h2 -> set_meet t1 v2 + | h1 :: _, h2 :: t2 when h1 > h2 -> set_meet v1 t2 + | _, _ -> mql_true + +let set_eq v1 v2 = + if v1 = v2 then mql_true else mql_false + +let rec set_union v1 v2 = + match v1, v2 with + | [], v -> v + | v, [] -> v + | h1 :: t1, h2 :: t2 when h1 < h2 -> h1 :: set_union t1 v2 + | h1 :: t1, h2 :: t2 when h1 > h2 -> h2 :: set_union v1 t2 + | h1 :: t1, _ :: t2 -> h1 :: set_union t1 t2 + +let rec set_intersect v1 v2 = + match v1, v2 with + | [], v -> [] + | v, [] -> [] + | h1 :: t1, h2 :: _ when h1 < h2 -> set_intersect t1 v2 + | h1 :: _, h2 :: t2 when h1 > h2 -> set_intersect v1 t2 + | h1 :: t1, _ :: t2 -> h1 :: set_intersect t1 t2 + +let rec iter f = function + | [] -> [] + | head :: tail -> set_union (f head) (iter f tail) + +(* MathQL specific set operations ******************************************) + +let rec mql_union s1 s2 = + match s1, s2 with + | [], s -> s + | s, [] -> s + | (r1, g1) :: t1, (r2, _) :: _ when r1 < r2 -> + (r1, g1) :: mql_union t1 s2 + | (r1, _) :: _, (r2, g2) :: t2 when r1 > r2 -> + (r2, g2) :: mql_union s1 t2 + | (r1, g1) :: t1, (_, g2) :: t2 -> + (r1, set_union g1 g2) :: mql_union t1 t2 + +let rec mql_iter f = function + | [] -> [] + | head :: tail -> mql_union (f head) (mql_iter f tail) + +let rec mql_iter2 f l1 l2 = match l1, l2 with + | [], [] -> [] + | h1 :: t1, h2 :: t2 -> mql_union (f h1 h2) (mql_iter2 f t1 t2) + | _ -> raise (Invalid_argument "mql_iter2") + +let rec mql_prod g1 g2 = + let mql_prod_aux a = iter (fun h -> [mql_union a h]) g2 in + iter mql_prod_aux g1 + +let rec mql_intersect s1 s2 = + match s1, s2 with + | [], s -> [] + | s, [] -> [] + | (r1, _) :: t1, (r2, _) :: _ when r1 < r2 -> mql_intersect t1 s2 + | (r1, _) :: _, (r2, _) :: t2 when r1 > r2 -> mql_intersect s1 t2 + | (r1, g1) :: t1, (_, g2) :: t2 -> + (r1, set_intersect g1 g2) :: mql_intersect t1 t2 + +let rec mql_diff s1 s2 = + match s1, s2 with + | [], _ -> [] + | s, [] -> s + | (r1, g1) :: t1 , (r2, _) ::_ when r1 < r2 -> + (r1, g1) :: (mql_diff t1 s2) + | (r1, _) :: _, (r2, _) :: t2 when r1 > r2 -> mql_diff s1 t2 + | _ :: t1, _ :: t2 -> mql_diff t1 t2 + +(* logic operations ********************************************************) + +let xor v1 v2 = + let b = v1 <> mql_false in + if b && v2 <> mql_false then mql_false else + if b then v1 else v2 + +(* numeric operations ******************************************************) + +let int_of_list = function + | [s] -> int_of_string s + | _ -> raise (Failure "int_of_list") + +let le v1 v2 = + try if int_of_list v1 <= int_of_list v2 then mql_true else mql_false + with _ -> mql_false + +let lt v1 v2 = + try if int_of_list v1 < int_of_list v2 then mql_true else mql_false + with _ -> mql_false + +let align n v = + let c = String.length v in + try + let l = int_of_list [n] in + if c < l then [(String.make (l - c) ' ') ^ v] else [v] + with _ -> [v] + +(* context handling ********************************************************) + +let rec set ap = function + | [] -> [ap] + | head :: tail when fst head = fst ap -> ap :: tail + | head :: tail -> head :: set ap tail diff --git a/helm/ocaml/mathql_interpreter/mQIUtil.mli b/helm/ocaml/mathql_interpreter/mQIUtil.mli new file mode 100644 index 000000000..76735a863 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQIUtil.mli @@ -0,0 +1,69 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val mql_true : MathQL.value + +val mql_false : MathQL.value + +val set_sub : MathQL.value -> MathQL.value -> MathQL.value + +val set_meet : MathQL.value -> MathQL.value -> MathQL.value + +val set_eq : MathQL.value -> MathQL.value -> MathQL.value + +val set_union : 'a list -> 'a list -> 'a list + +val set_intersect : 'a list -> 'a list -> 'a list + +val mql_union : ('a * 'b list) list -> ('a * 'b list) list -> + ('a * 'b list) list + +val mql_prod : MathQL.attribute_set -> MathQL.attribute_set -> + MathQL.attribute_set + +val mql_intersect : MathQL.result -> MathQL.result -> MathQL.result + +val mql_diff : MathQL.result -> MathQL.result -> MathQL.result + +val iter : ('a -> 'b list) -> 'a list -> 'b list + +val mql_iter : ('c -> ('a * 'b list) list) -> 'c list -> + ('a * 'b list) list + +val mql_iter2 : ('c -> 'd -> ('a * 'b list) list) -> 'c list -> + 'd list -> ('a * 'b list) list + +val xor : MathQL.value -> MathQL.value -> MathQL.value + +val le : MathQL.value -> MathQL.value -> MathQL.value + +val lt : MathQL.value -> MathQL.value -> MathQL.value + +val align : string -> string -> MathQL.value + +val set : string * 'a -> (string * 'a) list -> (string * 'a) list diff --git a/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml b/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml new file mode 100644 index 000000000..9280a2c2a --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml @@ -0,0 +1,247 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +(* contexts *****************************************************************) + +type svar_context = (MathQL.svar * MathQL.resource_set) list + +type avar_context = (MathQL.avar * MathQL.resource) list + +type group_context = (MathQL.avar * MathQL.attribute_group) list + +type vvar_context = (MathQL.vvar * MathQL.value) list + +type context = {svars: svar_context; + avars: avar_context; + groups: group_context; (* auxiliary context *) + vvars: vvar_context + } + +(* execute *****************************************************************) + +exception Found + +module M = MathQL +module P = MQueryUtil +module C = MQIConn +module U = MQIUtil + +let execute h x = + let warn q = + if C.set h C.Warn then + begin + C.log h "MQIExecute: waring: reference to undefined variables: "; + P.text_of_query (C.log h) "\n" q + end + in + let rec eval_val c = function + | M.False -> U.mql_false + | M.True -> U.mql_true + | M.Const s -> [s] + | M.Set l -> U.iter (eval_val c) l + | M.Test (k,y1,y2) -> + let cand y1 y2 = + if eval_val c y1 = U.mql_false then U.mql_false else eval_val c y2 + in + let cor y1 y2 = + let v1 = eval_val c y1 in + if v1 = U.mql_false then eval_val c y2 else v1 + in + let h f y1 y2 = f (eval_val c y1) (eval_val c y2) in + let f = match k with + | M.And -> cand + | M.Or -> cor + | M.Xor -> h U.xor + | M.Sub -> h U.set_sub + | M.Meet -> h U.set_meet + | M.Eq -> h U.set_eq + | M.Le -> h U.le + | M.Lt -> h U.lt + in + f y1 y2 + | M.Not y -> + if eval_val c y = U.mql_false then U.mql_true else U.mql_false + | M.VVar i -> begin + try List.assoc i c.vvars + with Not_found -> warn (M.Subj (M.VVar i)); [] end + | M.Dot (i,p) -> begin + try List.assoc p (List.assoc i c.groups) + with Not_found -> warn (M.Subj (M.Dot (i,p))); [] end + | M.Proj (None,x) -> List.map (fun (r, _) -> r) (eval_query c x) + | M.Proj ((Some p),x) -> + let proj_group_aux (q, v) = if q = p then v else [] in + let proj_group a = U.iter proj_group_aux a in + let proj_set (_, g) = U.iter proj_group g in + U.iter proj_set (eval_query c x) + | M.Ex (l,y) -> + let rec ex_aux h = function + | [] -> + let d = {c with groups = h} in + if eval_val d y = U.mql_false then () else raise Found + | i :: tail -> + begin + try + let (_, a) = List.assoc i c.avars in + let rec add_group = function + | [] -> () + | g :: t -> ex_aux ((i, g) :: h) tail; add_group t + in + add_group a + with Not_found -> () + end + in + (try ex_aux [] l; U.mql_false with Found -> U.mql_true) + | M.StatVal y -> + let t = P.start_time () in + let r = (eval_val c y) in + let s = P.stop_time t in + C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r)); + r + | M.Count y -> [string_of_int (List.length (eval_val c y))] + | M.Align (s,y) -> U.iter (U.align s) (eval_val c y) + and eval_query c = function + | M.Empty -> [] + | M.Subj x -> + List.map (fun s -> (s, [])) (eval_val c x) + | M.Log (_,b,x) -> + if b then begin + let t = P.start_time () in + P.text_of_query (C.log h) "\n" x; + let s = P.stop_time t in + if C.set h C.Times then + C.log h (Printf.sprintf "Log source: %s\n" s); + eval_query c x + end else begin + let s = (eval_query c x) in + let t = P.start_time () in + P.text_of_result (C.log h) "\n" s; + let r = P.stop_time t in + if C.set h C.Times then + C.log h (Printf.sprintf "Log: %s\n" r); + s + end + | M.If (y,x1,x2) -> + if (eval_val c y) = U.mql_false + then (eval_query c x2) else (eval_query c x1) + | M.Bin (k,x1,x2) -> + let f = match k with + | M.BinFJoin -> U.mql_union + | M.BinFMeet -> U.mql_intersect + | M.BinFDiff -> U.mql_diff + in + f (eval_query c x1) (eval_query c x2) + | M.SVar i -> begin + try List.assoc i c.svars + with Not_found -> warn (M.SVar i); [] end + | M.AVar i -> begin + try [List.assoc i c.avars] + with Not_found -> warn (M.AVar i); [] end + | M.LetSVar (i,x1,x2) -> + let d = {c with svars = U.set (i, eval_query c x1) c.svars} in + eval_query d x2 + | M.LetVVar (i,y,x) -> + let d = {c with vvars = U.set (i, eval_val c y) c.vvars} in + eval_query d x + | M.For (k,i,x1,x2) -> + let f = match k with + | M.GenFJoin -> U.mql_union + | M.GenFMeet -> U.mql_intersect + in + let rec for_aux = function + | [] -> [] + | h :: t -> + let d = {c with avars = U.set (i, h) c.avars} in + f (eval_query d x2) (for_aux t) + in + for_aux (eval_query c x1) + | M.Add (b,z,x) -> + let f = if b then U.mql_prod else U.set_union in + let g a s = (fst a, f (snd a) (eval_grp c z)) :: s in + List.fold_right g (eval_query c x) [] + | M.Property (q0,q1,q2,mc,ct,cfl,el,pat,y) -> + let subj, mct = + if q0 then [], (pat, q2 @ mc, eval_val c y) + else (q2 @ mc), (pat, [], eval_val c y) + in + let eval_cons (pat, p, y) = (pat, q2 @ p, eval_val c y) in + let cons_true = mct :: List.map eval_cons ct in + let cons_false = List.map (List.map eval_cons) cfl in + let eval_exp (p, po) = (q2 @ p, po) in + let exp = List.map eval_exp el in + let t = P.start_time () in + let r = MQIProperty.exec h q1 subj cons_true cons_false exp in + let s = P.stop_time t in + if C.set h C.Times then + C.log h (Printf.sprintf "Property: %s,%i\n" s (List.length r)); + r + | M.StatQuery x -> + let t = P.start_time () in + let r = (eval_query c x) in + let s = P.stop_time t in + C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r)); + r + | M.Select (i,x,y) -> + let rec select_aux = function + | [] -> [] + | h :: t -> + let d = {c with avars = U.set (i, h) c.avars} in + if eval_val d y = U.mql_false + then select_aux t else h :: select_aux t + in + select_aux (eval_query c x) + | M.Keep (b,l,x) -> + let keep_path (p, v) t = + if List.mem p l = b then t else (p, v) :: t in + let keep_grp a = List.fold_right keep_path a [] in + let keep_set a g = + let kg = keep_grp a in + if kg = [] then g else kg :: g + in + let keep_av (s, g) = (s, List.fold_right keep_set g []) in + List.map keep_av (eval_query c x) + and eval_grp c = function + | M.Attr gs -> + let attr_aux g (p, y) = U.mql_union g [(p, eval_val c y)] in + let attr_auxs s l = U.set_union s [List.fold_left attr_aux [] l] in + List.fold_left attr_auxs [] gs + | M.From i -> + try snd (List.assoc i c.avars) + with Not_found -> warn (M.AVar i); [] + in + let c = {svars = []; avars = []; groups = []; vvars = []} in + let t = P.start_time () in + if C.set h C.Source then P.text_of_query (C.log h) "\n" x; + let r = eval_query c x in + if C.set h C.Result then P.text_of_result (C.log h) "\n" r; + let s = P.stop_time t in + if C.set h C.Times then + C.log h (Printf.sprintf "MQIExecute: %s,%s\n" s + (C.string_of_flags (C.flags h))); + r diff --git a/helm/ocaml/mathql_interpreter/mQueryInterpreter.mli b/helm/ocaml/mathql_interpreter/mQueryInterpreter.mli new file mode 100644 index 000000000..9d7081fff --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQueryInterpreter.mli @@ -0,0 +1,29 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val execute : MQIConn.handle -> MathQL.query -> MathQL.result diff --git a/helm/ocaml/mathql_interpreter/mQueryTLexer.mll b/helm/ocaml/mathql_interpreter/mQueryTLexer.mll new file mode 100644 index 000000000..ca51751f0 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQueryTLexer.mll @@ -0,0 +1,133 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +{ + open MQueryTParser + + let debug = false + + let out s = if debug then prerr_endline s +} + +let SPC = [' ' '\t' '\n']+ +let ALPHA = ['A'-'Z' 'a'-'z' '_'] +let NUM = ['0'-'9'] +let IDEN = ALPHA (NUM | ALPHA)* +let QSTR = [^ '"' '\\']+ + +rule comm_token = parse + | "(*" { comm_token lexbuf; comm_token lexbuf } + | "*)" { () } + | ['*' '('] { comm_token lexbuf } + | [^ '*' '(']* { comm_token lexbuf } +and string_token = parse + | '"' { DQ } + | '\\' _ { STR (String.sub (Lexing.lexeme lexbuf) 1 1) } + | QSTR { STR (Lexing.lexeme lexbuf) } + | eof { EOF } +and query_token = parse + | "(*" { comm_token lexbuf; query_token lexbuf } + | SPC { query_token lexbuf } + | '"' { let str = qstr string_token lexbuf in + out ("STR " ^ str); STR str } + | '(' { out "LP"; LP } + | ')' { out "RP"; RP } + | '{' { out "LC"; LC } + | '}' { out "RC"; RC } + | '@' { out "AT"; AT } + | '%' { out "PC"; PC } + | '$' { out "DL"; DL } + | '.' { out "FS"; FS } + | ',' { out "CM"; CM } + | ';' { out "SC"; SC } + | '/' { out "SL"; SL } + | "add" { out "ADD" ; ADD } + | "align" { out "ALIGN" ; ALIGN } + | "allbut" { out "BUT" ; BUT } + | "and" { out "AND" ; AND } + | "as" { out "AS" ; AS } + | "attr" { out "ATTR" ; ATTR } + | "be" { out "BE" ; BE } + | "count" { out "COUNT" ; COUNT } + | "diff" { out "DIFF" ; DIFF } + | "distr" { out "DISTR" ; DISTR } + | "else" { out "ELSE" ; ELSE } + | "empty" { out "EMPTY" ; EMPTY } + | "eq" { out "EQ" ; EQ } + | "ex" { out "EX" ; EX } + | "false" { out "FALSE" ; FALSE } + | "for" { out "FOR" ; FOR } + | "from" { out "FROM" ; FROM } + | "if" { out "IF" ; IF } + | "in" { out "IN" ; IN } + | "inf" { out "INF" ; INF } + | "intersect" { out "INTER" ; INTER } + | "inverse" { out "INV" ; INV } + | "istrue" { out "IST" ; IST } + | "isfalse" { out "ISF" ; ISF } + | "keep" { out "KEEP" ; KEEP } + | "le" { out "LE" ; LE } + | "let" { out "LET" ; LET } + | "log" { out "LOG" ; LOG } + | "lt" { out "LT" ; LT } + | "main" { out "MAIN" ; MAIN } + | "match" { out "MATCH" ; MATCH } + | "meet" { out "MEET" ; MEET } + | "not" { out "NOT" ; NOT } + | "of" { out "OF" ; OF } + | "or" { out "OR" ; OR } + | "pattern" { out "PAT" ; PAT } + | "proj" { out "PROJ" ; PROJ } + | "property" { out "PROP" ; PROP } + | "select" { out "SELECT"; SELECT } + | "source" { out "SOURCE"; SOURCE } + | "stat" { out "STAT" ; STAT } + | "sub" { out "SUB" ; SUB } + | "subj" { out "SUBJ" ; SUBJ } + | "sup" { out "SUP" ; SUP } + | "super" { out "SUPER" ; SUPER } + | "then" { out "THEN" ; THEN } + | "true" { out "TRUE" ; TRUE } + | "union" { out "UNION" ; UNION } + | "where" { out "WHERE" ; WHERE } + | "xor" { out "XOR" ; XOR } + | IDEN { let id = Lexing.lexeme lexbuf in + out ("ID " ^ id); ID id } + | eof { out "EOF" ; EOF } +and result_token = parse + | SPC { result_token lexbuf } + | "(*" { comm_token lexbuf; result_token lexbuf } + | '"' { STR (qstr string_token lexbuf) } + | '/' { out "SL"; SL } + | '{' { LC } + | '}' { RC } + | ',' { CM } + | ';' { SC } + | '=' { IS } + | "attr" { ATTR } + | eof { EOF } diff --git a/helm/ocaml/mathql_interpreter/mQueryTParser.mly b/helm/ocaml/mathql_interpreter/mQueryTParser.mly new file mode 100644 index 000000000..2f8896185 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQueryTParser.mly @@ -0,0 +1,314 @@ +/* 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/. + */ + +/* AUTOR: Ferruccio Guidi + */ + +%{ + module M = MathQL + + let analyze x = + let rec join l1 l2 = match l1, l2 with + | [], _ -> l2 + | _, [] -> l1 + | s1 :: tl1, s2 :: _ when s1 < s2 -> s1 :: join tl1 l2 + | s1 :: _, s2 :: tl2 when s2 < s1 -> s2 :: join l1 tl2 + | s1 :: tl1, s2 :: tl2 -> s1 :: join tl1 tl2 + in + let rec iter f = function + | [] -> [] + | head :: tail -> join (f head) (iter f tail) + in + let rec an_val = function + | M.True -> [] + | M.False -> [] + | M.Const _ -> [] + | M.VVar _ -> [] + | M.Ex _ -> [] + | M.Dot (rv,_) -> [rv] + | M.Not x -> an_val x + | M.StatVal x -> an_val x + | M.Count x -> an_val x + | M.Align (_,x) -> an_val x + | M.Proj (_,x) -> an_set x + | M.Test (_,x,y) -> iter an_val [x; y] + | M.Set l -> iter an_val l + and an_set = function + | M.Empty -> [] + | M.SVar _ -> [] + | M.AVar _ -> [] + | M.Subj x -> an_val x + | M.Keep (_,_,x) -> an_set x + | M.Log (_,_,x) -> an_set x + | M.StatQuery x -> an_set x + | M.Bin (_,x,y) -> iter an_set [x; y] + | M.LetSVar (_,x,y) -> iter an_set [x; y] + | M.For (_,_,x,y) -> iter an_set [x; y] + | M.Add (_,g,x) -> join (an_grp g) (an_set x) + | M.LetVVar (_,x,y) -> join (an_val x) (an_set y) + | M.Select (_,x,y) -> join (an_set x) (an_val y) + | M.Property (_,_,_,_,c,d,_,_,x) -> + join (an_val x) (iter an_con [c; List.concat d]) + | M.If (x,y,z) -> join (an_val x) (iter an_set [y; z]) + and fc (_, _, v) = an_val v + and an_con c = iter fc c + and fg (_, v) = an_val v + and an_grp = function + | M.Attr g -> iter (iter fg) g + | M.From _ -> [] + in + an_val x + + let f (x, y, z) = x + let s (x, y, z) = y + let t (x, y, z) = z +%} + %token ID STR + %token SL IS LC RC CM SC LP RP AT PC DL FS DQ EOF + %token ADD ALIGN AND AS ATTR BE BUT COUNT DIFF DISTR ELSE EMPTY EQ EX + %token FALSE FOR FROM IF IN INF INTER INV ISF IST KEEP LE LET LOG LT + %token MAIN MATCH MEET NOT OF OR PAT PROJ PROP SELECT SOURCE STAT SUB + %token SUBJ SUP SUPER THEN TRUE UNION WHERE XOR + %nonassoc IN SUP INF ELSE LOG STAT + %left DIFF + %left UNION + %left INTER + %nonassoc WHERE EX + %left XOR OR + %left AND + %nonassoc NOT + %nonassoc SUB MEET EQ LT LE + %nonassoc SUBJ OF PROJ COUNT ALIGN + + %start qstr query result + %type qstr + %type query + %type result +%% + qstr: + | DQ { "" } + | STR qstr { $1 ^ $2 } + ; + svar: + | PC ID { $2 } + ; + avar: + | AT ID { $2 } + ; + vvar: + | DL ID { $2 } + ; + strs: + | STR CM strs { $1 :: $3 } + | STR { [$1] } + ; + subpath: + | STR SL subpath { $1 :: $3 } + | STR { [$1] } + ; + path: + | subpath { $1 } + | SL subpath { $2 } + | SL { [] } + ; + paths: + | path CM paths { $1 :: $3 } + | path { [$1] } + inv: + | INV { true } + | { false } + ; + ref: + | SUB { M.RefineSub } + | SUPER { M.RefineSuper } + | { M.RefineExact } + ; + qualif: + | inv ref path { $1, $2, $3 } + ; + cons: + | path IN val_exp { (false, $1, $3) } + | path MATCH val_exp { (true, $1, $3) } + ; + conss: + | cons CM conss { $1 :: $3 } + | cons { [$1] } + ; + istrue: + | IST conss { $2 } + | { [] } + ; + isfalse: + | { [] } + | ISF conss isfalse { $2 :: $3 } + ; + mainc: + | MAIN path { $2 } + | { [] } + ; + exp: + | path AS path { $1, Some $3 } + | path { $1, None } + ; + exps: + | exp CM exps { $1 :: $3 } + | exp { [$1] } + ; + attrc: + | ATTR exps { $2 } + | { [] } + ; + pattern: + | PAT { true } + | { false } + ; + opt_path: + | path { Some $1 } + | { None } + ; + ass: + | val_exp AS path { ($3, $1) } + ; + asss: + | ass CM asss { $1 :: $3 } + | ass { [$1] } + ; + assg: + | asss SC assg { $1 :: $3 } + | asss { [$1] } + ; + distr: + | DISTR { true } + | { false } + ; + allbut: + | BUT { true } + | { false } + ; + bin_op: + | set_exp DIFF set_exp { M.BinFDiff, $1, $3 } + | set_exp UNION set_exp { M.BinFJoin, $1, $3 } + | set_exp INTER set_exp { M.BinFMeet, $1, $3 } + ; + gen_op: + | SUP set_exp { M.GenFJoin, $2 } + | INF set_exp { M.GenFMeet, $2 } + ; + test_op: + | val_exp XOR val_exp { M.Xor, $1, $3 } + | val_exp OR val_exp { M.Or, $1, $3 } + | val_exp AND val_exp { M.And, $1, $3 } + | val_exp SUB val_exp { M.Sub, $1, $3 } + | val_exp MEET val_exp { M.Meet, $1, $3 } + | val_exp EQ val_exp { M.Eq, $1, $3 } + | val_exp LE val_exp { M.Le, $1, $3 } + | val_exp LT val_exp { M.Lt, $1, $3 } + ; + source: + | SOURCE { true } + | { false } + ; + xml: + | { false} + ; + grp_exp: + | assg { M.Attr $1 } + | avar { M.From $1 } + ; + val_exp: + | TRUE { M.True } + | FALSE { M.False } + | STR { M.Const $1 } + | avar FS path { M.Dot ($1,$3) } + | vvar { M.VVar $1 } + | LC vals RC { M.Set $2 } + | LC RC { M.Set [] } + | LP val_exp RP { $2 } + | STAT val_exp { M.StatVal $2 } + | EX val_exp { M.Ex ((analyze $2),$2) } + | NOT val_exp { M.Not $2 } + | test_op { M.Test ((f $1),(s $1),(t $1)) } + | PROJ opt_path set_exp { M.Proj ($2,$3) } + | COUNT val_exp { M.Count $2 } + | ALIGN STR IN val_exp { M.Align ($2,$4) } + ; + vals: + | val_exp CM vals { $1 :: $3 } + | val_exp { [$1] } + ; + set_exp: + | EMPTY { M.Empty } + | LP set_exp RP { $2 } + | svar { M.SVar $1 } + | avar { M.AVar $1 } + | LET svar BE set_exp IN set_exp { M.LetSVar ($2,$4,$6) } + | LET vvar BE val_exp IN set_exp { M.LetVVar ($2,$4,$6) } + | FOR avar IN set_exp gen_op + { M.For ((fst $5),$2,$4,(snd $5)) } + | ADD distr grp_exp IN set_exp { M.Add ($2,$3,$5) } + | IF val_exp THEN set_exp ELSE set_exp { M.If ($2,$4,$6) } + | PROP qualif mainc istrue isfalse attrc OF pattern val_exp + { M.Property ((f $2),(s $2),(t $2),$3,$4,$5,$6,$8,$9) } + | LOG xml source set_exp { M.Log ($2,$3,$4) } + | STAT set_exp { M.StatQuery $2 } + | KEEP allbut paths IN set_exp { M.Keep ($2,$3,$5) } + | KEEP allbut IN set_exp { M.Keep ($2,[],$4) } + | bin_op + { M.Bin ((f $1),(s $1),(t $1)) } + | SELECT avar FROM set_exp WHERE val_exp { M.Select ($2,$4,$6) } + | SUBJ val_exp { M.Subj $2 } + ; + query: + | set_exp { $1 } + | set_exp error { $1 } + | EOF { raise End_of_file } + ; + attr: + | path IS strs { $1, $3 } + | path { $1, [] } + ; + attrs: + | attr SC attrs { $1 :: $3 } + | attr { [$1] } + ; + group: + LC attrs RC { $2 } + ; + groups: + | group CM groups { $1 :: $3 } + | group { [$1] } + ; + resource: + | STR ATTR groups { ($1, $3) } + | STR { ($1, []) } + ; + resources: + | resource SC resources { $1 :: $3 } + | resource { [$1] } + | { [] } + ; + result: + | resources { $1 } + | EOF { raise End_of_file } diff --git a/helm/ocaml/mathql_interpreter/mQueryUtil.ml b/helm/ocaml/mathql_interpreter/mQueryUtil.ml new file mode 100644 index 000000000..6323cc950 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQueryUtil.ml @@ -0,0 +1,220 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +(* $Id$ *) + +(* text linearization and parsing *******************************************) + +let rec txt_list out f s = function + | [] -> () + | [a] -> f a + | a :: tail -> f a; out s; txt_list out f s tail + +let txt_str out s = out ("\"" ^ s ^ "\"") + +let txt_path out p = out "/"; txt_list out (txt_str out) "/" p + +let text_of_query out sep x = + let module M = MathQL in + let txt_path_list l = txt_list out (txt_path out) ", " l in + let txt_svar sv = out ("%" ^ sv) in + let txt_avar av = out ("@" ^ av) in + let txt_vvar vv = out ("$" ^ vv) in + let txt_inv i = if i then out "inverse " in + let txt_ref = function + | M.RefineExact -> () + | M.RefineSub -> out "sub " + | M.RefineSuper -> out "super " + in + let txt_qualif i r p = txt_inv i; txt_ref r; txt_path out p in + let main = function + | [] -> () + | p -> out " main "; txt_path out p + in + let txt_exp = function + | (pl, None) -> txt_path out pl + | (pl, Some pr) -> txt_path out pl; out " as "; txt_path out pr + in + let txt_exp_list = function + | [] -> () + | l -> out " attr "; txt_list out txt_exp ", " l + in + let pattern b = if b then out "pattern " in + let txt_opt_path = function + | None -> () + | Some p -> txt_path out p; out " " + in + let txt_distr d = if d then out "distr " in + let txt_bin = function + | M.BinFJoin -> out " union " + | M.BinFMeet -> out " intersect " + | M.BinFDiff -> out " diff " + in + let txt_gen = function + | M.GenFJoin -> out " sup " + | M.GenFMeet -> out " inf " + in + let txt_test = function + | M.Xor -> out " xor " + | M.Or -> out " or " + | M.And -> out " and " + | M.Sub -> out " sub " + | M.Meet -> out " meet " + | M.Eq -> out " eq " + | M.Le -> out " le " + | M.Lt -> out " lt " + in + let txt_log a b = + if a then out "xml "; + if b then out "source " + in + let txt_allbut b = if b then out "allbut " in + let rec txt_con (pat, p, x) = + txt_path out p; + if pat then out " match " else out " in "; + txt_val x + and txt_con_list s = function + | [] -> () + | l -> out s; txt_list out txt_con ", " l + and txt_istrue lt = txt_con_list " istrue " lt + and txt_isfalse lf = txt_con_list " isfalse " lf + and txt_ass (p, x) = txt_val x; out " as "; txt_path out p + and txt_ass_list l = txt_list out txt_ass ", " l + and txt_assg_list g = txt_list out txt_ass_list "; " g + and txt_val_list = function + | [v] -> txt_val v + | l -> out "{"; txt_list out txt_val ", " l; out "}" + and txt_grp = function + | M.Attr g -> txt_assg_list g + | M.From av -> txt_avar av + and txt_val = function + | M.True -> out "true" + | M.False -> out "false" + | M.Const s -> txt_str out s + | M.Set l -> txt_val_list l + | M.VVar vv -> txt_vvar vv + | M.Dot (av,p) -> txt_avar av; out "."; txt_path out p + | M.Proj (op,x) -> out "proj "; txt_opt_path op; txt_set x + | M.Ex (b,x) -> out "ex "; txt_val x +(* | M.Ex b x -> out "ex ["; txt_list out txt_avar "," b; out "] "; txt_val x +*) | M.Not x -> out "not "; txt_val x + | M.Test (k,x,y) -> out "("; txt_val x; txt_test k; txt_val y; out ")" + | M.StatVal x -> out "stat "; txt_val x + | M.Count x -> out "count "; txt_val x + | M.Align (s,x) -> out "align "; txt_str out s; out " in "; txt_val x + and txt_set = function + | M.Empty -> out "empty" + | M.SVar sv -> txt_svar sv + | M.AVar av -> txt_avar av + | M.Property (q0,q1,q2,mc,ct,cfl,xl,b,x) -> + out "property "; txt_qualif q0 q1 q2; main mc; + txt_istrue ct; txt_list out txt_isfalse "" cfl; txt_exp_list xl; + out " of "; pattern b; txt_val x + | M.Bin (k,x,y) -> out "("; txt_set x; txt_bin k; txt_set y; + out ")" + | M.LetSVar (sv,x,y) -> out "let "; txt_svar sv; out " be "; + txt_set x; out " in "; txt_set y + | M.LetVVar (vv,x,y) -> out "let "; txt_vvar vv; out " be "; + txt_val x; out " in "; txt_set y + | M.Select (av,x,y) -> out "select "; txt_avar av; out " from "; + txt_set x; out " where "; txt_val y + | M.Subj x -> out "subj "; txt_val x + | M.For (k,av,x,y) -> out "for "; txt_avar av; out " in "; + txt_set x; txt_gen k; txt_set y + | M.If (x,y,z) -> out "if "; txt_val x; out " then "; + txt_set y; out " else "; txt_set z + | M.Add (d,g,x) -> out "add "; txt_distr d; txt_grp g; + out " in "; txt_set x + | M.Log (a,b,x) -> out "log "; txt_log a b; txt_set x + | M.StatQuery x -> out "stat "; txt_set x + | M.Keep (b,l,x) -> out "keep "; txt_allbut b; txt_path_list l; + txt_set x + in + txt_set x; out sep + +let text_of_result out sep x = + let txt_attr = function + | (p, []) -> txt_path out p + | (p, l) -> txt_path out p; out " = "; txt_list out (txt_str out) ", " l + in + let txt_group l = out "{"; txt_list out txt_attr "; " l; out "}" in + let txt_res = function + | (s, []) -> txt_str out s + | (s, l) -> txt_str out s; out " attr "; txt_list out txt_group ", " l + in + let txt_set l = txt_list out txt_res ("; " ^ sep) l; out sep in + txt_set x + +let query_of_text lexbuf = + MQueryTParser.query MQueryTLexer.query_token lexbuf + +let result_of_text lexbuf = + MQueryTParser.result MQueryTLexer.result_token lexbuf + +(* time handling ***********************************************************) + +type time = float * float + +let start_time () = + (Sys.time (), Unix.time ()) + +let stop_time (s0, u0) = + let s1 = Sys.time () in + let u1 = Unix.time () in + Printf.sprintf "%.2fs,%.2fs" (s1 -. s0) (u1 -. u0) + +(* operations on lists *****************************************************) + +type 'a comparison = Lt + | Gt + | Eq of 'a + +let list_join f l1 l2 = + let rec aux = function + | [], v + | v, [] -> v + | ((h1 :: t1) as v1), ((h2 :: t2) as v2) -> begin + match f h1 h2 with + | Lt -> h1 :: aux (t1, v2) + | Gt -> h2 :: aux (v1, t2) + | Eq h -> h :: aux (t1, t2) + end + in aux (l1, l2) + +let list_meet f l1 l2 = + let rec aux = function + | [], v + | v, [] -> [] + | ((h1 :: t1) as v1), ((h2 :: t2) as v2) -> begin + match f h1 h2 with + | Lt -> aux (t1, v2) + | Gt -> aux (v1, t2) + | Eq h -> h :: aux (t1, t2) + end + in aux (l1, l2) + diff --git a/helm/ocaml/mathql_interpreter/mQueryUtil.mli b/helm/ocaml/mathql_interpreter/mQueryUtil.mli new file mode 100644 index 000000000..575400298 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mQueryUtil.mli @@ -0,0 +1,49 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +val text_of_query : (string -> unit) -> string -> MathQL.query -> unit + +val text_of_result : (string -> unit) -> string -> MathQL.result -> unit + +val query_of_text : Lexing.lexbuf -> MathQL.query + +val result_of_text : Lexing.lexbuf -> MathQL.result + +type time + +val start_time : unit -> time + +val stop_time : time -> string + +type 'a comparison = Lt + | Gt + | Eq of 'a + +val list_join : ('a -> 'a -> 'a comparison) -> 'a list -> 'a list -> 'a list + +val list_meet : ('a -> 'a -> 'a comparison) -> 'a list -> 'a list -> 'a list diff --git a/helm/ocaml/metadata/.depend b/helm/ocaml/metadata/.depend new file mode 100644 index 000000000..04197957b --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/Makefile b/helm/ocaml/metadata/Makefile new file mode 100644 index 000000000..29ca2d3bc --- /dev/null +++ b/helm/ocaml/metadata/Makefile @@ -0,0 +1,37 @@ +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.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: + make -C table_creator/ clean + +clean_extractor: + make -C extractor/ clean + diff --git a/helm/ocaml/metadata/dump_db/dump.sh b/helm/ocaml/metadata/dump_db/dump.sh new file mode 100755 index 000000000..e7b43666e --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/extractor/.depend b/helm/ocaml/metadata/extractor/.depend new file mode 100644 index 000000000..e69de29bb diff --git a/helm/ocaml/metadata/extractor/Makefile b/helm/ocaml/metadata/extractor/Makefile new file mode 100644 index 000000000..e58064b41 --- /dev/null +++ b/helm/ocaml/metadata/extractor/Makefile @@ -0,0 +1,30 @@ +OCAMLFIND=ocamlfind + +all: extractor extractor_manager +opt: extractor.opt extractor_manager.opt + +clean: + rm -f *.cm[ixo] *.[ao] extractor extractor.opt *.err *.out extractor_manager extractor_manager.opt + +extractor: extractor.ml + $(OCAMLFIND) ocamlc \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +extractor.opt: extractor.ml + $(OCAMLFIND) ocamlopt \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +extractor_manager: extractor_manager.ml + $(OCAMLFIND) ocamlc \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +extractor_manager.opt: extractor_manager.ml + $(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 diff --git a/helm/ocaml/metadata/extractor/extractor.conf.xml b/helm/ocaml/metadata/extractor/extractor.conf.xml new file mode 100644 index 000000000..8dbc9a935 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/extractor/extractor.ml b/helm/ocaml/metadata/extractor/extractor.ml new file mode 100644 index 000000000..418d5ff7c --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/extractor/extractor_manager.ml b/helm/ocaml/metadata/extractor/extractor_manager.ml new file mode 100644 index 000000000..05393b63e --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataConstraints.ml b/helm/ocaml/metadata/metadataConstraints.ml new file mode 100644 index 000000000..07fcc738b --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataConstraints.mli b/helm/ocaml/metadata/metadataConstraints.mli new file mode 100644 index 000000000..63757ae47 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataDb.ml b/helm/ocaml/metadata/metadataDb.ml new file mode 100644 index 000000000..457545dee --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataDb.mli b/helm/ocaml/metadata/metadataDb.mli new file mode 100644 index 000000000..86820aafb --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataExtractor.ml b/helm/ocaml/metadata/metadataExtractor.ml new file mode 100644 index 000000000..4fbae1ba7 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataExtractor.mli b/helm/ocaml/metadata/metadataExtractor.mli new file mode 100644 index 000000000..68af269a9 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataPp.ml b/helm/ocaml/metadata/metadataPp.ml new file mode 100644 index 000000000..373ec540f --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataPp.mli b/helm/ocaml/metadata/metadataPp.mli new file mode 100644 index 000000000..cffb24c48 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataTypes.ml b/helm/ocaml/metadata/metadataTypes.ml new file mode 100644 index 000000000..e186b377a --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/metadataTypes.mli b/helm/ocaml/metadata/metadataTypes.mli new file mode 100644 index 000000000..f86ff84f5 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/sqlStatements.ml b/helm/ocaml/metadata/sqlStatements.ml new file mode 100644 index 000000000..a08073965 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/sqlStatements.mli b/helm/ocaml/metadata/sqlStatements.mli new file mode 100644 index 000000000..9f9af55ef --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/table_creator/.depend b/helm/ocaml/metadata/table_creator/.depend new file mode 100644 index 000000000..1cf113d91 --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/table_creator/Makefile b/helm/ocaml/metadata/table_creator/Makefile new file mode 100644 index 000000000..cb8ab7636 --- /dev/null +++ b/helm/ocaml/metadata/table_creator/Makefile @@ -0,0 +1,31 @@ +REQUIRES = mysql helm-metadata +OCAMLFIND = ocamlfind + +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 +opt: table_creator.opt table_destructor.opt + +table_creator: table_creator.ml ../metadata.cma + $(OCAMLFIND) ocamlc \ + -thread -package mysql,helm-metadata -linkpkg -o $@ $< + +table_destructor: table_creator + ln -f $< $@ + +table_creator.opt: table_creator.ml ../metadata.cmxa + $(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 diff --git a/helm/ocaml/metadata/table_creator/sync_db.sh b/helm/ocaml/metadata/table_creator/sync_db.sh new file mode 100755 index 000000000..7b201382a --- /dev/null +++ b/helm/ocaml/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/ocaml/metadata/table_creator/table_creator.ml b/helm/ocaml/metadata/table_creator/table_creator.ml new file mode 100644 index 000000000..423edfb27 --- /dev/null +++ b/helm/ocaml/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/ocaml/paramodulation/.depend b/helm/ocaml/paramodulation/.depend new file mode 100644 index 000000000..7c6673bad --- /dev/null +++ b/helm/ocaml/paramodulation/.depend @@ -0,0 +1,12 @@ +inference.cmi: utils.cmi +equality_indexing.cmi: utils.cmi inference.cmi +utils.cmo: utils.cmi +utils.cmx: utils.cmi +inference.cmo: utils.cmi inference.cmi +inference.cmx: utils.cmx inference.cmi +equality_indexing.cmo: utils.cmi inference.cmi equality_indexing.cmi +equality_indexing.cmx: utils.cmx inference.cmx equality_indexing.cmi +indexing.cmo: utils.cmi inference.cmi equality_indexing.cmi +indexing.cmx: utils.cmx inference.cmx equality_indexing.cmx +saturation.cmo: utils.cmi inference.cmi indexing.cmo +saturation.cmx: utils.cmx inference.cmx indexing.cmx diff --git a/helm/ocaml/paramodulation/Makefile b/helm/ocaml/paramodulation/Makefile new file mode 100644 index 000000000..35b650ea7 --- /dev/null +++ b/helm/ocaml/paramodulation/Makefile @@ -0,0 +1,38 @@ +PACKAGE = paramodulation + +INTERFACE_FILES = \ + utils.mli \ + inference.mli\ + equality_indexing.mli + +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) \ + indexing.ml \ + saturation.ml + +include ../Makefile.common + +paramodulation.cmo: $(IMPLEMENTATION_FILES:%.ml=%.cmo) + $(OCAMLC) -pack -o $@ $(IMPLEMENTATION_FILES:%.ml=%.cmo) + +paramodulation.cmx: OCAMLOPTIONS=-package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread +paramodulation.cmx: $(IMPLEMENTATION_FILES:%.ml=%.cmx) + $(OCAMLOPT) -pack -o $@ $(IMPLEMENTATION_FILES:%.ml=%.cmx) + +OCAMLOPTIONS+=-for-pack Paramodulation + +$(ARCHIVE): paramodulation.cmo $(LIBRARIES) + $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ + paramodulation.cmo + +$(ARCHIVE_OPT): paramodulation.cmx $(LIBRARIES_OPT) + $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ + paramodulation.cmx + +PARAMOD_OBJS = $(IMPLEMENTATION_FILES:%.ml=%.cmo) +PARAMOD_OBJS_OPT = $(IMPLEMENTATION_FILES:%.ml=%.cmx) + +LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser +saturate: saturate_main.ml $(PARAMOD_OBJS) $(LIBRARIES) + $(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $(PARAMOD_OBJS) $< +saturate.opt: saturate_main.ml $(PARAMOD_OBJS_OPT) $(LIBRARIES) + $(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $(PARAMOD_OBJS_OPT) $< diff --git a/helm/ocaml/paramodulation/README b/helm/ocaml/paramodulation/README new file mode 100644 index 000000000..98deef5ad --- /dev/null +++ b/helm/ocaml/paramodulation/README @@ -0,0 +1,43 @@ +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 + +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/paramodulation/equality_indexing.ml b/helm/ocaml/paramodulation/equality_indexing.ml new file mode 100644 index 000000000..1dffb6399 --- /dev/null +++ b/helm/ocaml/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/ocaml/paramodulation/equality_indexing.mli b/helm/ocaml/paramodulation/equality_indexing.mli new file mode 100644 index 000000000..d7c3bec5e --- /dev/null +++ b/helm/ocaml/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/ocaml/paramodulation/indexing.ml b/helm/ocaml/paramodulation/indexing.ml new file mode 100644 index 000000000..2d9076ad5 --- /dev/null +++ b/helm/ocaml/paramodulation/indexing.ml @@ -0,0 +1,1021 @@ +(* 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;; + + +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 + 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 order = cmp c' other' in + let names = U.names_of_context context 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 + let names = U.names_of_context context 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 = + 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 _, proof, (eq_ty, left, right, order), metas, args = target 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 = U.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) in + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas + 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 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_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_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 *) + (* tentiamo di ridurre usando CicReduction.normalize *) + let w, p, (ty, left, right, o), m, a = newtarget in + let left' = ProofEngineReduction.simpl context left in + let right' = ProofEngineReduction.simpl context right in + let newleft = + if !Utils.compare_terms left' left = Utils.Lt then left' else left in + let newright = + if !Utils.compare_terms right' right = Utils.Lt then right' else right in +(* if newleft != left || newright != right then ( *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "left: %s, left': %s\nright: %s, right': %s\n" *) +(* (CicPp.ppterm left) (CicPp.ppterm left') (CicPp.ppterm right) *) +(* (CicPp.ppterm right'))) *) +(* ); *) + let w' = Utils.compute_equality_weight ty newleft newright in + let o' = !Utils.compare_terms newleft newright in + newmeta, (w', p, (ty, newleft, newright, o'), m, a) +;; + + +(** + 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), _, _ = 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), [], []) + 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 = + let bo' = apply_subst s (S.subst other bo) in + let t' = + let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in + incr sup_r_counter; + let l, r = + if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in + (name, ty, S.lift 1 eq_ty, l, r) + 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) + and env = (metasenv, context, ugraph) 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 + (!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 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 = + let bo = 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) as subproof) -> +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "replacing %s" *) +(* (Inference.string_of_proof subproof))); *) + 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 + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas 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 proof, metas, term = theorem 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 = + let bo = 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 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/paramodulation/inference.ml b/helm/ocaml/paramodulation/inference.ml new file mode 100644 index 000000000..04cdb0aeb --- /dev/null +++ b/helm/ocaml/paramodulation/inference.ml @@ -0,0 +1,952 @@ +(* 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 + | 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 proof = + let rec do_build_proof proof = + match proof with + | NoProof -> + Printf.fprintf stderr "WARNING: no proof!\n"; + Cic.Implicit None + | 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 print_table t = + String.concat ", " + (List.map + (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t) + 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 = + let f t = + String.concat ", " + (List.map + (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t) + in + if t1 = t2 then + true + else + try + let l, r = meta_convertibility_aux ([], []) t1 t2 in + 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 = + unification metasenv context t1 t2 ugraph + 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 + (index, p)::tl, max newmeta newmeta' + | 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 -> + let suri = UriManager.string_of_uri uri in + 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 + (uri, e)::tl, max newmeta newmeta' + | 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 newmeta ((w, p, (ty, left, right, o), menv, args) as equality) = + 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) 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 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_identity ((metasenv, context, ugraph) as env) = function + | ((_, _, (ty, left, right, _), menv, _) as equality) -> + (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/paramodulation/inference.mli b/helm/ocaml/paramodulation/inference.mli new file mode 100644 index 000000000..30927dc72 --- /dev/null +++ b/helm/ocaml/paramodulation/inference.mli @@ -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://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 + | 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: 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_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/paramodulation/saturate_main.ml b/helm/ocaml/paramodulation/saturate_main.ml new file mode 100644 index 000000000..bec597645 --- /dev/null +++ b/helm/ocaml/paramodulation/saturate_main.ml @@ -0,0 +1,161 @@ +(* 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 _ = + 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:" +in +Helm_registry.load_from !configuration_file; +ignore (CicNotation2.load_notation [] core_notation_script); +ignore (CicNotation2.load_notation [] "../../matita/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 +;; diff --git a/helm/ocaml/paramodulation/saturation.ml b/helm/ocaml/paramodulation/saturation.ml new file mode 100644 index 000000000..eb4a35d6c --- /dev/null +++ b/helm/ocaml/paramodulation/saturation.ml @@ -0,0 +1,2379 @@ +(* 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;; + + +(* 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.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, _), _, _) as equality) = + 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 all = active_list @ pl 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 + 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 all = if pl = [] then active_list else active_list @ pl 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 all = if pl = [] then active_list else active_list @ pl 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 +;; + + +(* 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 + let (_, ns), (_, ps), _ = passive 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 = + let equalities = equalities @ library_equalities in + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "SIMPLYFYING EQUALITIES..."); + let rec simpl 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 hd tl others_simpl + | Some e -> simpl hd tl (e::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> e::others_simpl + ) + in + match equalities with + | [] -> [] + | hd::tl -> + let others = List.map (fun e -> (Positive, e)) tl in + let res = + List.rev (List.map snd (simpl (Positive, hd) others [])) + in + debug_print + (lazy + (Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res)))); + res + 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 = + let equalities = equalities @ library_equalities in + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "SIMPLYFYING EQUALITIES..."); + let rec simpl 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 hd tl others_simpl + | Some e -> simpl hd tl (e::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> e::others_simpl + ) + in + match equalities with + | [] -> [] + | hd::tl -> + let others = List.map (fun e -> (Positive, e)) tl in + let res = + List.rev (List.map snd (simpl (Positive, hd) others [])) + in + debug_print + (lazy + (Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res)))); + res + 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 + debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time)); + newstatus + | _ -> + raise (ProofEngineTypes.Fail (lazy "NO proof found")) +;; + +(* dummy function called within matita to trigger linkage *) +let init () = ();; + + +(* UGLY SIDE EFFECT... *) +if connect_to_auto then ( + AutoTactic.paramodulation_tactic := saturate; + AutoTactic.term_is_equality := Inference.term_is_equality; +);; + + +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 goal = Inference.BasicProof new_meta_goal, [], goal 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 = + 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 + 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 + let t1 = Unix.gettimeofday () in + try + let goal = Inference.BasicProof new_meta_goal, [], goal in + let equalities = + let equalities = equalities @ library_equalities in + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "SIMPLYFYING EQUALITIES..."); + let rec simpl 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 hd tl others_simpl + | Some e -> simpl hd tl (e::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> e::others_simpl + ) + in + match equalities with + | [] -> [] + | hd::tl -> + let others = List.map (fun e -> (Positive, e)) tl in + let res = + List.rev (List.map snd (simpl (Positive, hd) others [])) + in + debug_print + (lazy + (Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res)))); + res + 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 "--------------------------------------------------"; + let start = Unix.gettimeofday () in + 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 finish = Unix.gettimeofday () 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))) +;; diff --git a/helm/ocaml/paramodulation/test_indexing.ml b/helm/ocaml/paramodulation/test_indexing.ml new file mode 100644 index 000000000..ba6b2ebe0 --- /dev/null +++ b/helm/ocaml/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/ocaml/paramodulation/utils.ml b/helm/ocaml/paramodulation/utils.ml new file mode 100644 index 000000000..5eb591c0b --- /dev/null +++ b/helm/ocaml/paramodulation/utils.ml @@ -0,0 +1,596 @@ +(* 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) +;; + +(* (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) +;; + + +type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; + +let string_of_comparison = function + | Lt -> "<" + | Le -> "<=" + | Gt -> ">" + | Ge -> ">=" + | Eq -> "=" + | Incomparable -> "I" + + +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 diffs < (- hdiff) then Lt + else if diffs = (- hdiff) then Le else Incomparable +(* + if hdiff <= 0 then + if m > 0 || hdiff < 0 then Lt + else if diffs >= (- hdiff) then Le else Incomparable + else + if diffs >= (- hdiff) then Le else Incomparable *) + | (0, _, m) -> + if (- hdiff) < diffs then Gt + else if (- hdiff) = diffs then Ge else Incomparable +(* + if hdiff >= 0 then + if m > 0 || hdiff > 0 then Gt + else if (- diffs) >= hdiff then Ge else Incomparable + 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 +;; + + +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 +;; + + +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 guarded_simpl context t = + let t' = ProofEngineReduction.simpl context t in + let simpl_order = !compare_terms t t' in + if simpl_order = Gt then + (* prerr_endline ("reduce: "^(CicPp.ppterm t)^(CicPp.ppterm t')); *) + t' + else t +;; + +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/paramodulation/utils.mli b/helm/ocaml/paramodulation/utils.mli new file mode 100644 index 000000000..d52483ddb --- /dev/null +++ b/helm/ocaml/paramodulation/utils.mli @@ -0,0 +1,82 @@ +(* 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 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: 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/patch_deps.sh b/helm/ocaml/patch_deps.sh new file mode 100755 index 000000000..cd9f09c89 --- /dev/null +++ b/helm/ocaml/patch_deps.sh @@ -0,0 +1,32 @@ +#!/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 snipet $2 ..." + sed -i "/digraph/r $2" $1 +} + +# args: file patch +apply_patch () +{ + if [ -f "$2" ]; then + echo "Applying to $1 patch $2 ..." + patch $1 $2 + fi +} + +cp $1 $2 +apply_patch $2 deps.patch +include_dot_snippet $2 daemons.dot +if [ "$use_clusters" = "yes" ]; then + include_dot_snippet $2 clusters.dot +fi + diff --git a/helm/ocaml/registry/.depend b/helm/ocaml/registry/.depend new file mode 100644 index 000000000..cf4f36b68 --- /dev/null +++ b/helm/ocaml/registry/.depend @@ -0,0 +1,2 @@ +helm_registry.cmo: helm_registry.cmi +helm_registry.cmx: helm_registry.cmi diff --git a/helm/ocaml/registry/.ocamlinit b/helm/ocaml/registry/.ocamlinit new file mode 100644 index 000000000..9aee6008e --- /dev/null +++ b/helm/ocaml/registry/.ocamlinit @@ -0,0 +1,4 @@ +#use "topfind";; +#require "helm-registry";; +open Helm_registry;; +load_from "sample.xml";; diff --git a/helm/ocaml/registry/Makefile b/helm/ocaml/registry/Makefile new file mode 100644 index 000000000..4d3e0a52c --- /dev/null +++ b/helm/ocaml/registry/Makefile @@ -0,0 +1,7 @@ + +PACKAGE = registry +INTERFACE_FILES = helm_registry.mli +IMPLEMENTATION_FILES = helm_registry.ml + +include ../Makefile.common + diff --git a/helm/ocaml/registry/helm_registry.ml b/helm/ocaml/registry/helm_registry.ml new file mode 100644 index 000000000..42316a27f --- /dev/null +++ b/helm/ocaml/registry/helm_registry.ml @@ -0,0 +1,422 @@ +(* 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 -> 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 new file mode 100644 index 000000000..1ef1aa3b7 --- /dev/null +++ b/helm/ocaml/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/ocaml/registry/test.ml b/helm/ocaml/registry/test.ml new file mode 100644 index 000000000..d0b91a28c --- /dev/null +++ b/helm/ocaml/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/ocaml/registry/tests/sample.xml b/helm/ocaml/registry/tests/sample.xml new file mode 100644 index 000000000..b0f91f30b --- /dev/null +++ b/helm/ocaml/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/ocaml/registry/tests/sample_include.xml b/helm/ocaml/registry/tests/sample_include.xml new file mode 100644 index 000000000..8a6851998 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/.depend b/helm/ocaml/tactics/.depend new file mode 100644 index 000000000..95131ecf4 --- /dev/null +++ b/helm/ocaml/tactics/.depend @@ -0,0 +1,128 @@ +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 +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 +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: proofEngineTypes.cmi proofEngineHelpers.cmi \ + primitiveTactics.cmi metadataQuery.cmi autoTactic.cmi +autoTactic.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \ + primitiveTactics.cmx metadataQuery.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 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 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 new file mode 100644 index 000000000..1595fb337 --- /dev/null +++ b/helm/ocaml/tactics/Makefile @@ -0,0 +1,23 @@ +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 \ + 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 + echo "(* GENERATED FILE, DO NOT EDIT *)" > $@ + $(OCAMLC) -i $< >> $@ + +include ../Makefile.common + diff --git a/helm/ocaml/tactics/autoTactic.ml b/helm/ocaml/tactics/autoTactic.ml new file mode 100644 index 000000000..dc5b8324c --- /dev/null +++ b/helm/ocaml/tactics/autoTactic.ml @@ -0,0 +1,348 @@ +(* 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 || (!term_is_equality meta_goal) + in + if paramodulation_ok then ( + debug_print (lazy "USO PARAMODULATION..."); +(* try *) + !paramodulation_tactic 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 new file mode 100644 index 000000000..696c97007 --- /dev/null +++ b/helm/ocaml/tactics/autoTactic.mli @@ -0,0 +1,38 @@ + +(* 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 + +val paramodulation_tactic: + (HMysql.dbd -> ?full:bool -> ?depth:int -> ?width:int -> + ProofEngineTypes.status -> + ProofEngineTypes.proof * ProofEngineTypes.goal list) ref + +val term_is_equality: + (Cic.term -> bool) ref diff --git a/helm/ocaml/tactics/continuationals.ml b/helm/ocaml/tactics/continuationals.ml new file mode 100644 index 000000000..3ed167a71 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/continuationals.mli b/helm/ocaml/tactics/continuationals.mli new file mode 100644 index 000000000..d40202d4b --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/discriminationTactics.ml b/helm/ocaml/tactics/discriminationTactics.ml new file mode 100644 index 000000000..9e5bc7f43 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/discriminationTactics.mli b/helm/ocaml/tactics/discriminationTactics.mli new file mode 100644 index 000000000..f1153256f --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/Makefile b/helm/ocaml/tactics/doc/Makefile new file mode 100644 index 000000000..b7d8fb45c --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/body.tex b/helm/ocaml/tactics/doc/body.tex new file mode 100644 index 000000000..8b7bbc9b0 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/infernce.sty b/helm/ocaml/tactics/doc/infernce.sty new file mode 100644 index 000000000..fc4afeaaf --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/ligature.sty b/helm/ocaml/tactics/doc/ligature.sty new file mode 100644 index 000000000..a914d91d1 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/main.tex b/helm/ocaml/tactics/doc/main.tex new file mode 100644 index 000000000..06952d61c --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/reserved.sty b/helm/ocaml/tactics/doc/reserved.sty new file mode 100644 index 000000000..c0d56b8aa --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/semantic.sty b/helm/ocaml/tactics/doc/semantic.sty new file mode 100644 index 000000000..98257cab8 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/shrthand.sty b/helm/ocaml/tactics/doc/shrthand.sty new file mode 100644 index 000000000..b73af4470 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/doc/tdiagram.sty b/helm/ocaml/tactics/doc/tdiagram.sty new file mode 100644 index 000000000..02202b34a --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/eliminationTactics.ml b/helm/ocaml/tactics/eliminationTactics.ml new file mode 100644 index 000000000..e98bcd3c8 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/eliminationTactics.mli b/helm/ocaml/tactics/eliminationTactics.mli new file mode 100644 index 000000000..cf6589f9a --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/equalityTactics.ml b/helm/ocaml/tactics/equalityTactics.ml new file mode 100644 index 000000000..8304d7bb1 --- /dev/null +++ b/helm/ocaml/tactics/equalityTactics.ml @@ -0,0 +1,363 @@ +(* 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 last_hyp_name_of_status (proof,goal) = + let curi, metasenv, pbo, pty = proof in + let metano,context,gty = CicUtil.lookup_meta goal metasenv in + match context with + (Some (Cic.Name s,_))::_ -> s + | _ -> assert false + 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 new file mode 100644 index 000000000..1d60ae149 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/fourier.ml b/helm/ocaml/tactics/fourier.ml new file mode 100644 index 000000000..d7728c0b3 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/fourier.mli b/helm/ocaml/tactics/fourier.mli new file mode 100644 index 000000000..8b26bc21a --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/fourierR.ml b/helm/ocaml/tactics/fourierR.ml new file mode 100644 index 000000000..5418e1149 --- /dev/null +++ b/helm/ocaml/tactics/fourierR.ml @@ -0,0 +1,1205 @@ +(* 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 + let tmp = (f a) in + false + with + _-> true + ;; + +let rec flin_of_term t = + let fl_of_binop f l = + let a = List.hd l and + b = List.hd(List.tl l) in + f (flin_of_term a) (flin_of_term b) + in + try( + match t with + | Cic.Cast (t1,t2) -> (flin_of_term t1) + | Cic.Appl (t1::next) -> + begin + match t1 with + Cic.Const (u,boh) -> + begin + 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 (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 (PrimitiveTactics.apply_tac ~term:_Rle_not_lt) status)) + ~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 new file mode 100644 index 000000000..e5790ec0f --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/fwdSimplTactic.ml b/helm/ocaml/tactics/fwdSimplTactic.ml new file mode 100644 index 000000000..0bae64f6c --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/fwdSimplTactic.mli b/helm/ocaml/tactics/fwdSimplTactic.mli new file mode 100644 index 000000000..d75b83320 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/hashtbl_equiv.ml b/helm/ocaml/tactics/hashtbl_equiv.ml new file mode 100644 index 000000000..86448268c --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/hashtbl_equiv.mli b/helm/ocaml/tactics/hashtbl_equiv.mli new file mode 100644 index 000000000..d2608b862 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/history.ml b/helm/ocaml/tactics/history.ml new file mode 100644 index 000000000..7559f367e --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/history.mli b/helm/ocaml/tactics/history.mli new file mode 100644 index 000000000..86bad463f --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/introductionTactics.ml b/helm/ocaml/tactics/introductionTactics.ml new file mode 100644 index 000000000..9ed3647c1 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/introductionTactics.mli b/helm/ocaml/tactics/introductionTactics.mli new file mode 100644 index 000000000..c3a12720b --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/inversion.ml b/helm/ocaml/tactics/inversion.ml new file mode 100644 index 000000000..6b563fe6a --- /dev/null +++ b/helm/ocaml/tactics/inversion.ml @@ -0,0 +1,253 @@ +(* 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 (newproof, metasenv') = PEH.subst_meta_in_proof proof metano term [] 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 new file mode 100644 index 000000000..50bdf58f2 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/metadataQuery.ml b/helm/ocaml/tactics/metadataQuery.ml new file mode 100644 index 000000000..b9c053653 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/metadataQuery.mli b/helm/ocaml/tactics/metadataQuery.mli new file mode 100644 index 000000000..b65a23fa9 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/negationTactics.ml b/helm/ocaml/tactics/negationTactics.ml new file mode 100644 index 000000000..7ee79e534 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/negationTactics.mli b/helm/ocaml/tactics/negationTactics.mli new file mode 100644 index 000000000..bfa3e8d5d --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/primitiveTactics.ml b/helm/ocaml/tactics/primitiveTactics.ml new file mode 100644 index 000000000..7a732a572 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/primitiveTactics.mli b/helm/ocaml/tactics/primitiveTactics.mli new file mode 100644 index 000000000..01d200eb7 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineHelpers.ml b/helm/ocaml/tactics/proofEngineHelpers.ml new file mode 100644 index 000000000..cf7df2d58 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineHelpers.mli b/helm/ocaml/tactics/proofEngineHelpers.mli new file mode 100644 index 000000000..a7c0e5b54 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineReduction.ml b/helm/ocaml/tactics/proofEngineReduction.ml new file mode 100644 index 000000000..755a09854 --- /dev/null +++ b/helm/ocaml/tactics/proofEngineReduction.ml @@ -0,0 +1,973 @@ +(* 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 -> + (try + match List.nth context (n-1) with + Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l) + | Some (_,C.Def (bo,_)) -> + try_delta_expansion context l t (S.lift n bo) + | None -> raise RelToHiddenHypothesis + with + Failure _ -> assert false) + | 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,_,_,_) -> + 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 tys = + List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl in + let (_,_,body) = List.nth fl i in + let body' = + let counter = ref (List.length fl) in + List.fold_right + (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) + fl + body + in + let tl' = List.map (reduceaux context []) tl in + reduceaux context tl' body' + | t -> t + in + (match decofix (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 new file mode 100644 index 000000000..67247876a --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineStructuralRules.ml b/helm/ocaml/tactics/proofEngineStructuralRules.ml new file mode 100644 index 000000000..4677a33ac --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineStructuralRules.mli b/helm/ocaml/tactics/proofEngineStructuralRules.mli new file mode 100644 index 000000000..91ebfecfb --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineTypes.ml b/helm/ocaml/tactics/proofEngineTypes.ml new file mode 100644 index 000000000..68ea561f9 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/proofEngineTypes.mli b/helm/ocaml/tactics/proofEngineTypes.mli new file mode 100644 index 000000000..4396ea78f --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/reductionTactics.ml b/helm/ocaml/tactics/reductionTactics.ml new file mode 100644 index 000000000..115faa80b --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/reductionTactics.mli b/helm/ocaml/tactics/reductionTactics.mli new file mode 100644 index 000000000..16e2bc23c --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/ring.ml b/helm/ocaml/tactics/ring.ml new file mode 100644 index 000000000..4c58f1004 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/ring.mli b/helm/ocaml/tactics/ring.mli new file mode 100644 index 000000000..b6eb34b69 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/statefulProofEngine.ml b/helm/ocaml/tactics/statefulProofEngine.ml new file mode 100644 index 000000000..9529c897c --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/statefulProofEngine.mli b/helm/ocaml/tactics/statefulProofEngine.mli new file mode 100644 index 000000000..4198876ca --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/tacticChaser.ml b/helm/ocaml/tactics/tacticChaser.ml new file mode 100644 index 000000000..cb700f776 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/tacticals.ml b/helm/ocaml/tactics/tacticals.ml new file mode 100644 index 000000000..a674fe313 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/tacticals.mli b/helm/ocaml/tactics/tacticals.mli new file mode 100644 index 000000000..88fafc1f8 --- /dev/null +++ b/helm/ocaml/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/ocaml/tactics/tactics.ml b/helm/ocaml/tactics/tactics.ml new file mode 100644 index 000000000..170d6887f --- /dev/null +++ b/helm/ocaml/tactics/tactics.ml @@ -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://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 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 new file mode 100644 index 000000000..25e479b47 --- /dev/null +++ b/helm/ocaml/tactics/tactics.mli @@ -0,0 +1,90 @@ +(* 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 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 new file mode 100644 index 000000000..fc6413eb5 --- /dev/null +++ b/helm/ocaml/tactics/variousTactics.ml @@ -0,0 +1,178 @@ +(* 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 status = (uri,metasenv,pbo,pty),goal 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, 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 ( + (* TASSI: FIXME *) + 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) ; + 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 + PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern) +;; diff --git a/helm/ocaml/tactics/variousTactics.mli b/helm/ocaml/tactics/variousTactics.mli new file mode 100644 index 000000000..35576326e --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/.depend b/helm/ocaml/thread/.depend new file mode 100644 index 000000000..7759190c6 --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/Makefile b/helm/ocaml/thread/Makefile new file mode 100644 index 000000000..24a96b6e9 --- /dev/null +++ b/helm/ocaml/thread/Makefile @@ -0,0 +1,27 @@ + +PACKAGE = thread +INTERFACE_FILES = threadSafe.mli extThread.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +all: thread_fake.cma +opt: thread_fake.cmxa + +include ../Makefile.common + +fake/threadSafe.cmi: fake/threadSafe.mli + cd fake/ \ + && ocamlfind ocamlc -c threadSafe.mli +thread_fake.cma: fake/threadSafe.cmi + cd fake/ \ + && ocamlfind ocamlc -a -o $@ threadSafe.ml \ + && cp $@ ../ +thread_fake.cmxa: fake/threadSafe.cmi + 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 new file mode 100644 index 000000000..d59cccd26 --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/extThread.mli b/helm/ocaml/thread/extThread.mli new file mode 100644 index 000000000..5fb3bd487 --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/fake/threadSafe.ml b/helm/ocaml/thread/fake/threadSafe.ml new file mode 100644 index 000000000..b2c427710 --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/fake/threadSafe.mli b/helm/ocaml/thread/fake/threadSafe.mli new file mode 100644 index 000000000..78166abcc --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/threadSafe.ml b/helm/ocaml/thread/threadSafe.ml new file mode 100644 index 000000000..afe953370 --- /dev/null +++ b/helm/ocaml/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/ocaml/thread/threadSafe.mli b/helm/ocaml/thread/threadSafe.mli new file mode 100644 index 000000000..78166abcc --- /dev/null +++ b/helm/ocaml/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/ocaml/urimanager/.depend b/helm/ocaml/urimanager/.depend new file mode 100644 index 000000000..482148423 --- /dev/null +++ b/helm/ocaml/urimanager/.depend @@ -0,0 +1,2 @@ +uriManager.cmo: uriManager.cmi +uriManager.cmx: uriManager.cmi diff --git a/helm/ocaml/urimanager/Makefile b/helm/ocaml/urimanager/Makefile new file mode 100644 index 000000000..afd7d4442 --- /dev/null +++ b/helm/ocaml/urimanager/Makefile @@ -0,0 +1,9 @@ +PACKAGE = urimanager +PREDICATES = + +INTERFACE_FILES = uriManager.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../Makefile.common diff --git a/helm/ocaml/urimanager/uriManager.ml b/helm/ocaml/urimanager/uriManager.ml new file mode 100644 index 000000000..9ff6a7966 --- /dev/null +++ b/helm/ocaml/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/ocaml/urimanager/uriManager.mli b/helm/ocaml/urimanager/uriManager.mli new file mode 100644 index 000000000..8250cc839 --- /dev/null +++ b/helm/ocaml/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/ocaml/utf8_macros/.depend b/helm/ocaml/utf8_macros/.depend new file mode 100644 index 000000000..f3c6a8bd1 --- /dev/null +++ b/helm/ocaml/utf8_macros/.depend @@ -0,0 +1,2 @@ +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 new file mode 100644 index 000000000..e3afd40f6 --- /dev/null +++ b/helm/ocaml/utf8_macros/Makefile @@ -0,0 +1,36 @@ +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 + $(OCAMLFIND) ocamlc -package $(MAKE_TABLE_PACKAGES) -linkpkg -o $@ $^ + +utf8MacroTable.ml: + ./make_table $@ +utf8MacroTable.cmo: utf8MacroTable.ml + $(OCAMLFIND) ocamlc -c $< + +pa_unicode_macro.cmo: pa_unicode_macro.ml utf8Macro.cmo + $(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 + $(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 + +include ../Makefile.common + diff --git a/helm/ocaml/utf8_macros/README.syntax b/helm/ocaml/utf8_macros/README.syntax new file mode 100644 index 000000000..210ecc095 --- /dev/null +++ b/helm/ocaml/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/ocaml/utf8_macros/data/dictionary-tex.xml b/helm/ocaml/utf8_macros/data/dictionary-tex.xml new file mode 100644 index 000000000..47995454f --- /dev/null +++ b/helm/ocaml/utf8_macros/data/dictionary-tex.xml @@ -0,0 +1,378 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/ocaml/utf8_macros/data/entities-table.xml b/helm/ocaml/utf8_macros/data/entities-table.xml new file mode 100644 index 000000000..c283631b4 --- /dev/null +++ b/helm/ocaml/utf8_macros/data/entities-table.xml @@ -0,0 +1,2079 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/helm/ocaml/utf8_macros/data/extra-entities.xml b/helm/ocaml/utf8_macros/data/extra-entities.xml new file mode 100644 index 000000000..73b12ad5e --- /dev/null +++ b/helm/ocaml/utf8_macros/data/extra-entities.xml @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + + diff --git a/helm/ocaml/utf8_macros/make_table.ml b/helm/ocaml/utf8_macros/make_table.ml new file mode 100644 index 000000000..4722af1e1 --- /dev/null +++ b/helm/ocaml/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/ocaml/utf8_macros/pa_unicode_macro.ml b/helm/ocaml/utf8_macros/pa_unicode_macro.ml new file mode 100644 index 000000000..dda7d4cab --- /dev/null +++ b/helm/ocaml/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/ocaml/utf8_macros/test.ml b/helm/ocaml/utf8_macros/test.ml new file mode 100644 index 000000000..8f98bfd44 --- /dev/null +++ b/helm/ocaml/utf8_macros/test.ml @@ -0,0 +1,3 @@ +(* $Id$ *) + +prerr_endline <:unicode> diff --git a/helm/ocaml/utf8_macros/utf8Macro.ml b/helm/ocaml/utf8_macros/utf8Macro.ml new file mode 100644 index 000000000..e5fca10c4 --- /dev/null +++ b/helm/ocaml/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/ocaml/utf8_macros/utf8Macro.mli b/helm/ocaml/utf8_macros/utf8Macro.mli new file mode 100644 index 000000000..d92f60b37 --- /dev/null +++ b/helm/ocaml/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/ocaml/utf8_macros/utf8MacroTable.ml b/helm/ocaml/utf8_macros/utf8MacroTable.ml new file mode 100644 index 000000000..8b4a02e47 --- /dev/null +++ b/helm/ocaml/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/ocaml/whelp/.depend b/helm/ocaml/whelp/.depend new file mode 100644 index 000000000..39f37dfa9 --- /dev/null +++ b/helm/ocaml/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/ocaml/whelp/Makefile b/helm/ocaml/whelp/Makefile new file mode 100644 index 000000000..f43c77fa9 --- /dev/null +++ b/helm/ocaml/whelp/Makefile @@ -0,0 +1,10 @@ +PACKAGE = whelp + +INTERFACE_FILES = \ + whelp.mli \ + fwdQueries.mli \ + $(NULL) + +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + +include ../Makefile.common diff --git a/helm/ocaml/whelp/fwdQueries.ml b/helm/ocaml/whelp/fwdQueries.ml new file mode 100644 index 000000000..1f4e508fc --- /dev/null +++ b/helm/ocaml/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/ocaml/whelp/fwdQueries.mli b/helm/ocaml/whelp/fwdQueries.mli new file mode 100644 index 000000000..7f580a541 --- /dev/null +++ b/helm/ocaml/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/ocaml/whelp/whelp.ml b/helm/ocaml/whelp/whelp.ml new file mode 100644 index 000000000..5e63bcfc4 --- /dev/null +++ b/helm/ocaml/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/ocaml/whelp/whelp.mli b/helm/ocaml/whelp/whelp.mli new file mode 100644 index 000000000..9ff03ea20 --- /dev/null +++ b/helm/ocaml/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/ocaml/xml/.depend b/helm/ocaml/xml/.depend new file mode 100644 index 000000000..5ef59bdc9 --- /dev/null +++ b/helm/ocaml/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/ocaml/xml/Makefile b/helm/ocaml/xml/Makefile new file mode 100644 index 000000000..6ca7bd944 --- /dev/null +++ b/helm/ocaml/xml/Makefile @@ -0,0 +1,11 @@ +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.common diff --git a/helm/ocaml/xml/test.ml b/helm/ocaml/xml/test.ml new file mode 100644 index 000000000..84c042e28 --- /dev/null +++ b/helm/ocaml/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/ocaml/xml/xml.ml b/helm/ocaml/xml/xml.ml new file mode 100644 index 000000000..f8cc41cbe --- /dev/null +++ b/helm/ocaml/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/ocaml/xml/xml.mli b/helm/ocaml/xml/xml.mli new file mode 100644 index 000000000..4feca7503 --- /dev/null +++ b/helm/ocaml/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/ocaml/xml/xmlPushParser.ml b/helm/ocaml/xml/xmlPushParser.ml new file mode 100644 index 000000000..4f57e1242 --- /dev/null +++ b/helm/ocaml/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/ocaml/xml/xmlPushParser.mli b/helm/ocaml/xml/xmlPushParser.mli new file mode 100644 index 000000000..c13481c91 --- /dev/null +++ b/helm/ocaml/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/ocaml/xmldiff/.depend b/helm/ocaml/xmldiff/.depend new file mode 100644 index 000000000..e2832de33 --- /dev/null +++ b/helm/ocaml/xmldiff/.depend @@ -0,0 +1,2 @@ +xmlDiff.cmo: xmlDiff.cmi +xmlDiff.cmx: xmlDiff.cmi diff --git a/helm/ocaml/xmldiff/Makefile b/helm/ocaml/xmldiff/Makefile new file mode 100644 index 000000000..62492069e --- /dev/null +++ b/helm/ocaml/xmldiff/Makefile @@ -0,0 +1,9 @@ +PACKAGE = xmldiff +PREDICATES = + +INTERFACE_FILES = xmlDiff.mli +IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) +EXTRA_OBJECTS_TO_INSTALL = +EXTRA_OBJECTS_TO_CLEAN = + +include ../Makefile.common diff --git a/helm/ocaml/xmldiff/xmlDiff.ml b/helm/ocaml/xmldiff/xmlDiff.ml new file mode 100644 index 000000000..6f68438e9 --- /dev/null +++ b/helm/ocaml/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/ocaml/xmldiff/xmlDiff.mli b/helm/ocaml/xmldiff/xmlDiff.mli new file mode 100644 index 000000000..cf084af94 --- /dev/null +++ b/helm/ocaml/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