test branch

diff --git a/helm/matita/.depend b/helm/matita/.depend
new file mode 100644 (file)
index 0000000..06c32e0
--- /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 (file)
index 0000000..1585f71
--- /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 (file)
index 0000000..a2da427
--- /dev/null
+++ b/helm/matita/AUTHORS
@@ -0,0 +1,5 @@
+Andrea Asperti <asperti@cs.unibo.it>
+Luca Padovani <lpadovan@cs.unibo.it>
+Enrico Tassi <tassi@cs.unibo.it>
+Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>
+Stefano Zacchiroli <zacchiro@cs.unibo.it>

diff --git a/helm/matita/LICENSE b/helm/matita/LICENSE
new file mode 100644 (file)
index 0000000..7665cd2
--- /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 (file)
index 0000000..0614bda
--- /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 (file)
index 0000000..83e5f3c
--- /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 <asperti@cs.unibo.it>                  *)
+(*                                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 (file)
index 0000000..8e023ae
--- /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 <asperti@cs.unibo.it>                  *)
+(*                                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 (file)
index 0000000..debafe0
--- /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 (file)
index 0000000..949f8c5
--- /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 (file)
index 0000000..d3125ef
--- /dev/null
+++ b/helm/matita/closed.xml
@@ -0,0 +1,17 @@
+<?xml version="1.0"?>
+<b:box xmlns:m="http://www.w3.org/1998/Math/MathML" xmlns:b="http://helm.cs.unibo.it/2003/BoxML">
+  <b:h>
+    <b:space width="2em"/>
+    <b:v>
+      <b:space height="2ex"/>
+      <b:v>
+        <b:decor style="box">
+         <b:space width="1ex" height="1ex"/>
+       </b:decor>
+       <b:space height="1ex"/>
+       <b:text>This goal has already been closed.</b:text>
+       <b:text>Use the "skip" command to throw it away.</b:text>
+      </b:v>
+    </b:v>
+  </b:h>
+</b:box>

diff --git a/helm/matita/configure.ac b/helm/matita/configure.ac
new file mode 100644 (file)
index 0000000..1075d60
--- /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 (file)
index 0000000..5b2b2fa
--- /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 (file)
index 0000000..5726188
--- /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 (file)
index 0000000..cf7848a
--- /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 (file)
index 0000000..390c067
--- /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 (file)
index 0000000..489b2c1
--- /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 (file)
index 0000000..17a53f6
--- /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 (file)
index 0000000..cfcb572
--- /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 (file)
index 0000000..a688ec6
--- /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 (file)
index 0000000..c840fbd
--- /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 (file)
index 0000000..6c00407
--- /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 (file)
index 0000000..ed0afab
--- /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 (file)
index 0000000..68cbd01
--- /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 (file)
index 0000000..9a94919
--- /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 (file)
index 0000000..5d87204
--- /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 (file)
index 0000000..c30e514
--- /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 (file)
index 0000000..3590348
--- /dev/null
+++ b/helm/matita/dictionary-matita.xml
@@ -0,0 +1,15 @@
+<?xml version="1.0"?>
+<dictionary>
+ <operator name="(" form="prefix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="(" form="infix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name=")" form="postfix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name=")" form="infix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="[" form="prefix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="[" form="infix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="]" form="postfix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="]" form="infix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="{" form="prefix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="{" form="infix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="}" form="postfix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+ <operator name="}" form="infix" fence="true" stretchy="false" lspace="0em" rspace="0em"/>
+</dictionary>

diff --git a/helm/matita/dist/Makefile b/helm/matita/dist/Makefile
new file mode 100644 (file)
index 0000000..669137b
--- /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 (executable)
index 0000000..1ae28d3
--- /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 (file)
index 0000000..5a02bb3
--- /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 (file)
index 0000000..8b1d576
--- /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 (file)
index 0000000..05c21d4
--- /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 (file)
index 0000000..0a33ae6
--- /dev/null
+++ b/helm/matita/gtkmathview.matita.conf.xml.in
@@ -0,0 +1,15 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<math-engine-configuration>
+  <section name="dictionary">
+    <key name="path">@RT_BASE_DIR@/dictionary-matita.xml</key>
+  </section>
+  <section name="gtk-backend">
+    <section name="pango-default-shaper">
+      <section name="variants">
+        <section name="italic">
+          <key name="style">normal</key>
+        </section>
+      </section>
+    </section>
+  </section>
+</math-engine-configuration>

diff --git a/helm/matita/icons/matita-bulb-high.png b/helm/matita/icons/matita-bulb-high.png
new file mode 100644 (file)
index 0000000..03b6e7f
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 (file)
index 0000000..f97302e
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 (file)
index 0000000..d3d449f
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 (file)
index 0000000..ec0cc08
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 (file)
index 0000000..fe89a30
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 (file)
index 0000000..389152e
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 (file)
index 0000000..342bcb4
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 (file)
index 0000000..335688a
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 (file)
index 0000000..cfb017b
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 (file)
index 0000000..4c2be73
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 (file)
index 0000000..5597d51
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 (file)
index 0000000..c1da66f
--- /dev/null
+++ b/helm/matita/icons/whelp.svg
@@ -0,0 +1,221 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+<svg
+   xmlns:xml="http://www.w3.org/XML/1998/namespace"
+   xmlns:dc="http://purl.org/dc/elements/1.1/"
+   xmlns:cc="http://web.resource.org/cc/"
+   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+   xmlns:svg="http://www.w3.org/2000/svg"
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:sodipodi="http://inkscape.sourceforge.net/DTD/sodipodi-0.dtd"
+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+   inkscape:export-ydpi="2.8499999"
+   inkscape:export-xdpi="2.8499999"
+   inkscape:export-filename="/home/tassi/helm/matita/icons/whelp.png"
+   sodipodi:docname="whelp.svg"
+   sodipodi:docbase="/home/tassi/helm/matita/icons"
+   inkscape:version="0.41"
+   sodipodi:version="0.32"
+   id="svg2"
+   height="297mm"
+   width="210mm">
+  <defs
+     id="defs3" />
+  <sodipodi:namedview
+     inkscape:window-y="47"
+     inkscape:window-x="538"
+     inkscape:window-height="743"
+     inkscape:window-width="697"
+     inkscape:current-layer="layer1"
+     inkscape:document-units="px"
+     inkscape:cy="526.18109"
+     inkscape:cx="-47.832055"
+     inkscape:zoom="0.53878789"
+     inkscape:pageshadow="2"
+     inkscape:pageopacity="0.0"
+     borderopacity="1.0"
+     bordercolor="#666666"
+     pagecolor="#ffffff"
+     id="base" />
+  <metadata
+     id="metadata4">
+    <rdf:RDF
+       id="RDF5">
+      <cc:Work
+         id="Work6"
+         rdf:about="">
+        <dc:format
+           id="format7">image/svg+xml</dc:format>
+        <dc:type
+           rdf:resource="http://purl.org/dc/dcmitype/StillImage"
+           id="type9" />
+      </cc:Work>
+    </rdf:RDF>
+  </metadata>
+  <g
+     id="layer1"
+     inkscape:groupmode="layer"
+     inkscape:label="Layer 1">
+    <g
+       transform="translate(7.424147,-25.98425)"
+       id="g2113">
+      <path
+         transform="matrix(3.092445,0.000000,0.000000,3.244102,-1367.216,-1102.351)"
+         d="M 277.14285 465.21933 A 21.428572 18.571428 0 1 1  234.28571,465.21933 A 21.428572 18.571428 0 1 1  277.14285 465.21933 z"
+         sodipodi:ry="18.571428"
+         sodipodi:rx="21.428572"
+         sodipodi:cy="465.21933"
+         sodipodi:cx="255.71428"
+         id="path1310"
+         style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.31571975;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4.0000000;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <path
+         transform="matrix(3.577041,0.000000,0.000000,3.764523,-1365.700,-1442.358)"
+         d="M 277.14285 465.21933 A 21.428572 18.571428 0 1 1  234.28571,465.21933 A 21.428572 18.571428 0 1 1  277.14285 465.21933 z"
+         sodipodi:ry="18.571428"
+         sodipodi:rx="21.428572"
+         sodipodi:cy="465.21933"
+         sodipodi:cx="255.71428"
+         id="path1316"
+         style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.27251038;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4.0000000;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <path
+         transform="matrix(3.536915,0.000000,0.000000,3.972675,-1343.944,-1485.563)"
+         d="M 322.85714 442.36218 A 22.857143 18.571428 0 1 1  277.14286,442.36218 A 22.857143 18.571428 0 1 1  322.85714 442.36218 z"
+         sodipodi:ry="18.571428"
+         sodipodi:rx="22.857143"
+         sodipodi:cy="442.36218"
+         sodipodi:cx="300.00000"
+         id="path1322"
+         style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.26677564;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4.0000000;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <path
+         transform="matrix(3.750966,0.000000,0.000000,3.972675,-1450.760,-1408.096)"
+         d="M 382.85716 436.64789 A 24.285715 21.428572 0 1 1  334.28573,436.64789 A 24.285715 21.428572 0 1 1  382.85716 436.64789 z"
+         sodipodi:ry="21.428572"
+         sodipodi:rx="24.285715"
+         sodipodi:cy="436.64789"
+         sodipodi:cx="358.57144"
+         id="path1328"
+         style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.25905198;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4.0000000;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <path
+         transform="matrix(3.536915,0.000000,0.000000,3.972675,-1478.347,-1461.727)"
+         d="M 394.28573 513.79077 A 65.714287 52.857143 0 1 1  262.85715,513.79077 A 65.714287 52.857143 0 1 1  394.28573 513.79077 z"
+         sodipodi:ry="52.857143"
+         sodipodi:rx="65.714287"
+         sodipodi:cy="513.79077"
+         sodipodi:cx="328.57144"
+         id="path1334"
+         style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.26677564;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4.0000000;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+    </g>
+    <g
+       id="g3923"
+       transform="matrix(3.536915,0.000000,0.000000,3.972675,-801.3348,-1982.086)"
+       inkscape:export-filename="/projects/helm/daemons/searchEngine/html/whelp.png"
+       inkscape:export-xdpi="100.84000"
+       inkscape:export-ydpi="100.84000">
+      <path
+         transform="matrix(0.874334,0.000000,0.000000,0.816604,44.53485,211.7504)"
+         d="M 277.14285 465.21933 A 21.428572 18.571428 0 1 1  234.28571,465.21933 A 21.428572 18.571428 0 1 1  277.14285 465.21933 z"
+         sodipodi:ry="18.571428"
+         sodipodi:rx="21.428572"
+         sodipodi:cy="465.21933"
+         sodipodi:cx="255.71428"
+         id="path2998"
+         style="fill:#780000;fill-opacity:0.48627451;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <text
+         id="text3000"
+         y="600.53583"
+         x="257.61462"
+         style="font-size:36.000000;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:0.78431374;stroke:none;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Domestic Manners;text-anchor:start;writing-mode:lr-tb"
+         xml:space="preserve"><tspan
+           y="600.53583"
+           x="257.61462"
+           id="tspan3002"
+           sodipodi:role="line">h</tspan></text>
+      <path
+         transform="matrix(1.011345,0.000000,0.000000,0.947604,44.96344,126.1641)"
+         d="M 277.14285 465.21933 A 21.428572 18.571428 0 1 1  234.28571,465.21933 A 21.428572 18.571428 0 1 1  277.14285 465.21933 z"
+         sodipodi:ry="18.571428"
+         sodipodi:rx="21.428572"
+         sodipodi:cy="465.21933"
+         sodipodi:cx="255.71428"
+         id="path3004"
+         style="fill:#780000;fill-opacity:0.48627451;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <text
+         id="text3006"
+         y="573.53583"
+         x="292.11462"
+         style="font-size:36.000000;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:0.78431374;stroke:none;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Domestic Manners;text-anchor:start;writing-mode:lr-tb"
+         xml:space="preserve"><tspan
+           y="573.53583"
+           x="292.11462"
+           id="tspan3008"
+           sodipodi:role="line">e</tspan></text>
+      <path
+         transform="translate(51.11460,115.2886)"
+         d="M 322.85714 442.36218 A 22.857143 18.571428 0 1 1  277.14286,442.36218 A 22.857143 18.571428 0 1 1  322.85714 442.36218 z"
+         sodipodi:ry="18.571428"
+         sodipodi:rx="22.857143"
+         sodipodi:cy="442.36218"
+         sodipodi:cx="300.00000"
+         id="path3010"
+         style="fill:#780000;fill-opacity:0.48627451;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <text
+         id="text3012"
+         y="570.53583"
+         x="345.11462"
+         style="font-size:36.000000;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:0.78431374;stroke:none;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Domestic Manners;text-anchor:start;writing-mode:lr-tb"
+         xml:space="preserve"><tspan
+           y="570.53583"
+           x="345.11462"
+           id="tspan3014"
+           sodipodi:role="line">l</tspan></text>
+      <path
+         transform="matrix(1.060519,0.000000,0.000000,1.000000,20.91431,134.7886)"
+         d="M 382.85716 436.64789 A 24.285715 21.428572 0 1 1  334.28573,436.64789 A 24.285715 21.428572 0 1 1  382.85716 436.64789 z"
+         sodipodi:ry="21.428572"
+         sodipodi:rx="24.285715"
+         sodipodi:cy="436.64789"
+         sodipodi:cx="358.57144"
+         id="path3016"
+         style="fill:#780000;fill-opacity:0.48627451;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <text
+         id="text3018"
+         y="575.03583"
+         x="392.11462"
+         style="font-size:36.000000;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:0.78431374;stroke:none;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Domestic Manners;text-anchor:start;writing-mode:lr-tb"
+         xml:space="preserve"><tspan
+           y="575.03583"
+           x="392.11462"
+           id="tspan3020"
+           sodipodi:role="line">p</tspan></text>
+      <path
+         transform="translate(13.11460,121.2886)"
+         d="M 394.28573 513.79077 A 65.714287 52.857143 0 1 1  262.85715,513.79077 A 65.714287 52.857143 0 1 1  394.28573 513.79077 z"
+         sodipodi:ry="52.857143"
+         sodipodi:rx="65.714287"
+         sodipodi:cy="513.79077"
+         sodipodi:cx="328.57144"
+         id="path3024"
+         style="fill:#000050;fill-opacity:0.31372550;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000"
+         sodipodi:type="arc" />
+      <text
+         id="text3026"
+         y="655.03577"
+         x="317.61459"
+         style="font-size:64.000000;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:0.78431374;stroke:none;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Domestic Manners;text-anchor:start;writing-mode:lr-tb"
+         xml:space="preserve"><tspan
+           y="655.03577"
+           x="317.61459"
+           id="tspan3028"
+           sodipodi:role="line">W</tspan></text>
+    </g>
+  </g>
+</svg>

diff --git a/helm/matita/library/Makefile b/helm/matita/library/Makefile
new file mode 100644 (file)
index 0000000..fd278eb
--- /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 (file)
index 0000000..3401549
--- /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 (file)
index 0000000..4a50259
--- /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<n1
+      | EQ \Rightarrow n=n1
+      | GT \Rightarrow n1<n] \to 
+      match (nat_compare n n1) with
+      [ LT \Rightarrow (S n) \leq n1
+      | EQ \Rightarrow pos n = pos n1
+      | GT \Rightarrow (S n1) \leq n]). 
+        apply Hcut.apply nat_compare_to_Prop. 
+        elim (nat_compare n n1).
+          simplify.exact H.
+          simplify.apply eq_f.exact H.
+          simplify.exact H.
+    simplify.exact I.    
+  elim y. 
+    simplify.exact I.
+    simplify.exact I.
+    simplify. 
+      cut (match (nat_compare n1 n) with
+      [ LT \Rightarrow n1<n
+      | EQ \Rightarrow n1=n
+      | GT \Rightarrow n<n1] \to 
+      match (nat_compare n1 n) with
+      [ LT \Rightarrow (S n1) \leq n
+      | EQ \Rightarrow neg n = neg n1
+      | GT \Rightarrow (S n) \leq n1]). 
+        apply Hcut. apply nat_compare_to_Prop. 
+        elim (nat_compare n1 n).
+          simplify.exact H.
+          simplify.apply eq_f.apply sym_eq.exact H.
+          simplify.exact H.
+qed.

diff --git a/helm/matita/library/Z/orders.ma b/helm/matita/library/Z/orders.ma
new file mode 100644 (file)
index 0000000..c39f693
--- /dev/null
+++ b/helm/matita/library/Z/orders.ma
@@ -0,0 +1,130 @@
+(**************************************************************************)
+(*       ___                                                               *)
+(*      ||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/orders".
+
+include "Z/z.ma".
+include "nat/orders.ma".
+
+definition Zle : Z \to Z \to Prop \def
+\lambda x,y:Z.
+  match x with
+  [ OZ \Rightarrow 
+    match y with 
+    [ OZ \Rightarrow True
+    | (pos m) \Rightarrow True
+    | (neg m) \Rightarrow False ]
+  | (pos n) \Rightarrow 
+    match y with 
+    [ OZ \Rightarrow False
+    | (pos m) \Rightarrow n \leq m
+    | (neg m) \Rightarrow False ]
+  | (neg n) \Rightarrow 
+    match y with 
+    [ OZ \Rightarrow True
+    | (pos m) \Rightarrow True
+    | (neg m) \Rightarrow m \leq n ]].
+
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "integer 'less or equal to'" 'leq x y = (cic:/matita/Z/orders/Zle.con x y).
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "integer 'neither less nor equal to'" 'nleq x y =
+  (cic:/matita/logic/connectives/Not.con (cic:/matita/Z/orders/Zle.con x y)).
+
+definition Zlt : Z \to Z \to Prop \def
+\lambda x,y:Z.
+  match x with
+  [ OZ \Rightarrow 
+    match y with 
+    [ OZ \Rightarrow False
+    | (pos m) \Rightarrow True
+    | (neg m) \Rightarrow False ]
+  | (pos n) \Rightarrow 
+    match y with 
+    [ OZ \Rightarrow False
+    | (pos m) \Rightarrow n<m
+    | (neg m) \Rightarrow False ]
+  | (neg n) \Rightarrow 
+    match y with 
+    [ OZ \Rightarrow True
+    | (pos m) \Rightarrow True
+    | (neg m) \Rightarrow m<n ]].
+    
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "integer 'less than'" 'lt x y = (cic:/matita/Z/orders/Zlt.con x y).
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "integer 'not less than'" 'nless x y =
+  (cic:/matita/logic/connectives/Not.con (cic:/matita/Z/orders/Zlt.con x y)).
+
+theorem irreflexive_Zlt: irreflexive Z Zlt.
+change with (\forall x:Z. x < x \to False).
+intro.elim x.exact H.
+cut (neg n < neg n \to False).
+apply Hcut.apply H.simplify.unfold lt.apply not_le_Sn_n.
+cut (pos n < pos n \to False).
+apply Hcut.apply H.simplify.unfold lt.apply not_le_Sn_n.
+qed.
+
+theorem irrefl_Zlt: irreflexive Z Zlt
+\def irreflexive_Zlt.
+
+theorem Zlt_neg_neg_to_lt: 
+\forall n,m:nat. neg n < neg m \to m < n.
+intros.apply H.
+qed.
+
+theorem lt_to_Zlt_neg_neg: \forall n,m:nat.m < n \to neg n < neg m. 
+intros.
+simplify.apply H.
+qed.
+
+theorem Zlt_pos_pos_to_lt: 
+\forall n,m:nat. pos n < pos m \to n < m.
+intros.apply H.
+qed.
+
+theorem lt_to_Zlt_pos_pos: \forall n,m:nat.n < m \to pos n < pos m. 
+intros.
+simplify.apply H.
+qed.
+
+theorem Zlt_to_Zle: \forall x,y:Z. x < y \to Zsucc x \leq y.
+intros 2.
+elim x.
+(* goal: x=OZ *)
+  cut (OZ < y \to Zsucc OZ \leq y).
+    apply Hcut. assumption.
+    simplify.elim y. 
+      simplify.exact H1.
+      simplify.apply le_O_n.
+      simplify.exact H1.
+(* goal: x=pos *)      
+  exact H.
+(* goal: x=neg *)      
+  cut (neg n < y \to Zsucc (neg n) \leq y).
+    apply Hcut. assumption.
+    elim n.
+      cut (neg O < y \to Zsucc (neg O) \leq y).
+        apply Hcut. assumption.
+        simplify.elim y.
+          simplify.exact I.
+          simplify.exact I.
+          simplify.apply (not_le_Sn_O n1 H2).
+      cut (neg (S n1) < y \to (Zsucc (neg (S n1))) \leq y).
+        apply Hcut. assumption.simplify.
+        elim y.
+          simplify.exact I.
+          simplify.exact I.
+          simplify.apply (le_S_S_to_le n2 n1 H3).
+qed.

diff --git a/helm/matita/library/Z/plus.ma b/helm/matita/library/Z/plus.ma
new file mode 100644 (file)
index 0000000..976f6cf
--- /dev/null
+++ b/helm/matita/library/Z/plus.ma
@@ -0,0 +1,301 @@
+(**************************************************************************)
+(*       ___                                                               *)
+(*      ||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/plus".
+
+include "Z/z.ma".
+include "nat/minus.ma".
+
+definition Zplus :Z \to Z \to Z \def
+\lambda x,y.
+  match x with
+    [ OZ \Rightarrow y
+    | (pos m) \Rightarrow
+        match y with
+         [ OZ \Rightarrow x
+         | (pos n) \Rightarrow (pos (pred ((S m)+(S n))))
+         | (neg n) \Rightarrow 
+              match nat_compare m n with
+                [ LT \Rightarrow (neg (pred (n-m)))
+                | EQ \Rightarrow OZ
+                | GT \Rightarrow (pos (pred (m-n)))] ]
+    | (neg m) \Rightarrow
+        match y with
+         [ OZ \Rightarrow x
+         | (pos n) \Rightarrow 
+              match nat_compare m n with
+                [ LT \Rightarrow (pos (pred (n-m)))
+                | EQ \Rightarrow OZ
+                | GT \Rightarrow (neg (pred (m-n)))]     
+         | (neg n) \Rightarrow (neg (pred ((S m)+(S n))))] ].
+
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "integer plus" 'plus x y = (cic:/matita/Z/plus/Zplus.con x y).
+         
+theorem Zplus_z_OZ:  \forall z:Z. z+OZ = z.
+intro.elim z.
+simplify.reflexivity.
+simplify.reflexivity.
+simplify.reflexivity.
+qed.
+
+(* theorem symmetric_Zplus: symmetric Z Zplus. *)
+
+theorem sym_Zplus : \forall x,y:Z. x+y = y+x.
+intros.elim x.rewrite > 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 (file)
index 0000000..e5e1cdb
--- /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 (file)
index 0000000..ea50a2c
--- /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 (file)
index 0000000..3292e67
--- /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 (file)
index 0000000..c4fd119
--- /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 (file)
index 0000000..2ac1cb3
--- /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 (file)
index 0000000..a1b54c8
--- /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 (file)
index 0000000..c2b351d
--- /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 (file)
index 0000000..029b229
--- /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 (file)
index 0000000..ea1f593
--- /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 (file)
index 0000000..ffa2c8e
--- /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 (file)
index 0000000..939cece
--- /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 (file)
index 0000000..4cbea35
--- /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 (file)
index 0000000..b87dc6c
--- /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 (file)
index 0000000..30cc744
--- /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 (file)
index 0000000..2647315
--- /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 (file)
index 0000000..af744cf
--- /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<p \to n \mod p = (n \mod p) \mod p.
+intros.
+rewrite > (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<p \to O<m \to n \mod p = (n \mod (m*p)) \mod p.
+intros.
+apply (div_mod_spec_to_eq2 n p (n/p) (n \mod p) 
+(n/(m*p)*m + (n \mod (m*p)/p))).
+apply div_mod_spec_div_mod.assumption.
+constructor 1.
+apply lt_mod_m_m.assumption.
+rewrite > 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 (file)
index 0000000..20913fa
--- /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 (file)
index 0000000..e9831f8
--- /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 (file)
index 0000000..11d84f7
--- /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 (file)
index 0000000..14217bb
--- /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 (file)
index 0000000..6a30943
--- /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<r).
+rewrite > 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 (file)
index 0000000..cc18a8b
--- /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 (file)
index 0000000..65f61b5
--- /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 (file)
index 0000000..a761830
--- /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 (file)
index 0000000..b8339f3
--- /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<q.
+intro.elim n.
+rewrite > 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<q.
+intros.apply (lt_plus_to_lt_l n). 
+rewrite > 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<q \to p*(S n) < q*(S n)
+\def monotonic_lt_times_l.
+
+theorem lt_times:\forall n,m,p,q:nat. n<m \to p<q \to n*p < m*q.
+intro.
+elim n.
+apply (lt_O_n_elim m H).
+intro.
+cut (lt O q).
+apply (lt_O_n_elim q Hcut).
+intro.change with (O < (S m1)*(S m2)).
+apply lt_O_times_S_S.
+apply (ltn_to_ltO p q H1).
+apply (trans_lt ? ((S n1)*q)).
+apply lt_times_r.assumption.
+cut (lt O q).
+apply (lt_O_n_elim q Hcut).
+intro.
+apply lt_times_l.
+assumption.
+apply (ltn_to_ltO p q H2).
+qed.
+
+theorem lt_times_to_lt_l: 
+\forall n,p,q:nat. p*(S n) < q*(S n) \to p < q.
+intros.
+cut (p < q \lor p \nlt q).
+elim Hcut.
+assumption.
+absurd (p * (S n) < q * (S n)).
+assumption.
+apply le_to_not_lt.
+apply le_times_l.
+apply not_lt_to_le.
+assumption.
+exact (decidable_lt p q).
+qed.
+
+theorem lt_times_to_lt_r: 
+\forall n,p,q:nat. (S n)*p < (S n)*q \to lt p q.
+intros.
+apply (lt_times_to_lt_l n).
+rewrite < sym_times.
+rewrite < (sym_times (S n)).
+assumption.
+qed.
+
+theorem nat_compare_times_l : \forall n,p,q:nat. 
+nat_compare p q = nat_compare ((S n) * p) ((S n) * q).
+intros.apply nat_compare_elim.intro.
+apply nat_compare_elim.
+intro.reflexivity.
+intro.absurd (p=q).
+apply (inj_times_r n).assumption.
+apply lt_to_not_eq. assumption.
+intro.absurd (q<p).
+apply (lt_times_to_lt_r n).assumption.
+apply le_to_not_lt.apply lt_to_le.assumption.
+intro.rewrite < H.rewrite > nat_compare_n_n.reflexivity.
+intro.apply nat_compare_elim.intro.
+absurd (p<q).
+apply (lt_times_to_lt_r n).assumption.
+apply le_to_not_lt.apply lt_to_le.assumption.
+intro.absurd (q=p).
+symmetry.
+apply (inj_times_r n).assumption.
+apply lt_to_not_eq.assumption.
+intro.reflexivity.
+qed.
+
+(* div *) 
+
+theorem eq_mod_O_to_lt_O_div: \forall n,m:nat. O < m \to O < n\to n \mod m = O \to O < n / m. 
+intros 4.apply (lt_O_n_elim m H).intros.
+apply (lt_times_to_lt_r m1).
+rewrite < times_n_O.
+rewrite > (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 (file)
index 0000000..0abed5a
--- /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 (file)
index 0000000..710418d
--- /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 (file)
index 0000000..a75032d
--- /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 (file)
index 0000000..5330f52
--- /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 (file)
index 0000000..24874c0
--- /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 = <q,r> 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 (file)
index 0000000..6ec0c99
--- /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<n.
+
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "natural 'greater than'" 'gt x y = (cic:/matita/nat/orders/gt.con x y).
+(*CSC: the URI must disappear: there is a bug now *)
+interpretation "natural 'not greater than'" 'ngtr x y =
+  (cic:/matita/logic/connectives/Not.con (cic:/matita/nat/orders/gt.con x y)).
+
+theorem transitive_le : transitive nat le.
+unfold transitive.intros.elim H1.
+assumption.
+apply le_S.assumption.
+qed.
+
+theorem trans_le: \forall n,m,p:nat. n \leq m \to m \leq p \to n \leq p
+\def transitive_le.
+
+theorem transitive_lt: transitive nat lt.
+unfold transitive.unfold lt.intros.elim H1.
+apply le_S. assumption.
+apply le_S.assumption.
+qed.
+
+theorem trans_lt: \forall n,m,p:nat. lt n m \to lt m p \to lt n p
+\def transitive_lt.
+
+theorem le_S_S: \forall n,m:nat. n \leq m \to S n \leq S m.
+intros.elim H.
+apply le_n.
+apply le_S.assumption.
+qed.
+
+theorem le_O_n : \forall n:nat. O \leq n.
+intros.elim n.
+apply le_n.apply 
+le_S. assumption.
+qed.
+
+theorem le_n_Sn : \forall n:nat. n \leq S n.
+intros. apply le_S.apply le_n.
+qed.
+
+theorem le_pred_n : \forall n:nat. pred n \leq n.
+intros.elim n.
+simplify.apply le_n.
+simplify.apply le_n_Sn.
+qed.
+
+theorem le_S_S_to_le : \forall n,m:nat. S n \leq S m \to n \leq m.
+intros.change with (pred (S n) \leq pred (S m)).
+elim H.apply le_n.apply (trans_le ? (pred n1)).assumption.
+apply le_pred_n.
+qed.
+
+theorem leS_to_not_zero : \forall n,m:nat. S n \leq m \to not_zero m.
+intros.elim H.exact I.exact I.
+qed.
+
+(* not le *)
+theorem not_le_Sn_O: \forall n:nat. S n \nleq O.
+intros.unfold Not.simplify.intros.apply (leS_to_not_zero ? ? H).
+qed.
+
+theorem not_le_Sn_n: \forall n:nat. S n \nleq n.
+intros.elim n.apply not_le_Sn_O.unfold Not.simplify.intros.cut (S n1 \leq n1).
+apply H.assumption.
+apply le_S_S_to_le.assumption.
+qed.
+
+(* le to lt or eq *)
+theorem le_to_or_lt_eq : \forall n,m:nat. 
+n \leq m \to n < m \lor n = m.
+intros.elim H.
+right.reflexivity.
+left.unfold lt.apply le_S_S.assumption.
+qed.
+
+(* not eq *)
+theorem lt_to_not_eq : \forall n,m:nat. n<m \to n \neq m.
+unfold Not.intros.cut ((le (S n) m) \to False).
+apply Hcut.assumption.rewrite < H1.
+apply not_le_Sn_n.
+qed.
+
+(* le vs. lt *)
+theorem lt_to_le : \forall n,m:nat. n<m \to n \leq m.
+simplify.intros.unfold lt in H.elim H.
+apply le_S. apply le_n.
+apply le_S. assumption.
+qed.
+
+theorem lt_S_to_le : \forall n,m:nat. n < S m \to n \leq m.
+simplify.intros.
+apply le_S_S_to_le.assumption.
+qed.
+
+theorem not_le_to_lt: \forall n,m:nat. n \nleq m \to m<n.
+intros 2.
+apply (nat_elim2 (\lambda n,m.n \nleq m \to m<n)).
+intros.apply (absurd (O \leq n1)).apply le_O_n.assumption.
+unfold Not.unfold lt.intros.apply le_S_S.apply le_O_n.
+unfold Not.unfold lt.intros.apply le_S_S.apply H.intros.apply H1.apply le_S_S.
+assumption.
+qed.
+
+theorem lt_to_not_le: \forall n,m:nat. n<m \to m \nleq n.
+unfold Not.unfold lt.intros 3.elim H.
+apply (not_le_Sn_n n H1).
+apply H2.apply lt_to_le. apply H3.
+qed.
+
+theorem not_lt_to_le: \forall n,m:nat. Not (lt n m) \to le m n.
+simplify.intros.
+apply lt_S_to_le.
+apply not_le_to_lt.exact H.
+qed.
+
+theorem le_to_not_lt: \forall n,m:nat. le n m \to Not (lt m n).
+intros.
+change with (Not (le (S m) n)).
+apply lt_to_not_le.unfold lt.
+apply le_S_S.assumption.
+qed.
+
+(* le elimination *)
+theorem le_n_O_to_eq : \forall n:nat. n \leq O \to O=n.
+intro.elim n.reflexivity.
+apply False_ind.
+apply not_le_Sn_O.
+goal 17. apply H1.
+qed.
+
+theorem le_n_O_elim: \forall n:nat.n \leq O \to \forall P: nat \to Prop.
+P O \to P n.
+intro.elim n.
+assumption.
+apply False_ind.
+apply  (not_le_Sn_O ? H1).
+qed.
+
+theorem le_n_Sm_elim : \forall n,m:nat.n \leq S m \to 
+\forall P:Prop. (S n \leq S m \to P) \to (n=S m \to P) \to P.
+intros 4.elim H.
+apply H2.reflexivity.
+apply H3. apply le_S_S. assumption.
+qed.
+
+(* lt and le trans *)
+theorem lt_to_le_to_lt: \forall n,m,p:nat. lt n m \to le m p \to lt n p.
+intros.elim H1.
+assumption.unfold lt.apply le_S.assumption.
+qed.
+
+theorem le_to_lt_to_lt: \forall n,m,p:nat. le n m \to lt m p \to lt n p.
+intros 4.elim H.
+assumption.apply H2.unfold lt.
+apply lt_to_le.assumption.
+qed.
+
+theorem ltn_to_ltO: \forall n,m:nat. lt n m \to lt O m.
+intros.apply (le_to_lt_to_lt O n).
+apply le_O_n.assumption.
+qed.
+
+theorem lt_O_n_elim: \forall n:nat. lt O n \to 
+\forall P:nat\to Prop. (\forall m:nat.P (S m)) \to P n.
+intro.elim n.apply False_ind.exact (not_le_Sn_O O H).
+apply H2.
+qed.
+
+(* other abstract properties *)
+theorem antisymmetric_le : antisymmetric nat le.
+unfold antisymmetric.intros 2.
+apply (nat_elim2 (\lambda n,m.(n \leq m \to m \leq n \to n=m))).
+intros.apply le_n_O_to_eq.assumption.
+intros.apply False_ind.apply (not_le_Sn_O ? H).
+intros.apply eq_f.apply H.
+apply le_S_S_to_le.assumption.
+apply le_S_S_to_le.assumption.
+qed.
+
+theorem antisym_le: \forall n,m:nat. n \leq m \to m \leq n \to n=m
+\def antisymmetric_le.
+
+theorem decidable_le: \forall n,m:nat. decidable (n \leq m).
+intros.
+apply (nat_elim2 (\lambda n,m.decidable (n \leq m))).
+intros.unfold decidable.left.apply le_O_n.
+intros.unfold decidable.right.exact (not_le_Sn_O n1).
+intros 2.unfold decidable.intro.elim H.
+left.apply le_S_S.assumption.
+right.unfold Not.intro.apply H1.apply le_S_S_to_le.assumption.
+qed.
+
+theorem decidable_lt: \forall n,m:nat. decidable (n < m).
+intros.exact (decidable_le (S n) m).
+qed.
+
+(* well founded induction principles *)
+
+theorem nat_elim1 : \forall n:nat.\forall P:nat \to Prop. 
+(\forall m.(\forall p. (p \lt m) \to P p) \to P m) \to P n.
+intros.cut (\forall q:nat. q \le n \to P q).
+apply (Hcut n).apply le_n.
+elim n.apply (le_n_O_elim q H1).
+apply H.
+intros.apply False_ind.apply (not_le_Sn_O p H2).
+apply H.intros.apply H1.
+cut (p < S n1).
+apply lt_S_to_le.assumption.
+apply (lt_to_le_to_lt p q (S n1) H3 H2).
+qed.
+
+(* some properties of functions *)
+
+definition increasing \def \lambda f:nat \to nat. 
+\forall n:nat. f n < f (S n).
+
+theorem increasing_to_monotonic: \forall f:nat \to nat.
+increasing f \to monotonic nat lt f.
+unfold monotonic.unfold lt.unfold increasing.unfold lt.intros.elim H1.apply H.
+apply (trans_le ? (f n1)).
+assumption.apply (trans_le ? (S (f n1))).
+apply le_n_Sn.
+apply H.
+qed.
+
+theorem le_n_fn: \forall f:nat \to nat. (increasing f) 
+\to \forall n:nat. n \le (f n).
+intros.elim n.
+apply le_O_n.
+apply (trans_le ? (S (f n1))).
+apply le_S_S.apply H1.
+simplify in H. unfold increasing in H.unfold lt in H.apply H.
+qed.
+
+theorem increasing_to_le: \forall f:nat \to nat. (increasing f) 
+\to \forall m:nat. \exists i. m \le (f i).
+intros.elim m.
+apply (ex_intro ? ? O).apply le_O_n.
+elim H1.
+apply (ex_intro ? ? (S a)).
+apply (trans_le ? (S (f a))).
+apply le_S_S.assumption.
+simplify in H.unfold increasing in H.unfold lt in H.
+apply H.
+qed.
+
+theorem increasing_to_le2: \forall f:nat \to nat. (increasing f) 
+\to \forall m:nat. (f O) \le m \to 
+\exists i. (f i) \le m \land m <(f (S i)).
+intros.elim H1.
+apply (ex_intro ? ? O).
+split.apply le_n.apply H.
+elim H3.elim H4.
+cut ((S n1) < (f (S a)) \lor (S n1) = (f (S a))).
+elim Hcut.
+apply (ex_intro ? ? a).
+split.apply le_S. assumption.assumption.
+apply (ex_intro ? ? (S a)).
+split.rewrite < H7.apply le_n.
+rewrite > 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 (file)
index 0000000..3e987e9
--- /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 (file)
index 0000000..d595dad
--- /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 (file)
index 0000000..50b7d12
--- /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<m).assumption.
+rewrite > 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<i).assumption.apply (le_n_O_elim i H1).
+apply (not_le_Sn_O O).
+change with (i \divides (S n1)*n1!).
+apply (le_n_Sm_elim i n1 H2).
+intro.
+apply (transitive_divides ? n1!).
+apply H1.apply le_S_S_to_le. assumption.
+apply (witness ? ? (S n1)).apply sym_times.
+intro.
+rewrite > 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 (file)
index 0000000..3ec61ee
--- /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 = <q,r> 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 (file)
index 0000000..f4cf437
--- /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 (file)
index 0000000..4f5f6cb
--- /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 (file)
index 0000000..2ae5ffd
--- /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 (file)
index 0000000..24c3920
--- /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 (file)
index 0000000..ee9aae1
--- /dev/null
+++ b/helm/matita/matita.conf.xml.sample.in
@@ -0,0 +1,36 @@
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+  <section name="user">
+    <key name="home">~</key>
+<!-- If not specified here, name of the user executing matita will be used -->
+<!--     <key name="name">foo</key> -->
+  </section>
+  <section name="matita">
+    <key name="auto_disambiguation">true</key>
+    <key name="environment_trust">true</key>
+    <key name="baseuri">cic:/matita/</key>
+    <key name="basedir">$(user.home)/.matita</key>
+    <key name="owner">$(user.name)</key>
+<!--     <key name="font_size">10</key> -->
+    <key name="tactics_bar">false</key>
+  </section>
+  <section name="db">
+    <!-- <key name="host">localhost</key> -->
+    <key name="host">mowgli.cs.unibo.it</key>
+    <key name="user">helm</key>
+    <key name="database">matita</key>
+  </section>
+  <section name="getter">
+    <key name="cache_dir">$(user.home)/.matita/getter/cache</key>
+    <key name="dtd_dir">/projects/helm/xml/dtd</key>
+    <key name="prefix">
+      cic:/
+      file:///projects/helm/library/coq_contribs/
+      legacy
+    </key>
+    <key name="prefix">
+      cic:/matita/
+      file://$(user.home)/.matita/xml/matita/
+    </key>
+  </section>
+</helm_registry>

diff --git a/helm/matita/matita.glade b/helm/matita/matita.glade
new file mode 100644 (file)
index 0000000..436dd7b
--- /dev/null
+++ b/helm/matita/matita.glade
@@ -0,0 +1,3952 @@
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="BrowserWin">
+  <property name="visible">True</property>
+  <property name="title" translatable="yes">Cic browser</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_CENTER_ON_PARENT</property>
+  <property name="modal">False</property>
+  <property name="default_width">500</property>
+  <property name="default_height">500</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+
+  <child>
+    <widget class="GtkEventBox" id="BrowserWinEventBox">
+      <property name="visible">True</property>
+      <property name="visible_window">True</property>
+      <property name="above_child">False</property>
+
+      <child>
+       <widget class="GtkVBox" id="BrowserVBox">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">0</property>
+
+         <child>
+           <widget class="GtkFrame" id="frame2">
+             <property name="visible">True</property>
+             <property name="label_xalign">0</property>
+             <property name="label_yalign">0</property>
+             <property name="shadow_type">GTK_SHADOW_NONE</property>
+
+             <child>
+               <widget class="GtkHBox" id="BrowserHBox">
+                 <property name="visible">True</property>
+                 <property name="homogeneous">False</property>
+                 <property name="spacing">0</property>
+
+                 <child>
+                   <widget class="GtkButton" id="BrowserNewButton">
+                     <property name="visible">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="relief">GTK_RELIEF_NONE</property>
+                     <property name="focus_on_click">True</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image303">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-new</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkButton" id="BrowserBackButton">
+                     <property name="visible">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="relief">GTK_RELIEF_NONE</property>
+                     <property name="focus_on_click">True</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image304">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-go-back</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkButton" id="BrowserForwardButton">
+                     <property name="visible">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="relief">GTK_RELIEF_NONE</property>
+                     <property name="focus_on_click">True</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image305">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-go-forward</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkButton" id="BrowserRefreshButton">
+                     <property name="visible">True</property>
+                     <property name="tooltip" translatable="yes">refresh</property>
+                     <property name="can_default">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="relief">GTK_RELIEF_NONE</property>
+                     <property name="focus_on_click">True</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image229">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-refresh</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkButton" id="BrowserHomeButton">
+                     <property name="visible">True</property>
+                     <property name="tooltip" translatable="yes">home</property>
+                     <property name="can_default">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="relief">GTK_RELIEF_NONE</property>
+                     <property name="focus_on_click">True</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image190">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-home</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkImage" id="image301">
+                     <property name="visible">True</property>
+                     <property name="stock">gtk-jump-to</property>
+                     <property name="icon_size">2</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                   </widget>
+                   <packing>
+                     <property name="padding">3</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkHBox" id="UriHBox">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">0</property>
+
+                     <child>
+                       <placeholder/>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">True</property>
+                     <property name="fill">True</property>
+                   </packing>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkHBox" id="whelpBarBox">
+             <property name="border_width">3</property>
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">6</property>
+
+             <child>
+               <widget class="GtkImage" id="WhelpBarImage">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkEntry" id="queryInputText">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="editable">True</property>
+                 <property name="visibility">True</property>
+                 <property name="max_length">0</property>
+                 <property name="text" translatable="yes"></property>
+                 <property name="has_frame">True</property>
+                 <property name="invisible_char">*</property>
+                 <property name="activates_default">False</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">True</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkVBox" id="whelpBarComboVbox">
+                 <property name="visible">True</property>
+                 <property name="homogeneous">False</property>
+                 <property name="spacing">0</property>
+
+                 <child>
+                   <widget class="GtkAlignment" id="alignment4">
+                     <property name="visible">True</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xscale">1</property>
+                     <property name="yscale">1</property>
+                     <property name="top_padding">0</property>
+                     <property name="bottom_padding">0</property>
+                     <property name="left_padding">0</property>
+                     <property name="right_padding">0</property>
+
+                     <child>
+                       <placeholder/>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkNotebook" id="mathOrListNotebook">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="show_tabs">True</property>
+             <property name="show_border">True</property>
+             <property name="tab_pos">GTK_POS_TOP</property>
+             <property name="scrollable">False</property>
+             <property name="enable_popup">False</property>
+
+             <child>
+               <widget class="GtkScrolledWindow" id="ScrolledBrowser">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                 <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                 <property name="shadow_type">GTK_SHADOW_NONE</property>
+                 <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                 <child>
+                   <placeholder/>
+                 </child>
+               </widget>
+               <packing>
+                 <property name="tab_expand">False</property>
+                 <property name="tab_fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkLabel" id="mathLabel">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">MathView</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+                 <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                 <property name="width_chars">-1</property>
+                 <property name="single_line_mode">False</property>
+                 <property name="angle">0</property>
+               </widget>
+               <packing>
+                 <property name="type">tab</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkScrolledWindow" id="scrolledwindow9">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                 <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                 <property name="shadow_type">GTK_SHADOW_IN</property>
+                 <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                 <child>
+                   <widget class="GtkTreeView" id="whelpResultTreeview">
+                     <property name="visible">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="headers_visible">False</property>
+                     <property name="rules_hint">False</property>
+                     <property name="reorderable">False</property>
+                     <property name="enable_search">True</property>
+                     <property name="fixed_height_mode">False</property>
+                     <property name="hover_selection">False</property>
+                     <property name="hover_expand">False</property>
+                   </widget>
+                 </child>
+               </widget>
+               <packing>
+                 <property name="tab_expand">False</property>
+                 <property name="tab_fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkLabel" id="listLabel">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">WhelpResults</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+                 <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                 <property name="width_chars">-1</property>
+                 <property name="single_line_mode">False</property>
+                 <property name="angle">0</property>
+               </widget>
+               <packing>
+                 <property name="type">tab</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkImage" id="EasterEggImage">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="tab_expand">False</property>
+                 <property name="tab_fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkLabel" id="EasterEggLabel">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">WhelpEasterEgg</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+                 <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                 <property name="width_chars">-1</property>
+                 <property name="single_line_mode">False</property>
+                 <property name="angle">0</property>
+               </widget>
+               <packing>
+                 <property name="type">tab</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+       </widget>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkDialog" id="ConfirmationDialog">
+  <property name="title" translatable="yes">DUMMY</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_CENTER</property>
+  <property name="modal">True</property>
+  <property name="resizable">False</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+  <property name="has_separator">True</property>
+
+  <child internal-child="vbox">
+    <widget class="GtkVBox" id="dialog-vbox1">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child internal-child="action_area">
+       <widget class="GtkHButtonBox" id="dialog-action_area1">
+         <property name="visible">True</property>
+         <property name="layout_style">GTK_BUTTONBOX_END</property>
+
+         <child>
+           <widget class="GtkButton" id="ConfirmationDialogCancelButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-6</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="ConfirmationDialogOkButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-ok</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-5</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+         <property name="pack_type">GTK_PACK_END</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkLabel" id="ConfirmationDialogLabel">
+         <property name="visible">True</property>
+         <property name="label" translatable="yes">DUMMY</property>
+         <property name="use_underline">False</property>
+         <property name="use_markup">False</property>
+         <property name="justify">GTK_JUSTIFY_CENTER</property>
+         <property name="wrap">False</property>
+         <property name="selectable">False</property>
+         <property name="xalign">0.5</property>
+         <property name="yalign">0.5</property>
+         <property name="xpad">0</property>
+         <property name="ypad">0</property>
+         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+         <property name="width_chars">-1</property>
+         <property name="single_line_mode">False</property>
+         <property name="angle">0</property>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkDialog" id="EmptyDialog">
+  <property name="visible">True</property>
+  <property name="title" translatable="yes">DUMMY</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">False</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+  <property name="has_separator">True</property>
+
+  <child internal-child="vbox">
+    <widget class="GtkVBox" id="EmptyDialogVBox">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child internal-child="action_area">
+       <widget class="GtkHButtonBox" id="dialog-action_area5">
+         <property name="visible">True</property>
+         <property name="layout_style">GTK_BUTTONBOX_END</property>
+
+         <child>
+           <widget class="GtkButton" id="EmptyDialogCancelButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-6</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="EmptyDialogOkButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-ok</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-5</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+         <property name="pack_type">GTK_PACK_END</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkLabel" id="EmptyDialogLabel">
+         <property name="visible">True</property>
+         <property name="label" translatable="yes">DUMMY</property>
+         <property name="use_underline">False</property>
+         <property name="use_markup">False</property>
+         <property name="justify">GTK_JUSTIFY_LEFT</property>
+         <property name="wrap">False</property>
+         <property name="selectable">False</property>
+         <property name="xalign">0.5</property>
+         <property name="yalign">0.5</property>
+         <property name="xpad">0</property>
+         <property name="ypad">0</property>
+         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+         <property name="width_chars">-1</property>
+         <property name="single_line_mode">False</property>
+         <property name="angle">0</property>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+
+      <child>
+       <placeholder/>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkFileSelection" id="FileSelectionWin">
+  <property name="border_width">10</property>
+  <property name="title" translatable="yes">Select File</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_CENTER</property>
+  <property name="modal">True</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+  <property name="show_fileops">True</property>
+
+  <child internal-child="cancel_button">
+    <widget class="GtkButton" id="fileSelCancelButton">
+      <property name="visible">True</property>
+      <property name="can_default">True</property>
+      <property name="can_focus">True</property>
+      <property name="relief">GTK_RELIEF_NORMAL</property>
+      <property name="focus_on_click">True</property>
+    </widget>
+  </child>
+
+  <child internal-child="ok_button">
+    <widget class="GtkButton" id="fileSelOkButton">
+      <property name="visible">True</property>
+      <property name="can_default">True</property>
+      <property name="can_focus">True</property>
+      <property name="relief">GTK_RELIEF_NORMAL</property>
+      <property name="focus_on_click">True</property>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkDialog" id="RecordChoiceDialog">
+  <property name="width_request">350</property>
+  <property name="height_request">250</property>
+  <property name="title" translatable="yes">title</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">True</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+  <property name="has_separator">True</property>
+
+  <child internal-child="vbox">
+    <widget class="GtkVBox" id="dialog-vbox4">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child internal-child="action_area">
+       <widget class="GtkHButtonBox" id="dialog-action_area4">
+         <property name="visible">True</property>
+         <property name="layout_style">GTK_BUTTONBOX_END</property>
+
+         <child>
+           <widget class="GtkButton" id="RecordChoiceHelpButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-help</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-11</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="RecordChoiceCancelButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-6</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="RecordChoiceOkButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-ok</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-5</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+         <property name="pack_type">GTK_PACK_END</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkVBox" id="vbox3">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">0</property>
+
+         <child>
+           <widget class="GtkLabel" id="RecordChoiceDialogLabel">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes">some informative message here ...</property>
+             <property name="use_underline">False</property>
+             <property name="use_markup">False</property>
+             <property name="justify">GTK_JUSTIFY_LEFT</property>
+             <property name="wrap">False</property>
+             <property name="selectable">False</property>
+             <property name="xalign">0.5</property>
+             <property name="yalign">0.5</property>
+             <property name="xpad">0</property>
+             <property name="ypad">0</property>
+             <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+             <property name="width_chars">-1</property>
+             <property name="single_line_mode">False</property>
+             <property name="angle">0</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkScrolledWindow" id="scrolledwindow4">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+             <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+             <property name="shadow_type">GTK_SHADOW_IN</property>
+             <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+             <child>
+               <widget class="GtkTreeView" id="RecordChoiceTreeView">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="headers_visible">False</property>
+                 <property name="rules_hint">False</property>
+                 <property name="reorderable">False</property>
+                 <property name="enable_search">True</property>
+                 <property name="fixed_height_mode">False</property>
+                 <property name="hover_selection">False</property>
+                 <property name="hover_expand">False</property>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkWindow" id="MainWin">
+  <property name="title" translatable="yes">Matita</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">False</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+
+  <child>
+    <widget class="GtkEventBox" id="MainWinEventBox">
+      <property name="visible">True</property>
+      <property name="visible_window">True</property>
+      <property name="above_child">False</property>
+
+      <child>
+       <widget class="GtkVBox" id="vbox8">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">0</property>
+
+         <child>
+           <widget class="GtkHandleBox" id="menuBarHandleBox">
+             <property name="visible">True</property>
+             <property name="shadow_type">GTK_SHADOW_OUT</property>
+             <property name="handle_position">GTK_POS_LEFT</property>
+             <property name="snap_edge">GTK_POS_TOP</property>
+
+             <child>
+               <widget class="GtkMenuBar" id="menubar1">
+                 <property name="visible">True</property>
+
+                 <child>
+                   <widget class="GtkMenuItem" id="fileMenu">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">_File</property>
+                     <property name="use_underline">True</property>
+
+                     <child>
+                       <widget class="GtkMenu" id="fileMenu_menu">
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="newMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_New</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="n" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image856">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-new</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="openMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Open...</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="o" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image857">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-open</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="saveMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Save</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="s" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image858">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-save</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="saveAsMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Save _As ...</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="s" modifiers="GDK_CONTROL_MASK | GDK_SHIFT_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image859">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-save-as</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="developmentsMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Developments...</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="d" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image860">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-execute</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator2">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="quitMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Quit</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="q" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image861">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-quit</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+                       </widget>
+                     </child>
+                   </widget>
+                 </child>
+
+                 <child>
+                   <widget class="GtkMenuItem" id="editMenu">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">_Edit</property>
+                     <property name="use_underline">True</property>
+
+                     <child>
+                       <widget class="GtkMenu" id="editMenu_menu">
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="undoMenuItem">
+                             <property name="visible">True</property>
+                             <property name="sensitive">False</property>
+                             <property name="label" translatable="yes">_Undo</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="z" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image862">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-undo</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="redoMenuItem">
+                             <property name="visible">True</property>
+                             <property name="sensitive">False</property>
+                             <property name="label" translatable="yes">_Redo</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="z" modifiers="GDK_CONTROL_MASK | GDK_SHIFT_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image863">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-redo</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator3">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="cutMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Cu_t</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="x" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image864">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-cut</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="copyMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Copy</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="c" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image865">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-copy</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="pasteMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Paste</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="v" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image866">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-paste</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="pastePatternMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Paste as pattern</property>
+                             <property name="use_underline">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="deleteMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Delete</property>
+                             <property name="use_underline">True</property>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image867">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-delete</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator4">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="selectAllMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Select _All</property>
+                             <property name="use_underline">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator7">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="findReplMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Find &amp; Replace ...</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="f" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image868">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-find-and-replace</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator8">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="LigatureButton">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Next ligature</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="l" modifiers="GDK_MOD1_MASK" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="externalEditorMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Edit with E_xternal Editor</property>
+                             <property name="use_underline">True</property>
+                           </widget>
+                         </child>
+                       </widget>
+                     </child>
+                   </widget>
+                 </child>
+
+                 <child>
+                   <widget class="GtkMenuItem" id="scriptMenu">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">_Script</property>
+                     <property name="use_underline">True</property>
+
+                     <child>
+                       <widget class="GtkMenu" id="scriptMenu_menu">
+
+                         <child>
+                           <widget class="GtkMenuItem" id="scriptAdvanceMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Execute 1 phrase</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="Page_Down" modifiers="GDK_CONTROL_MASK | GDK_MOD1_MASK" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="scriptRetractMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Retract 1 phrase</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="Page_Up" modifiers="GDK_CONTROL_MASK | GDK_MOD1_MASK" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator9">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="scriptBottomMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Execute all</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="End" modifiers="GDK_CONTROL_MASK | GDK_MOD1_MASK" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="scriptTopMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Restart</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="Home" modifiers="GDK_CONTROL_MASK | GDK_MOD1_MASK" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator10">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="scriptJumpMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Execute until cursor</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="period" modifiers="GDK_CONTROL_MASK | GDK_MOD1_MASK" signal="activate"/>
+                           </widget>
+                         </child>
+                       </widget>
+                     </child>
+                   </widget>
+                 </child>
+
+                 <child>
+                   <widget class="GtkMenuItem" id="viewMenu">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">_View</property>
+                     <property name="use_underline">True</property>
+
+                     <child>
+                       <widget class="GtkMenu" id="viewMenu_menu">
+
+                         <child>
+                           <widget class="GtkCheckMenuItem" id="tacticsBarMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Show _Tactics Bar</property>
+                             <property name="use_underline">True</property>
+                             <property name="active">True</property>
+                             <accelerator key="F2" modifiers="0" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkMenuItem" id="newCicBrowserMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">New Cic _Browser</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="F3" modifiers="0" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator5">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkCheckMenuItem" id="fullscreenMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Fullscreen</property>
+                             <property name="use_underline">True</property>
+                             <property name="active">False</property>
+                             <accelerator key="F11" modifiers="0" signal="activate"/>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator1">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="increaseFontSizeMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Zoom _In</property>
+                             <property name="use_underline">True</property>
+                             <signal name="activate" handler="on_increaseFontSizeMenuItem_activate" last_modification_time="Wed, 15 Jun 2005 15:06:29 GMT"/>
+                             <accelerator key="plus" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image869">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-zoom-in</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="decreaseFontSizeMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">Zoom _Out</property>
+                             <property name="use_underline">True</property>
+                             <signal name="activate" handler="on_decreaseFontSizeMenuItem_activate" last_modification_time="Wed, 15 Jun 2005 15:06:29 GMT"/>
+                             <accelerator key="minus" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image870">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-zoom-out</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="normalFontSizeMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_Normal Size</property>
+                             <property name="use_underline">True</property>
+                             <accelerator key="equal" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image871">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-zoom-100</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+                       </widget>
+                     </child>
+                   </widget>
+                 </child>
+
+                 <child>
+                   <widget class="GtkMenuItem" id="debugMenu">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">_Debug</property>
+                     <property name="use_underline">True</property>
+
+                     <child>
+                       <widget class="GtkMenu" id="debugMenu_menu">
+
+                         <child>
+                           <widget class="GtkSeparatorMenuItem" id="separator6">
+                             <property name="visible">True</property>
+                           </widget>
+                         </child>
+                       </widget>
+                     </child>
+                   </widget>
+                 </child>
+
+                 <child>
+                   <widget class="GtkMenuItem" id="helpMenu">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">_Help</property>
+                     <property name="use_underline">True</property>
+
+                     <child>
+                       <widget class="GtkMenu" id="helpMenu_menu">
+
+                         <child>
+                           <widget class="GtkImageMenuItem" id="aboutMenuItem">
+                             <property name="visible">True</property>
+                             <property name="label" translatable="yes">_About</property>
+                             <property name="use_underline">True</property>
+
+                             <child internal-child="image">
+                               <widget class="GtkImage" id="image872">
+                                 <property name="visible">True</property>
+                                 <property name="stock">gtk-about</property>
+                                 <property name="icon_size">1</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                               </widget>
+                             </child>
+                           </widget>
+                         </child>
+                       </widget>
+                     </child>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkHBox" id="hbox9">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">0</property>
+
+             <child>
+               <widget class="GtkHPaned" id="hpaneScriptSequent">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+
+                 <child>
+                   <widget class="GtkHBox" id="hbox18">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">0</property>
+
+                     <child>
+                       <widget class="GtkHandleBox" id="TacticsButtonsHandlebox">
+                         <property name="visible">True</property>
+                         <property name="shadow_type">GTK_SHADOW_OUT</property>
+                         <property name="handle_position">GTK_POS_TOP</property>
+                         <property name="snap_edge">GTK_POS_TOP</property>
+
+                         <child>
+                           <widget class="GtkTable" id="ToolBarTable">
+                             <property name="visible">True</property>
+                             <property name="n_rows">17</property>
+                             <property name="n_columns">2</property>
+                             <property name="homogeneous">False</property>
+                             <property name="row_spacing">4</property>
+                             <property name="column_spacing">0</property>
+
+                             <child>
+                               <widget class="GtkButton" id="applyButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Apply</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">apply</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">0</property>
+                                 <property name="bottom_attach">1</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="introsButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Intros</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">intro</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">0</property>
+                                 <property name="bottom_attach">1</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="exactButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Exact</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">exact</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">2</property>
+                                 <property name="bottom_attach">3</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="elimButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Elim</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">elim</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">4</property>
+                                 <property name="bottom_attach">5</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="reflexivityButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Reflexivity</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">refl</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">8</property>
+                                 <property name="bottom_attach">9</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="symmetryButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Symmetry</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">sym</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">8</property>
+                                 <property name="bottom_attach">9</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="transitivityButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Transitivity</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">trans</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">9</property>
+                                 <property name="bottom_attach">10</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="simplifyButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Simplify</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">simpl</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">11</property>
+                                 <property name="bottom_attach">12</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="reduceButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Reduce</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">red</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">11</property>
+                                 <property name="bottom_attach">12</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="whdButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Whd</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">whd</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">12</property>
+                                 <property name="bottom_attach">13</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="assumptionButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Assumption</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">assum</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">14</property>
+                                 <property name="bottom_attach">15</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="autoButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Auto</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">auto</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">14</property>
+                                 <property name="bottom_attach">15</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="cutButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Cut</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">cut</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">16</property>
+                                 <property name="bottom_attach">17</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="replaceButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">Replace</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">repl</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">16</property>
+                                 <property name="bottom_attach">17</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkButton" id="elimTypeButton">
+                                 <property name="visible">True</property>
+                                 <property name="tooltip" translatable="yes">ElimType</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="label" translatable="yes">elimTy</property>
+                                 <property name="use_underline">True</property>
+                                 <property name="relief">GTK_RELIEF_NORMAL</property>
+                                 <property name="focus_on_click">True</property>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">4</property>
+                                 <property name="bottom_attach">5</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options"></property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkHBox" id="hbox18">
+                                 <property name="visible">True</property>
+                                 <property name="homogeneous">True</property>
+                                 <property name="spacing">0</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="rightButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Right</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="label" translatable="yes">R</property>
+                                     <property name="use_underline">True</property>
+                                     <property name="relief">GTK_RELIEF_NORMAL</property>
+                                     <property name="focus_on_click">True</property>
+                                   </widget>
+                                   <packing>
+                                     <property name="padding">0</property>
+                                     <property name="expand">True</property>
+                                     <property name="fill">True</property>
+                                   </packing>
+                                 </child>
+
+                                 <child>
+                                   <widget class="GtkButton" id="existsButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Exists</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="label" translatable="yes">∃</property>
+                                     <property name="use_underline">True</property>
+                                     <property name="relief">GTK_RELIEF_NORMAL</property>
+                                     <property name="focus_on_click">True</property>
+                                   </widget>
+                                   <packing>
+                                     <property name="padding">0</property>
+                                     <property name="expand">True</property>
+                                     <property name="fill">True</property>
+                                   </packing>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">1</property>
+                                 <property name="right_attach">2</property>
+                                 <property name="top_attach">6</property>
+                                 <property name="bottom_attach">7</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkHBox" id="hbox17">
+                                 <property name="visible">True</property>
+                                 <property name="homogeneous">True</property>
+                                 <property name="spacing">0</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="splitButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Split</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="label" translatable="yes">∧</property>
+                                     <property name="use_underline">True</property>
+                                     <property name="relief">GTK_RELIEF_NORMAL</property>
+                                     <property name="focus_on_click">True</property>
+                                   </widget>
+                                   <packing>
+                                     <property name="padding">0</property>
+                                     <property name="expand">True</property>
+                                     <property name="fill">True</property>
+                                   </packing>
+                                 </child>
+
+                                 <child>
+                                   <widget class="GtkButton" id="leftButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Left</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="label" translatable="yes">L</property>
+                                     <property name="use_underline">True</property>
+                                     <property name="relief">GTK_RELIEF_NORMAL</property>
+                                     <property name="focus_on_click">True</property>
+                                   </widget>
+                                   <packing>
+                                     <property name="padding">0</property>
+                                     <property name="expand">True</property>
+                                     <property name="fill">True</property>
+                                   </packing>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">6</property>
+                                 <property name="bottom_attach">7</property>
+                                 <property name="x_options">fill</property>
+                                 <property name="y_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment6">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">1</property>
+                                 <property name="bottom_attach">2</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment7">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">3</property>
+                                 <property name="bottom_attach">4</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment8">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">5</property>
+                                 <property name="bottom_attach">6</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment9">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">7</property>
+                                 <property name="bottom_attach">8</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment10">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">10</property>
+                                 <property name="bottom_attach">11</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment11">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">13</property>
+                                 <property name="bottom_attach">14</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkAlignment" id="alignment12">
+                                 <property name="visible">True</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xscale">1</property>
+                                 <property name="yscale">1</property>
+                                 <property name="top_padding">0</property>
+                                 <property name="bottom_padding">0</property>
+                                 <property name="left_padding">0</property>
+                                 <property name="right_padding">0</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="left_attach">0</property>
+                                 <property name="right_attach">1</property>
+                                 <property name="top_attach">15</property>
+                                 <property name="bottom_attach">16</property>
+                                 <property name="x_options">fill</property>
+                               </packing>
+                             </child>
+                           </widget>
+                         </child>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">True</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkVBox" id="vboxScript">
+                         <property name="width_request">400</property>
+                         <property name="visible">True</property>
+                         <property name="homogeneous">False</property>
+                         <property name="spacing">0</property>
+
+                         <child>
+                           <widget class="GtkToolbar" id="buttonsToolbar">
+                             <property name="visible">True</property>
+                             <property name="orientation">GTK_ORIENTATION_HORIZONTAL</property>
+                             <property name="toolbar_style">GTK_TOOLBAR_BOTH</property>
+                             <property name="tooltips">True</property>
+                             <property name="show_arrow">True</property>
+
+                             <child>
+                               <widget class="GtkToolItem" id="toolitem25">
+                                 <property name="visible">True</property>
+                                 <property name="visible_horizontal">True</property>
+                                 <property name="visible_vertical">True</property>
+                                 <property name="is_important">False</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="scriptTopButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Restart</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="relief">GTK_RELIEF_NONE</property>
+                                     <property name="focus_on_click">True</property>
+
+                                     <child>
+                                       <widget class="GtkImage" id="image253">
+                                         <property name="visible">True</property>
+                                         <property name="stock">gtk-goto-top</property>
+                                         <property name="icon_size">4</property>
+                                         <property name="xalign">0.5</property>
+                                         <property name="yalign">0.5</property>
+                                         <property name="xpad">0</property>
+                                         <property name="ypad">0</property>
+                                       </widget>
+                                     </child>
+                                   </widget>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="expand">False</property>
+                                 <property name="homogeneous">False</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkToolItem" id="toolitem26">
+                                 <property name="visible">True</property>
+                                 <property name="visible_horizontal">True</property>
+                                 <property name="visible_vertical">True</property>
+                                 <property name="is_important">False</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="scriptRetractButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Retract 1 phrase</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="relief">GTK_RELIEF_NONE</property>
+                                     <property name="focus_on_click">True</property>
+
+                                     <child>
+                                       <widget class="GtkImage" id="image254">
+                                         <property name="visible">True</property>
+                                         <property name="stock">gtk-go-up</property>
+                                         <property name="icon_size">4</property>
+                                         <property name="xalign">0.5</property>
+                                         <property name="yalign">0.5</property>
+                                         <property name="xpad">0</property>
+                                         <property name="ypad">0</property>
+                                       </widget>
+                                     </child>
+                                   </widget>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="expand">False</property>
+                                 <property name="homogeneous">False</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkToolItem" id="toolitem27">
+                                 <property name="visible">True</property>
+                                 <property name="visible_horizontal">True</property>
+                                 <property name="visible_vertical">True</property>
+                                 <property name="is_important">False</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="scriptJumpButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Execute until point</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="relief">GTK_RELIEF_NONE</property>
+                                     <property name="focus_on_click">True</property>
+
+                                     <child>
+                                       <widget class="GtkImage" id="image255">
+                                         <property name="visible">True</property>
+                                         <property name="stock">gtk-jump-to</property>
+                                         <property name="icon_size">4</property>
+                                         <property name="xalign">0.5</property>
+                                         <property name="yalign">0.5</property>
+                                         <property name="xpad">0</property>
+                                         <property name="ypad">0</property>
+                                       </widget>
+                                     </child>
+                                   </widget>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="expand">False</property>
+                                 <property name="homogeneous">False</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkToolItem" id="toolitem28">
+                                 <property name="visible">True</property>
+                                 <property name="visible_horizontal">True</property>
+                                 <property name="visible_vertical">True</property>
+                                 <property name="is_important">False</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="scriptAdvanceButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Execute 1 phrase</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="relief">GTK_RELIEF_NONE</property>
+                                     <property name="focus_on_click">True</property>
+
+                                     <child>
+                                       <widget class="GtkImage" id="image256">
+                                         <property name="visible">True</property>
+                                         <property name="stock">gtk-go-down</property>
+                                         <property name="icon_size">4</property>
+                                         <property name="xalign">0.5</property>
+                                         <property name="yalign">0.5</property>
+                                         <property name="xpad">0</property>
+                                         <property name="ypad">0</property>
+                                       </widget>
+                                     </child>
+                                   </widget>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="expand">False</property>
+                                 <property name="homogeneous">False</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkToolItem" id="toolitem29">
+                                 <property name="visible">True</property>
+                                 <property name="visible_horizontal">True</property>
+                                 <property name="visible_vertical">True</property>
+                                 <property name="is_important">False</property>
+
+                                 <child>
+                                   <widget class="GtkButton" id="scriptBottomButton">
+                                     <property name="visible">True</property>
+                                     <property name="tooltip" translatable="yes">Execute all</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="relief">GTK_RELIEF_NONE</property>
+                                     <property name="focus_on_click">True</property>
+
+                                     <child>
+                                       <widget class="GtkImage" id="image257">
+                                         <property name="visible">True</property>
+                                         <property name="stock">gtk-goto-bottom</property>
+                                         <property name="icon_size">4</property>
+                                         <property name="xalign">0.5</property>
+                                         <property name="yalign">0.5</property>
+                                         <property name="xpad">0</property>
+                                         <property name="ypad">0</property>
+                                       </widget>
+                                     </child>
+                                   </widget>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="expand">False</property>
+                                 <property name="homogeneous">False</property>
+                               </packing>
+                             </child>
+                           </widget>
+                           <packing>
+                             <property name="padding">0</property>
+                             <property name="expand">False</property>
+                             <property name="fill">False</property>
+                           </packing>
+                         </child>
+
+                         <child>
+                           <widget class="GtkNotebook" id="scriptNotebook">
+                             <property name="visible">True</property>
+                             <property name="can_focus">True</property>
+                             <property name="show_tabs">True</property>
+                             <property name="show_border">True</property>
+                             <property name="tab_pos">GTK_POS_BOTTOM</property>
+                             <property name="scrollable">False</property>
+                             <property name="enable_popup">False</property>
+
+                             <child>
+                               <widget class="GtkScrolledWindow" id="ScriptScrolledWin">
+                                 <property name="visible">True</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                                 <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                                 <property name="shadow_type">GTK_SHADOW_NONE</property>
+                                 <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                                 <child>
+                                   <placeholder/>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="tab_expand">False</property>
+                                 <property name="tab_fill">True</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkLabel" id="scriptLabel">
+                                 <property name="visible">True</property>
+                                 <property name="label" translatable="yes">script</property>
+                                 <property name="use_underline">False</property>
+                                 <property name="use_markup">False</property>
+                                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                                 <property name="wrap">False</property>
+                                 <property name="selectable">False</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                                 <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                                 <property name="width_chars">-1</property>
+                                 <property name="single_line_mode">False</property>
+                                 <property name="angle">0</property>
+                               </widget>
+                               <packing>
+                                 <property name="type">tab</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkScrolledWindow" id="scrolledwindow8">
+                                 <property name="visible">True</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                                 <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+                                 <property name="shadow_type">GTK_SHADOW_NONE</property>
+                                 <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                                 <child>
+                                   <widget class="GtkTreeView" id="scriptTreeView">
+                                     <property name="visible">True</property>
+                                     <property name="can_focus">True</property>
+                                     <property name="headers_visible">False</property>
+                                     <property name="rules_hint">False</property>
+                                     <property name="reorderable">False</property>
+                                     <property name="enable_search">True</property>
+                                     <property name="fixed_height_mode">False</property>
+                                     <property name="hover_selection">False</property>
+                                     <property name="hover_expand">False</property>
+                                   </widget>
+                                 </child>
+                               </widget>
+                               <packing>
+                                 <property name="tab_expand">False</property>
+                                 <property name="tab_fill">True</property>
+                               </packing>
+                             </child>
+
+                             <child>
+                               <widget class="GtkLabel" id="label13">
+                                 <property name="visible">True</property>
+                                 <property name="label" translatable="yes">outline</property>
+                                 <property name="use_underline">False</property>
+                                 <property name="use_markup">False</property>
+                                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                                 <property name="wrap">False</property>
+                                 <property name="selectable">False</property>
+                                 <property name="xalign">0.5</property>
+                                 <property name="yalign">0.5</property>
+                                 <property name="xpad">0</property>
+                                 <property name="ypad">0</property>
+                                 <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                                 <property name="width_chars">-1</property>
+                                 <property name="single_line_mode">False</property>
+                                 <property name="angle">0</property>
+                               </widget>
+                               <packing>
+                                 <property name="type">tab</property>
+                               </packing>
+                             </child>
+                           </widget>
+                           <packing>
+                             <property name="padding">0</property>
+                             <property name="expand">True</property>
+                             <property name="fill">True</property>
+                           </packing>
+                         </child>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">True</property>
+                         <property name="fill">True</property>
+                       </packing>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="shrink">True</property>
+                     <property name="resize">False</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkVPaned" id="vpaned1">
+                     <property name="width_request">250</property>
+                     <property name="height_request">500</property>
+                     <property name="visible">True</property>
+                     <property name="can_focus">True</property>
+                     <property name="position">380</property>
+
+                     <child>
+                       <widget class="GtkNotebook" id="sequentsNotebook">
+                         <property name="visible">True</property>
+                         <property name="can_focus">True</property>
+                         <property name="show_tabs">True</property>
+                         <property name="show_border">True</property>
+                         <property name="tab_pos">GTK_POS_TOP</property>
+                         <property name="scrollable">False</property>
+                         <property name="enable_popup">False</property>
+                       </widget>
+                       <packing>
+                         <property name="shrink">True</property>
+                         <property name="resize">False</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkHBox" id="hbox9">
+                         <property name="visible">True</property>
+                         <property name="homogeneous">False</property>
+                         <property name="spacing">0</property>
+
+                         <child>
+                           <widget class="GtkScrolledWindow" id="logScrolledWin">
+                             <property name="visible">True</property>
+                             <property name="can_focus">True</property>
+                             <property name="hscrollbar_policy">GTK_POLICY_NEVER</property>
+                             <property name="vscrollbar_policy">GTK_POLICY_ALWAYS</property>
+                             <property name="shadow_type">GTK_SHADOW_IN</property>
+                             <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                             <child>
+                               <widget class="GtkTextView" id="logTextView">
+                                 <property name="visible">True</property>
+                                 <property name="can_focus">True</property>
+                                 <property name="editable">False</property>
+                                 <property name="overwrite">False</property>
+                                 <property name="accepts_tab">True</property>
+                                 <property name="justification">GTK_JUSTIFY_LEFT</property>
+                                 <property name="wrap_mode">GTK_WRAP_CHAR</property>
+                                 <property name="cursor_visible">False</property>
+                                 <property name="pixels_above_lines">0</property>
+                                 <property name="pixels_below_lines">0</property>
+                                 <property name="pixels_inside_wrap">0</property>
+                                 <property name="left_margin">0</property>
+                                 <property name="right_margin">0</property>
+                                 <property name="indent">0</property>
+                                 <property name="text" translatable="yes"></property>
+                               </widget>
+                             </child>
+                           </widget>
+                           <packing>
+                             <property name="padding">0</property>
+                             <property name="expand">True</property>
+                             <property name="fill">True</property>
+                           </packing>
+                         </child>
+                       </widget>
+                       <packing>
+                         <property name="shrink">True</property>
+                         <property name="resize">True</property>
+                       </packing>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="shrink">True</property>
+                     <property name="resize">True</property>
+                   </packing>
+                 </child>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">True</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkHBox" id="hbox10">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">0</property>
+
+             <child>
+               <widget class="GtkStatusbar" id="StatusBar">
+                 <property name="visible">True</property>
+                 <property name="has_resize_grip">False</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">True</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkNotebook" id="HintNotebook">
+                 <property name="visible">True</property>
+                 <property name="show_tabs">False</property>
+                 <property name="show_border">True</property>
+                 <property name="tab_pos">GTK_POS_TOP</property>
+                 <property name="scrollable">False</property>
+                 <property name="enable_popup">False</property>
+
+                 <child>
+                   <widget class="GtkImage" id="HintLowImage">
+                     <property name="visible">True</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                   </widget>
+                   <packing>
+                     <property name="tab_expand">False</property>
+                     <property name="tab_fill">True</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkLabel" id="label14">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">label14</property>
+                     <property name="use_underline">False</property>
+                     <property name="use_markup">False</property>
+                     <property name="justify">GTK_JUSTIFY_LEFT</property>
+                     <property name="wrap">False</property>
+                     <property name="selectable">False</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                     <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                     <property name="width_chars">-1</property>
+                     <property name="single_line_mode">False</property>
+                     <property name="angle">0</property>
+                   </widget>
+                   <packing>
+                     <property name="type">tab</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkImage" id="HintMediumImage">
+                     <property name="visible">True</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                   </widget>
+                   <packing>
+                     <property name="tab_expand">False</property>
+                     <property name="tab_fill">True</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkLabel" id="label15">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">label15</property>
+                     <property name="use_underline">False</property>
+                     <property name="use_markup">False</property>
+                     <property name="justify">GTK_JUSTIFY_LEFT</property>
+                     <property name="wrap">False</property>
+                     <property name="selectable">False</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                     <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                     <property name="width_chars">-1</property>
+                     <property name="single_line_mode">False</property>
+                     <property name="angle">0</property>
+                   </widget>
+                   <packing>
+                     <property name="type">tab</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkImage" id="HintHighImage">
+                     <property name="visible">True</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                   </widget>
+                   <packing>
+                     <property name="tab_expand">False</property>
+                     <property name="tab_fill">True</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkLabel" id="label16">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">label16</property>
+                     <property name="use_underline">False</property>
+                     <property name="use_markup">False</property>
+                     <property name="justify">GTK_JUSTIFY_LEFT</property>
+                     <property name="wrap">False</property>
+                     <property name="selectable">False</property>
+                     <property name="xalign">0.5</property>
+                     <property name="yalign">0.5</property>
+                     <property name="xpad">0</property>
+                     <property name="ypad">0</property>
+                     <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                     <property name="width_chars">-1</property>
+                     <property name="single_line_mode">False</property>
+                     <property name="angle">0</property>
+                   </widget>
+                   <packing>
+                     <property name="type">tab</property>
+                   </packing>
+                 </child>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+       </widget>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkDialog" id="TextDialog">
+  <property name="title" translatable="yes">DUMMY</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">False</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+  <property name="has_separator">True</property>
+
+  <child internal-child="vbox">
+    <widget class="GtkVBox" id="vbox5">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child internal-child="action_area">
+       <widget class="GtkHButtonBox" id="hbuttonbox1">
+         <property name="visible">True</property>
+         <property name="layout_style">GTK_BUTTONBOX_END</property>
+
+         <child>
+           <widget class="GtkButton" id="TextDialogCancelButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-6</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="TextDialogOkButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-ok</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-5</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+         <property name="pack_type">GTK_PACK_END</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkLabel" id="TextDialogLabel">
+         <property name="visible">True</property>
+         <property name="label" translatable="yes">DUMMY</property>
+         <property name="use_underline">False</property>
+         <property name="use_markup">False</property>
+         <property name="justify">GTK_JUSTIFY_LEFT</property>
+         <property name="wrap">False</property>
+         <property name="selectable">False</property>
+         <property name="xalign">0.5</property>
+         <property name="yalign">0.5</property>
+         <property name="xpad">0</property>
+         <property name="ypad">0</property>
+         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+         <property name="width_chars">-1</property>
+         <property name="single_line_mode">False</property>
+         <property name="angle">0</property>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkScrolledWindow" id="scrolledwindow2">
+         <property name="visible">True</property>
+         <property name="can_focus">True</property>
+         <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+         <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+         <property name="shadow_type">GTK_SHADOW_IN</property>
+         <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+         <child>
+           <widget class="GtkTextView" id="TextDialogTextView">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="editable">True</property>
+             <property name="overwrite">False</property>
+             <property name="accepts_tab">True</property>
+             <property name="justification">GTK_JUSTIFY_LEFT</property>
+             <property name="wrap_mode">GTK_WRAP_NONE</property>
+             <property name="cursor_visible">True</property>
+             <property name="pixels_above_lines">0</property>
+             <property name="pixels_below_lines">0</property>
+             <property name="pixels_inside_wrap">0</property>
+             <property name="left_margin">0</property>
+             <property name="right_margin">0</property>
+             <property name="indent">0</property>
+             <property name="text" translatable="yes"></property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkDialog" id="UriChoiceDialog">
+  <property name="height_request">280</property>
+  <property name="title" translatable="yes">Uri choice</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_CENTER</property>
+  <property name="modal">True</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+  <property name="has_separator">True</property>
+
+  <child internal-child="vbox">
+    <widget class="GtkVBox" id="dialog-vbox3">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">4</property>
+
+      <child internal-child="action_area">
+       <widget class="GtkHButtonBox" id="dialog-action_area3">
+         <property name="visible">True</property>
+         <property name="layout_style">GTK_BUTTONBOX_END</property>
+
+         <child>
+           <widget class="GtkButton" id="UriChoiceAbortButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">-6</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="UriChoiceSelectedButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">0</property>
+
+             <child>
+               <widget class="GtkAlignment" id="alignment2">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xscale">0</property>
+                 <property name="yscale">0</property>
+                 <property name="top_padding">0</property>
+                 <property name="bottom_padding">0</property>
+                 <property name="left_padding">0</property>
+                 <property name="right_padding">0</property>
+
+                 <child>
+                   <widget class="GtkHBox" id="hbox3">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">2</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image19">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-index</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkLabel" id="label3">
+                         <property name="visible">True</property>
+                         <property name="label" translatable="yes">Try _Selected</property>
+                         <property name="use_underline">True</property>
+                         <property name="use_markup">False</property>
+                         <property name="justify">GTK_JUSTIFY_LEFT</property>
+                         <property name="wrap">False</property>
+                         <property name="selectable">False</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                         <property name="width_chars">-1</property>
+                         <property name="single_line_mode">False</property>
+                         <property name="angle">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="UriChoiceConstantsButton">
+             <property name="visible">True</property>
+             <property name="sensitive">False</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">Try Constants</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">0</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="copyButton">
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-copy</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">0</property>
+           </widget>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="uriChoiceAutoButton">
+             <property name="visible">True</property>
+             <property name="can_default">True</property>
+             <property name="can_focus">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+             <property name="response_id">0</property>
+
+             <child>
+               <widget class="GtkAlignment" id="alignment5">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xscale">0</property>
+                 <property name="yscale">0</property>
+                 <property name="top_padding">0</property>
+                 <property name="bottom_padding">0</property>
+                 <property name="left_padding">0</property>
+                 <property name="right_padding">0</property>
+
+                 <child>
+                   <widget class="GtkHBox" id="hbox16">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">2</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image302">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-ok</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkLabel" id="okLabel">
+                         <property name="visible">True</property>
+                         <property name="label" translatable="yes">bla bla bla</property>
+                         <property name="use_underline">True</property>
+                         <property name="use_markup">False</property>
+                         <property name="justify">GTK_JUSTIFY_LEFT</property>
+                         <property name="wrap">False</property>
+                         <property name="selectable">False</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                         <property name="width_chars">-1</property>
+                         <property name="single_line_mode">False</property>
+                         <property name="angle">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+         <property name="pack_type">GTK_PACK_END</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkVBox" id="vbox2">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">3</property>
+
+         <child>
+           <widget class="GtkLabel" id="UriChoiceLabel">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes">some informative message here ...</property>
+             <property name="use_underline">False</property>
+             <property name="use_markup">False</property>
+             <property name="justify">GTK_JUSTIFY_LEFT</property>
+             <property name="wrap">False</property>
+             <property name="selectable">False</property>
+             <property name="xalign">0.5</property>
+             <property name="yalign">0.5</property>
+             <property name="xpad">0</property>
+             <property name="ypad">0</property>
+             <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+             <property name="width_chars">-1</property>
+             <property name="single_line_mode">False</property>
+             <property name="angle">0</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkScrolledWindow" id="scrolledwindow1">
+             <property name="width_request">400</property>
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+             <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+             <property name="shadow_type">GTK_SHADOW_NONE</property>
+             <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+             <child>
+               <widget class="GtkTreeView" id="UriChoiceTreeView">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="headers_visible">False</property>
+                 <property name="rules_hint">False</property>
+                 <property name="reorderable">False</property>
+                 <property name="enable_search">True</property>
+                 <property name="fixed_height_mode">False</property>
+                 <property name="hover_selection">False</property>
+                 <property name="hover_expand">False</property>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkHBox" id="uriEntryHBox">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">0</property>
+
+             <child>
+               <widget class="GtkLabel" id="label2">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">URI: </property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+                 <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                 <property name="width_chars">-1</property>
+                 <property name="single_line_mode">False</property>
+                 <property name="angle">0</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">False</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkEntry" id="entry1">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="editable">True</property>
+                 <property name="visibility">True</property>
+                 <property name="max_length">0</property>
+                 <property name="text" translatable="yes"></property>
+                 <property name="has_frame">True</property>
+                 <property name="invisible_char">*</property>
+                 <property name="activates_default">False</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">True</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkWindow" id="FindReplWin">
+  <property name="border_width">5</property>
+  <property name="title" translatable="yes">Find &amp; Replace</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_MOUSE</property>
+  <property name="modal">False</property>
+  <property name="resizable">False</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+
+  <child>
+    <widget class="GtkTable" id="table1">
+      <property name="visible">True</property>
+      <property name="n_rows">3</property>
+      <property name="n_columns">2</property>
+      <property name="homogeneous">False</property>
+      <property name="row_spacing">5</property>
+      <property name="column_spacing">0</property>
+
+      <child>
+       <widget class="GtkLabel" id="label17">
+         <property name="visible">True</property>
+         <property name="label" translatable="yes">Find:</property>
+         <property name="use_underline">False</property>
+         <property name="use_markup">False</property>
+         <property name="justify">GTK_JUSTIFY_LEFT</property>
+         <property name="wrap">False</property>
+         <property name="selectable">False</property>
+         <property name="xalign">0</property>
+         <property name="yalign">0.5</property>
+         <property name="xpad">0</property>
+         <property name="ypad">0</property>
+         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+         <property name="width_chars">-1</property>
+         <property name="single_line_mode">False</property>
+         <property name="angle">0</property>
+       </widget>
+       <packing>
+         <property name="left_attach">0</property>
+         <property name="right_attach">1</property>
+         <property name="top_attach">0</property>
+         <property name="bottom_attach">1</property>
+         <property name="x_options">fill</property>
+         <property name="y_options"></property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkLabel" id="label18">
+         <property name="visible">True</property>
+         <property name="label" translatable="yes">Replace with: </property>
+         <property name="use_underline">False</property>
+         <property name="use_markup">False</property>
+         <property name="justify">GTK_JUSTIFY_LEFT</property>
+         <property name="wrap">False</property>
+         <property name="selectable">False</property>
+         <property name="xalign">0</property>
+         <property name="yalign">0.5</property>
+         <property name="xpad">0</property>
+         <property name="ypad">0</property>
+         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+         <property name="width_chars">-1</property>
+         <property name="single_line_mode">False</property>
+         <property name="angle">0</property>
+       </widget>
+       <packing>
+         <property name="left_attach">0</property>
+         <property name="right_attach">1</property>
+         <property name="top_attach">1</property>
+         <property name="bottom_attach">2</property>
+         <property name="x_options">fill</property>
+         <property name="y_options"></property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkEntry" id="findEntry">
+         <property name="visible">True</property>
+         <property name="can_default">True</property>
+         <property name="has_default">True</property>
+         <property name="can_focus">True</property>
+         <property name="has_focus">True</property>
+         <property name="editable">True</property>
+         <property name="visibility">True</property>
+         <property name="max_length">0</property>
+         <property name="text" translatable="yes"></property>
+         <property name="has_frame">True</property>
+         <property name="invisible_char">*</property>
+         <property name="activates_default">False</property>
+       </widget>
+       <packing>
+         <property name="left_attach">1</property>
+         <property name="right_attach">2</property>
+         <property name="top_attach">0</property>
+         <property name="bottom_attach">1</property>
+         <property name="y_options"></property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkEntry" id="replaceEntry">
+         <property name="visible">True</property>
+         <property name="can_focus">True</property>
+         <property name="editable">True</property>
+         <property name="visibility">True</property>
+         <property name="max_length">0</property>
+         <property name="text" translatable="yes"></property>
+         <property name="has_frame">True</property>
+         <property name="invisible_char">*</property>
+         <property name="activates_default">False</property>
+       </widget>
+       <packing>
+         <property name="left_attach">1</property>
+         <property name="right_attach">2</property>
+         <property name="top_attach">1</property>
+         <property name="bottom_attach">2</property>
+         <property name="y_options"></property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHBox" id="hbox19">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">5</property>
+
+         <child>
+           <widget class="GtkVBox" id="vbox9">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">0</property>
+
+             <child>
+               <placeholder/>
+             </child>
+
+             <child>
+               <placeholder/>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="findButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-find</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="findReplButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+
+             <child>
+               <widget class="GtkAlignment" id="alignment13">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xscale">0</property>
+                 <property name="yscale">0</property>
+                 <property name="top_padding">0</property>
+                 <property name="bottom_padding">0</property>
+                 <property name="left_padding">0</property>
+                 <property name="right_padding">0</property>
+
+                 <child>
+                   <widget class="GtkHBox" id="hbox20">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">2</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image357">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-find-and-replace</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkLabel" id="label19">
+                         <property name="visible">True</property>
+                         <property name="label">_Replace</property>
+                         <property name="use_underline">True</property>
+                         <property name="use_markup">False</property>
+                         <property name="justify">GTK_JUSTIFY_LEFT</property>
+                         <property name="wrap">False</property>
+                         <property name="selectable">False</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                         <property name="width_chars">-1</property>
+                         <property name="single_line_mode">False</property>
+                         <property name="angle">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="cancelButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="left_attach">0</property>
+         <property name="right_attach">2</property>
+         <property name="top_attach">2</property>
+         <property name="bottom_attach">3</property>
+         <property name="y_padding">5</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkWindow" id="NewDevelWin">
+  <property name="title" translatable="yes">Create development</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_CENTER_ALWAYS</property>
+  <property name="modal">True</property>
+  <property name="resizable">False</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_UTILITY</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+
+  <child>
+    <widget class="GtkVBox" id="vbox10">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child>
+       <widget class="GtkTable" id="table2">
+         <property name="border_width">3</property>
+         <property name="visible">True</property>
+         <property name="n_rows">2</property>
+         <property name="n_columns">3</property>
+         <property name="homogeneous">False</property>
+         <property name="row_spacing">5</property>
+         <property name="column_spacing">5</property>
+
+         <child>
+           <widget class="GtkLabel" id="label20">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes">Name</property>
+             <property name="use_underline">False</property>
+             <property name="use_markup">False</property>
+             <property name="justify">GTK_JUSTIFY_LEFT</property>
+             <property name="wrap">False</property>
+             <property name="selectable">False</property>
+             <property name="xalign">0</property>
+             <property name="yalign">0.5</property>
+             <property name="xpad">0</property>
+             <property name="ypad">0</property>
+             <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+             <property name="width_chars">-1</property>
+             <property name="single_line_mode">False</property>
+             <property name="angle">0</property>
+           </widget>
+           <packing>
+             <property name="left_attach">0</property>
+             <property name="right_attach">1</property>
+             <property name="top_attach">0</property>
+             <property name="bottom_attach">1</property>
+             <property name="x_options">fill</property>
+             <property name="y_options"></property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkLabel" id="label21">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes">Root directory</property>
+             <property name="use_underline">False</property>
+             <property name="use_markup">False</property>
+             <property name="justify">GTK_JUSTIFY_LEFT</property>
+             <property name="wrap">False</property>
+             <property name="selectable">False</property>
+             <property name="xalign">0</property>
+             <property name="yalign">0.5</property>
+             <property name="xpad">0</property>
+             <property name="ypad">0</property>
+             <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+             <property name="width_chars">-1</property>
+             <property name="single_line_mode">False</property>
+             <property name="angle">0</property>
+           </widget>
+           <packing>
+             <property name="left_attach">0</property>
+             <property name="right_attach">1</property>
+             <property name="top_attach">1</property>
+             <property name="bottom_attach">2</property>
+             <property name="x_options">fill</property>
+             <property name="y_options"></property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkEntry" id="nameEntry">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="editable">True</property>
+             <property name="visibility">True</property>
+             <property name="max_length">0</property>
+             <property name="text" translatable="yes"></property>
+             <property name="has_frame">True</property>
+             <property name="invisible_char">*</property>
+             <property name="activates_default">False</property>
+           </widget>
+           <packing>
+             <property name="left_attach">1</property>
+             <property name="right_attach">2</property>
+             <property name="top_attach">0</property>
+             <property name="bottom_attach">1</property>
+             <property name="y_options"></property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkEntry" id="rootEntry">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="editable">True</property>
+             <property name="visibility">True</property>
+             <property name="max_length">0</property>
+             <property name="text" translatable="yes"></property>
+             <property name="has_frame">True</property>
+             <property name="invisible_char">*</property>
+             <property name="activates_default">False</property>
+           </widget>
+           <packing>
+             <property name="left_attach">1</property>
+             <property name="right_attach">2</property>
+             <property name="top_attach">1</property>
+             <property name="bottom_attach">2</property>
+             <property name="y_options"></property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="chooseRootButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">...</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="left_attach">2</property>
+             <property name="right_attach">3</property>
+             <property name="top_attach">1</property>
+             <property name="bottom_attach">2</property>
+             <property name="x_options">fill</property>
+             <property name="y_options"></property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHSeparator" id="hseparator1">
+         <property name="visible">True</property>
+       </widget>
+       <packing>
+         <property name="padding">2</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHBox" id="hbox21">
+         <property name="border_width">3</property>
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">5</property>
+
+         <child>
+           <widget class="GtkVBox" id="vbox11">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">0</property>
+
+             <child>
+               <placeholder/>
+             </child>
+
+             <child>
+               <placeholder/>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="addButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-add</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="cancelButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-cancel</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkWindow" id="DevelListWin">
+  <property name="title" translatable="yes">Developments</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_CENTER</property>
+  <property name="modal">False</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="decorated">True</property>
+  <property name="skip_taskbar_hint">False</property>
+  <property name="skip_pager_hint">False</property>
+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>
+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+  <property name="focus_on_map">True</property>
+
+  <child>
+    <widget class="GtkVBox" id="vbox12">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child>
+       <widget class="GtkScrolledWindow" id="scrolledwindow10">
+         <property name="visible">True</property>
+         <property name="can_focus">True</property>
+         <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+         <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+         <property name="shadow_type">GTK_SHADOW_IN</property>
+         <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+         <child>
+           <widget class="GtkTreeView" id="developmentsTreeview">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="headers_visible">False</property>
+             <property name="rules_hint">False</property>
+             <property name="reorderable">False</property>
+             <property name="enable_search">True</property>
+             <property name="fixed_height_mode">False</property>
+             <property name="hover_selection">False</property>
+             <property name="hover_expand">False</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHSeparator" id="hseparator2">
+         <property name="visible">True</property>
+       </widget>
+       <packing>
+         <property name="padding">2</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHBox" id="buttonsHbox">
+         <property name="border_width">3</property>
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">4</property>
+
+         <child>
+           <widget class="GtkVBox" id="vbox13">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">0</property>
+
+             <child>
+               <placeholder/>
+             </child>
+
+             <child>
+               <placeholder/>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="newButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-new</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="deleteButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-delete</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="buildButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+
+             <child>
+               <widget class="GtkAlignment" id="alignment14">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xscale">0</property>
+                 <property name="yscale">0</property>
+                 <property name="top_padding">0</property>
+                 <property name="bottom_padding">0</property>
+                 <property name="left_padding">0</property>
+                 <property name="right_padding">0</property>
+
+                 <child>
+                   <widget class="GtkHBox" id="hbox23">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">2</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image358">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-execute</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkLabel" id="label22">
+                         <property name="visible">True</property>
+                         <property name="label" translatable="yes">_Build</property>
+                         <property name="use_underline">True</property>
+                         <property name="use_markup">False</property>
+                         <property name="justify">GTK_JUSTIFY_LEFT</property>
+                         <property name="wrap">False</property>
+                         <property name="selectable">False</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                         <property name="width_chars">-1</property>
+                         <property name="single_line_mode">False</property>
+                         <property name="angle">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="cleanButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+
+             <child>
+               <widget class="GtkAlignment" id="alignment15">
+                 <property name="visible">True</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xscale">0</property>
+                 <property name="yscale">0</property>
+                 <property name="top_padding">0</property>
+                 <property name="bottom_padding">0</property>
+                 <property name="left_padding">0</property>
+                 <property name="right_padding">0</property>
+
+                 <child>
+                   <widget class="GtkHBox" id="hbox24">
+                     <property name="visible">True</property>
+                     <property name="homogeneous">False</property>
+                     <property name="spacing">2</property>
+
+                     <child>
+                       <widget class="GtkImage" id="image359">
+                         <property name="visible">True</property>
+                         <property name="stock">gtk-clear</property>
+                         <property name="icon_size">4</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+
+                     <child>
+                       <widget class="GtkLabel" id="label23">
+                         <property name="visible">True</property>
+                         <property name="label" translatable="yes">C_lean</property>
+                         <property name="use_underline">True</property>
+                         <property name="use_markup">False</property>
+                         <property name="justify">GTK_JUSTIFY_LEFT</property>
+                         <property name="wrap">False</property>
+                         <property name="selectable">False</property>
+                         <property name="xalign">0.5</property>
+                         <property name="yalign">0.5</property>
+                         <property name="xpad">0</property>
+                         <property name="ypad">0</property>
+                         <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>
+                         <property name="width_chars">-1</property>
+                         <property name="single_line_mode">False</property>
+                         <property name="angle">0</property>
+                       </widget>
+                       <packing>
+                         <property name="padding">0</property>
+                         <property name="expand">False</property>
+                         <property name="fill">False</property>
+                       </packing>
+                     </child>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="closeButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label">gtk-close</property>
+             <property name="use_stock">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="focus_on_click">True</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+</glade-interface>

diff --git a/helm/matita/matita.gtkrc b/helm/matita/matita.gtkrc
new file mode 100644 (file)
index 0000000..91081c3
--- /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 "<ctrl>b" { "move-cursor" (logical-positions, -1, 0) }
+  bind "<shift><ctrl>b" { "move-cursor" (logical-positions, -1, 1) }
+  bind "<ctrl>f" { "move-cursor" (logical-positions, 1, 0) }
+  bind "<shift><ctrl>f" { "move-cursor" (logical-positions, 1, 1) }
+
+  bind "<alt>b" { "move-cursor" (words, -1, 0) }
+  bind "<shift><alt>b" { "move-cursor" (words, -1, 1) }
+  bind "<alt>f" { "move-cursor" (words, 1, 0) }
+  bind "<shift><alt>f" { "move-cursor" (words, 1, 1) }
+
+  bind "<ctrl>a" { "move-cursor" (paragraph-ends, -1, 0) }
+  bind "<shift><ctrl>a" { "move-cursor" (paragraph-ends, -1, 1) }
+  bind "<ctrl>e" { "move-cursor" (paragraph-ends, 1, 0) }
+  bind "<shift><ctrl>e" { "move-cursor" (paragraph-ends, 1, 1) }
+
+  bind "<ctrl>w" { "cut-clipboard" () }
+  bind "<ctrl>y" { "paste-clipboard" () }
+
+  bind "<ctrl>d" { "delete-from-cursor" (chars, 1) }
+  bind "<alt>d" { "delete-from-cursor" (word-ends, 1) }
+  bind "<ctrl>k" { "delete-from-cursor" (paragraph-ends, 1) }
+  bind "<alt>backslash" { "delete-from-cursor" (whitespace, 1) }
+
+  bind "<alt>space" { "delete-from-cursor" (whitespace, 1)
+                      "insert-at-cursor" (" ") }
+  bind "<alt>KP_Space" { "delete-from-cursor" (whitespace, 1)
+                         "insert-at-cursor" (" ")  }
+
+  #
+  # Some non-Emacs keybindings people are attached to
+  #
+  bind "<ctrl>u" {
+     "move-cursor" (paragraph-ends, -1, 0)
+     "delete-from-cursor" (paragraph-ends, 1)
+  }
+  bind "<ctrl>h" { "delete-from-cursor" (chars, -1) }
+  bind "<ctrl>w" { "delete-from-cursor" (word-ends, -1) }
+}
+
+#
+# Bindings for GtkTextView
+#
+binding "gtk-emacs-text-view"
+{
+#  bind "<ctrl>p" { "move-cursor" (display-lines, -1, 0) }
+  bind "<shift><ctrl>p" { "move-cursor" (display-lines, -1, 1) }
+#  bind "<ctrl>n" { "move-cursor" (display-lines, 1, 0) }
+  bind "<shift><ctrl>n" { "move-cursor" (display-lines, 1, 1) }
+
+  bind "<ctrl>space" { "set-anchor" () }
+  bind "<ctrl>KP_Space" { "set-anchor" () }
+}
+
+#
+# Bindings for GtkTreeView
+#
+binding "gtk-emacs-tree-view"
+{
+  bind "<ctrl>s" { "start-interactive-search" () }
+  bind "<ctrl>f" { "move-cursor" (logical-positions, 1) }
+  bind "<ctrl>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 (file)
index 0000000..0c181ee
--- /dev/null
+++ b/helm/matita/matita.lang
@@ -0,0 +1,186 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE language SYSTEM "language.dtd">
+<language _name="grafite" version="1.0" _section="Sources" mimetypes="text/x-matita">
+
+  <escape-char>\</escape-char>
+
+  <block-comment _name = "Block Comment" style = "Comment">
+    <start-regex>\(\*</start-regex>
+    <end-regex>\*\)</end-regex>
+  </block-comment>
+  
+  <block-comment _name = "Commented Code" style = "Comment">
+    <start-regex>\(\*\*</start-regex>
+    <end-regex>\*\*\)</end-regex>
+  </block-comment>
+
+  <keyword-list _name = "Theorem Kinds" style = "Keyword" case-sensitive="TRUE">
+    <keyword>theorem</keyword>
+    <keyword>definition</keyword>
+    <keyword>lemma</keyword>
+    <keyword>fact</keyword>
+    <keyword>remark</keyword>
+    <keyword>variant</keyword>
+  </keyword-list>
+    
+  <keyword-list _name = "Commands" style = "Keyword" case-sensitive="TRUE">
+    <keyword>alias</keyword>
+    <keyword>and</keyword>
+    <keyword>as</keyword>
+    <keyword>coercion</keyword>
+    <keyword>coinductive</keyword>
+    <keyword>corec</keyword>
+    <keyword>default</keyword>
+    <keyword>for</keyword>
+    <keyword>include</keyword>
+    <keyword>inductive</keyword>
+    <keyword>in</keyword>
+    <keyword>interpretation</keyword>
+    <keyword>let</keyword>
+    <keyword>match</keyword>
+    <keyword>names</keyword>
+    <keyword>notation</keyword>
+    <keyword>on</keyword>
+    <keyword>qed</keyword>
+    <keyword>rec</keyword>
+    <keyword>record</keyword>
+    <keyword>return</keyword>
+    <keyword>to</keyword>
+    <keyword>using</keyword>
+    <keyword>with</keyword>
+  </keyword-list>
+
+  <pattern-item _name = "Command [" style = "Keyword">
+    <regex>\[</regex>
+  </pattern-item>
+  <pattern-item _name = "Command |" style = "Keyword">
+    <regex>\|</regex>
+  </pattern-item>
+  <pattern-item _name = "Command ]" style = "Keyword">
+    <regex>\]</regex>
+  </pattern-item>
+  <pattern-item _name = "Command {" style = "Keyword">
+    <regex>\{</regex>
+  </pattern-item>
+  <pattern-item _name = "Command }" style = "Keyword">
+    <regex>\}</regex>
+  </pattern-item>
+  <pattern-item _name = "Notation ast mark" style = "Keyword">
+    <regex>@</regex>
+  </pattern-item>
+  <pattern-item _name = "Notation meta mark" style = "Keyword">
+    <regex>\$</regex>
+  </pattern-item>
+
+  <keyword-list _name = "Sorts" style = "Data Type" case-sensitive="TRUE">
+    <keyword>Set</keyword>
+    <keyword>Prop</keyword>
+    <keyword>Type</keyword>
+  </keyword-list>
+
+  <keyword-list _name = "Tactics" style = "Others 2" case-sensitive="TRUE">
+    <keyword>absurd</keyword>
+    <keyword>apply</keyword>
+    <keyword>assumption</keyword>
+    <keyword>auto</keyword>
+    <keyword>paramodulation</keyword>
+    <keyword>clear</keyword>
+    <keyword>clearbody</keyword>
+    <keyword>change</keyword>
+    <keyword>compare</keyword>
+    <keyword>constructor</keyword>
+    <keyword>contradiction</keyword>
+    <keyword>cut</keyword>
+    <keyword>decide</keyword> <keyword>equality</keyword> <!-- CSC: ??? -->
+    <keyword>decompose</keyword>
+    <keyword>discriminate</keyword>
+    <keyword>elim</keyword>
+    <keyword>elimType</keyword>
+    <keyword>exact</keyword>
+    <keyword>exists</keyword>
+    <keyword>fail</keyword>
+    <keyword>fold</keyword>
+    <keyword>fourier</keyword>
+    <keyword>fwd</keyword>
+    <keyword>generalize</keyword>
+    <keyword>goal</keyword>
+    <keyword>id</keyword>
+    <keyword>injection</keyword>
+    <keyword>intro</keyword>
+    <keyword>intros</keyword>
+    <keyword>lapply</keyword>
+    <keyword>left</keyword>
+    <keyword>letin</keyword>
+    <keyword>normalize</keyword>
+    <keyword>reduce</keyword>
+    <keyword>reflexivity</keyword>
+    <keyword>replace</keyword>
+    <keyword>rewrite</keyword>
+    <keyword>ring</keyword>
+    <keyword>right</keyword>
+    <keyword>symmetry</keyword>
+    <keyword>simplify</keyword>
+    <keyword>split</keyword>
+    <keyword>to</keyword>
+    <keyword>transitivity</keyword>
+    <keyword>unfold</keyword>
+    <keyword>whd</keyword>
+  </keyword-list>
+
+  <keyword-list _name = "Tacticals" style = "Keyword" case-sensitive="TRUE">
+    <keyword>try</keyword>
+    <keyword>solve</keyword>
+    <keyword>do</keyword>
+    <keyword>repeat</keyword>
+    <keyword>first</keyword>
+  </keyword-list>
+
+
+  <keyword-list _name = "Matita Macro" style = "Others 3" case-sensitive="TRUE">
+    <keyword>print</keyword>
+    <keyword>check</keyword>
+    <keyword>hint</keyword>
+    <keyword>quit</keyword>
+    <keyword>set</keyword>
+  </keyword-list>
+  
+  <keyword-list _name = "Whelp Macro" style = "Others 3"
+    case-sensitive="TRUE" 
+    beginning-regex="whelp *" 
+    match-empty-string-at-beginning="FALSE"
+    match-empty-string-at-end="FALSE" >
+    <keyword>elim</keyword>
+    <keyword>hint</keyword>
+    <keyword>instance</keyword>
+    <keyword>locate</keyword>
+    <keyword>match</keyword>
+  </keyword-list>
+    
+  <keyword-list _name = "TeX Macro" style = "Preprocessor" 
+    case-sensitive="TRUE" 
+    beginning-regex="\\" 
+    match-empty-string-at-beginning="FALSE"
+    match-empty-string-at-end="FALSE" >
+     <keyword>def</keyword>
+     <keyword>forall</keyword>
+     <keyword>lambda</keyword>
+     <keyword>to</keyword>
+     <keyword>exists</keyword>
+     <keyword>Rightarrow</keyword>
+     <keyword>Assign</keyword>
+     <keyword>land</keyword>
+     <keyword>lor</keyword>
+     <keyword>lnot</keyword>
+     <keyword>liff</keyword>
+     <keyword>subst</keyword>
+     <keyword>vdash</keyword>
+     <keyword>iforall</keyword>
+     <keyword>iexists</keyword>
+  </keyword-list>
+
+  <string _name = "String" style = "String" >
+    <start-regex>&quot;</start-regex>
+    <end-regex>&quot;</end-regex>
+  </string>
+ 
+</language>

diff --git a/helm/matita/matita.ma.templ b/helm/matita/matita.ma.templ
new file mode 100644 (file)
index 0000000..ec1bc80
--- /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 (file)
index 0000000..016d693
--- /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 (file)
index 0000000..ce34e40
--- /dev/null
+++ b/helm/matita/matita.txt
@@ -0,0 +1,426 @@
+  Ferruccio ha cambiato matita.lang:
+  >      <keyword>iforall</keyword>
+  >      <keyword>iexists</keyword>
+
+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 <stato, statement>. 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 (file)
index 0000000..f0d8ee4
--- /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 (file)
index 0000000..a3c54de
--- /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 (file)
index 0000000..28f25fd
--- /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\" \"<uri>\".' 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 (file)
index 0000000..9d8c773
--- /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 (file)
index 0000000..5534066
--- /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 (file)
index 0000000..1affd2a
--- /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 (file)
index 0000000..03e5058
--- /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.\n<i>Should I generate it?</i>"
+          (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 <b>unsaved</b>!\n\n"^
+         "<i>Do you want to save the script before continuing?</i>")
+    ()
+
+(** 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 :> <check_widgets: unit -> 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 (file)
index 0000000..8c9064e
--- /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 (file)
index 0000000..1b9d17c
--- /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 (file)
index 0000000..fec223b
--- /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),
+          ("<path> 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 (file)
index 0000000..9d86712
--- /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 (file)
index 0000000..3c4997a
--- /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.
+   * <m:mi xlink:href="...">bool</m:mi> *)
+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 "<b>%s</b>" (aux m)
+    | `Closed m -> sprintf "<s>%s</s>" (aux m)
+    | `Shift (pos, m) -> sprintf "|<sub>%d</sub>: %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 (file)
index 0000000..ea0c077
--- /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 (file)
index 0000000..0c4329e
--- /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 (file)
index 0000000..170a87c
--- /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 (file)
index 0000000..4c53f11
--- /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 <b>" ^ name ^ "</b>.\n\n" ^
+          "<i>Should I compile it and Its dependencies?</i>"
+        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 <b>not</b> handled by a development.\n" ^
+         "All dependencies are automatically solved for a development.\n\n" ^
+         "<i>Do you want to set up a development?</i>"
+        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 (file)
index 0000000..8eb6d8d
--- /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 (file)
index 0000000..13543db
--- /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 (file)
index 0000000..be77c44
--- /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 (file)
index 0000000..5599ba6
--- /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 (file)
index 0000000..3567c33
--- /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 (file)
index 0000000..636c51d
--- /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 (file)
index 0000000..826a4a2
--- /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 (file)
index 0000000..45d57a8
--- /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 (file)
index 0000000..48011c0
--- /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 (file)
index 0000000..45d57a8
--- /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 (file)
index 0000000..9eab0f6
--- /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 (file)
index 0000000..8eba26f
--- /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 "\e\\[[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 (file)
index 0000000..4aaab47
--- /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 (file)
index 0000000..0aba1e9
--- /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 (file)
index 0000000..d484490
--- /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 (file)
index 0000000..a455085
--- /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 (file)
index 0000000..4b4c1e8
--- /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 (file)
index 0000000..5ad50de
--- /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 <<EOT
+  REPORT FOR `date`
+  http://mowgli.cs.unibo.it/~tassi/bench.php
+
+  PERFORMANCE LOSS DETECTED (MARK $MARK vs MARK $LASTMARK)
+  is $CUR_TIME sec 
+  was $OLD_TIME sec
+
+EOT
+fi
+
+CUR_FAIL=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLADDERPHP -- $COMMONPHP "select count(distinct test) from bench where mark = \"$MARK\" and result = 'fail';"`
+OLD_FAIL=`/usr/bin/php4 -c /etc/php4/apache/php.ini -f $SHELLADDERPHP -- $COMMONPHP "select count(distinct test) from bench where mark = \"$LASTMARK\" and result = 'fail';"`
+
+if [ $CUR_FAIL -gt $OLD_FAIL ]; then
+  cat <<EOT
+  REPORT FOR `date`
+  http://mowgli.cs.unibo.it/~tassi/bench.php
+
+  MORE BROKEN TESTS DETECTED (MARK $MARK vs MARK $LASTMARK)
+  now broken:
+  `echo "select distinct test from bench where mark = \"$MARK\" and result = 'fail';" | mysql -u helm -h mowgli.cs.unibo.it matita`
+  were broken:
+  `echo "select distinct test from bench where mark = \"$LASTMARK\" and result = 'fail';" | mysql -u helm -h mowgli.cs.unibo.it matita`
+  
+EOT
+
+fi
+
+cd $OLD
+#rm -rf $TMPDIRNAME
+

diff --git a/helm/matita/scripts/do_tests.sh b/helm/matita/scripts/do_tests.sh
new file mode 100755 (executable)
index 0000000..687b7f8
--- /dev/null
+++ b/helm/matita/scripts/do_tests.sh
@@ -0,0 +1,85 @@
+#!/bin/bash
+
+OK="\e[32mOK\e[0m"
+FAIL="\e[31mFAIL\e[0m"
+
+if [ "$1" = "-no-color" ]; then
+  shift
+  OK="OK"
+  FAIL="FAIL"
+fi
+if [ "$1" = "-twice" ]; then
+  shift
+  TWICE=1
+fi
+if [ "$1" = "-keep-logs" ]; then
+  shift
+  KEEP=1
+fi
+
+COMPILER=$1
+shift
+CLEANCOMPILER=`echo $COMPILER | cut -d ' ' -f 1`
+CLEANER=$1
+shift
+LOGFILE=$1
+shift
+EXPECTED=$1
+shift
+TODO="$@"
+
+if [ -z "$COMPILER" -o -z "$CLEANER" -o -z "$LOGFILE" -o -z "$EXPECTED" -o -z "$TODO" ]; then
+  echo
+  echo "usage: "
+  echo "  do_tests.sh [-no-color] [-twice] [-keep-logs] ./compiler ./cleaner logfile expected_result test.ma ..."
+  echo
+  echo "options:  "
+  echo "  -no-color Do not use vt100 colors"
+  echo "  -twice    Run each test twice but show only the second run times"
+  echo "  -keep-logs Do not dele __* files"
+  echo
+  echo "If expected_result is OK the result will be OK if the test compiles."
+  echo "Otherwise if expected_result is FAIL the result will be OK if the test"
+  echo "does not compile and the generated output is equal to test.log."
+  echo "The value of the DO_TESTS_EXTRA evironment variable"
+  echo "will be appended to each line."
+  exit 1
+fi
+
+
+export TIMEFORMAT="%2lR %2lU %2lS"
+for T in $TODO; do
+  TT=`echo $T | sed s?/?.?`.not_for_matita
+  LOG=__log_$TT
+  DIFF=__diff_$TT
+  printf "$CLEANCOMPILER\t%-30s   " $T
+  if [ "$TWICE" = "1" ]; then
+    $CLEANER $T 1>/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 (file)
index 0000000..d62a6a3
--- /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 (executable)
index 0000000..eca457e
--- /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 (file)
index 0000000..2ee5408
--- /dev/null
+++ b/helm/matita/scripts/public_html/bench.php
@@ -0,0 +1,147 @@
+<?php require("common.php"); 
+  
+// syntax
+//
+// queries ::= query | query "###" queries
+// query ::= name "@@@" sql
+//
+$limits = array("20","50","100");
+  
+$quey_all = urlencode("Whole content:@@@select * from bench order by mark desc***");
+$query_fail = urlencode(
+  "Number of failures@@@" .
+  "select mark, count(distinct test) as fail_no from bench where result = 'fail' group by mark order by mark desc***"
+  . "###" . 
+  "Tests failed@@@" .
+  "select distinct mark, test, result from bench where result = 'fail' order by mark desc***" 
+);
+$query_gc = urlencode(
+  "GC usage @@@" .
+  "select bench.mark, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time)) - SUM(TIME_TO_SEC(bench1.time))) as gc_hoverhead from bench, bench as bench1 where bench.mark = bench1.mark and bench.test = bench1.test and bench.options = 'gc-on' and bench1.options = 'gc-off' and bench.compilation = bench1.compilation group by mark***"
+  . "###" . 
+  "GC usage (opt)@@@" .
+  "select bench.mark, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time)) - SUM(TIME_TO_SEC(bench1.time))) as gc_hoverhead from bench, bench as bench1 where bench.mark = bench1.mark and bench.test = bench1.test and bench.options = 'gc-on' and bench1.options = 'gc-off' and bench.compilation = bench1.compilation and bench.compilation = 'opt' group by mark***"
+  . "###" . 
+  "GC usage (byte)@@@" .
+  "select bench.mark, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time)) - SUM(TIME_TO_SEC(bench1.time))) as gc_hoverhead from bench, bench as bench1 where bench.mark = bench1.mark and bench.test = bench1.test and bench.options = 'gc-on' and bench1.options = 'gc-off' and bench.compilation = bench1.compilation and bench.compilation = 'byte' group by mark***"
+  
+);
+$query_auto = urlencode(
+  "Auto (with GC)@@@select mark, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time))) as time from bench where test='auto.ma' and options = 'gc-on' group by mark order by mark desc***"
+  . "###" . 
+  "Auto (without GC)@@@select mark, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time))) as time from bench where test='auto.ma' and options = 'gc-off' group by mark order by mark desc***"
+  #  . "###" . 
+  # "GC overhead@@@select bench.mark, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time)) - SUM(TIME_TO_SEC(bench1.time))) as gc_hoverhead from bench, bench as bench1 where bench.mark = bench1.mark and bench.test = bench1.test and bench.options = 'gc-on' and bench1.options = 'gc-off' and bench.compilation = bench1.compilation and bench.test = 'auto.ma' group by mark"
+);
+
+$query_csc = urlencode("Performances (byte and GC) per mark@@@select bench.mark ,bench_svn.revision as revision, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time))) as sum_time, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.timeuser))) as sum_timeuser from bench, bench_svn where bench.options = 'gc-on' and bench.compilation = 'byte' and bench_svn.mark = bench.mark group by bench.mark order by bench.mark desc"
+);
+
+$query_csc_opt = urlencode("Performances (opt and GC) per mark@@@select bench.mark,bench_svn.revision as revision, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.time))) as sum_time, SEC_TO_TIME(SUM(TIME_TO_SEC(bench.timeuser))) as sum_timeuser from bench, bench_svn where bench.options = 'gc-on' and bench.compilation = 'opt' and bench_svn.mark = bench.mark group by bench.mark order by bench.mark desc"
+);
+
+$query_total = urlencode(
+  
+"Max N@@@select COUNT(DISTINCT test) as MAX from bench group by mark order by MAX desc LIMIT 0,1;"
+  . "###" .
+  "Number of compiled tests@@@select mark, COUNT(DISTINCT test) as N from bench group by mark order by mark desc***"
+);
+
+function minus1_to_all($s){
+  if ($s == "-1") 
+    return "all";
+  else 
+    return $s;
+}
+
+function links_of($name,$q,$limits){
+  echo "<li>$name :&nbsp;&nbsp;&nbsp;";
+  if (strpos($q, urlencode("***")) === false) {
+    echo "<a href=\"showquery.php?query=$q;\">all</a>";
+  } else {
+    foreach($limits as $l) {
+      $q1 = str_replace(urlencode("***"), " LIMIT 0,$l", $q);
+      echo "<a href=\"showquery.php?query=$q1;\">" . 
+            minus1_to_all($l) . "</a>&nbsp;&nbsp;";
+    }
+      $q1 = str_replace(urlencode("***"), " ", $q);
+      echo "<a href=\"showquery.php?query=$q1;\">" . 
+            minus1_to_all("-1") . "</a>&nbsp;&nbsp;";
+  }
+  echo "</li>";
+}
+
+?>
+
+<html>
+  <head>
+  <link type="text/css" rel="stylesheet" href="style.css"/>
+  </head>
+  <body>
+    <h1>QUERY the benchmark system</h1>
+    <h2>Common Queries</h2>
+    <p>
+      <ul>
+      <? links_of("Broken tests",$query_fail,$limits) ?>
+      <? links_of("Garbage collector killer",$query_gc,$limits) ?>
+      <? links_of("Auto performances",$query_auto,$limits) ?>
+      <? links_of("Global performances (bytecode)",$query_csc,$limits) ?>
+      <? links_of("Global performances (nativecode)",$query_csc_opt,$limits) ?>
+      <? links_of("Number of compiled tests",$query_total,$limits) ?>
+      <? links_of("All table contents",$quey_all,$limits) ?>
+      </ul>
+    </p>
+    <h2>Custom Query</h2>
+    <form action="composequery.php" method="get">
+    <table>
+  <tr>
+    <td>Marks:</td>
+    <td> 
+      <? array_to_combo("mark",
+            query("select distinct mark from bench order by mark desc;")); ?>
+    </td>
+  </tr>
+  <tr>
+    <td>Compilations:</td>
+    <td> 
+      <? array_to_combo("compilation",
+           query("select distinct compilation from bench;")); ?>
+    </td>
+  </tr>
+  <tr>
+    <td>Options:</td>
+    <td>  
+      <?array_to_combo("options",query("select distinct options from bench;"));?>
+    </td>
+  </tr>
+  <tr>
+    <td>Tests:</td>
+    <td>    
+      <? array_to_combo("test",query("select distinct test from bench;")); ?>
+    </td>
+  </tr>
+  <tr>
+    <td>Test results:</td>
+    <td>
+      <? array_to_combo("result",query("select distinct result from bench;")); ?>
+    </td>
+  </tr>
+  <tr>
+    <td>Group By: </td>
+    <td>
+      <? array_to_combo("groupby",array(array("mark","options"))); ?>
+    </td>
+  </tr>
+  <tr>
+    <td>Limit: </td>
+    <td>
+      <? array_to_combo("limit",array($limits)); ?>
+    </td>
+  </tr>
+  <tr>
+    <td><input type="submit" value="Submit" class="button" /></td>
+  </tr>
+ </table>
+</form>
+</body>
+</html>

diff --git a/helm/matita/scripts/public_html/common.php b/helm/matita/scripts/public_html/common.php
new file mode 100644 (file)
index 0000000..f2a9be0
--- /dev/null
+++ b/helm/matita/scripts/public_html/common.php
@@ -0,0 +1,89 @@
+<?php
+
+function query($q) {
+  $db = mysql_pconnect("localhost","helm");
+  mysql_select_db("matita");
+  if (preg_match("/TIME_TO_SEC/",$q)) {
+    $group_by = true;
+    $q = preg_replace("/group by bench.mark/","",$q);
+    $q = preg_replace("/SEC_TO_TIME\(SUM\(TIME_TO_SEC\(([^)]+)\)\)\)/","$1",$q);
+  }
+  $rc = mysql_query($q,$db);
+  if(!$rc) {
+    die("Query failed: " . mysql_error());
+  }
+  $result = array();
+  while( $row = mysql_fetch_array($rc, MYSQL_ASSOC)){
+    $result[] = $row;
+  }
+  mysql_free_result($rc);
+  mysql_close($db);
+  if ($group_by){
+    return group_array_by_mark($result);
+  } else {
+    return $result;
+  }
+}
+
+function time_2_cents($t) {
+  $matches = array();
+  $rex = "/^(\d+)m(\d\d?)\.(\d{2})s$/";
+  $m = preg_match($rex,$t,$matches);
+  if ( $m == 0 ) exit(1);
+  $t_minutes = $matches[1];
+  $t_secs = $matches[2];
+  $t_cents = $matches[3];
+  return ((int) $t_cents) + ((int) $t_secs) * 100 + ((int)$t_minutes) * 6000 ;
+}
+
+function sum_time($t1, $t2) {
+  $matches1 = array();
+  $matches2 = array();
+  $rex = "/^(\d+)m(\d\d?)\.(\d{2})s$/";
+  $m1 = preg_match($rex,$t1,$matches1);
+  $m2 = preg_match($rex,$t2,$matches2);
+  if ($m1 != 0 && $m2 != 0) {
+    $t1_minutes = $matches1[1];
+    $t2_minutes = $matches2[1];
+    $t1_secs = $matches1[2];
+    $t2_secs = $matches2[2];
+    $t1_cents = $matches1[3];
+    $t2_cents = $matches2[3];
+    $time1 = ((int) $t1_cents) + ((int) $t1_secs) * 100 + ((int)$t1_minutes) * 6000 ;
+    $time2 = ((int) $t2_cents) + ((int) $t2_secs) * 100 + ((int)$t2_minutes) * 6000 ;
+    $sum = $time1 + $time2;
+    $min = $sum / 6000;
+    $sec = ($sum % 6000) / 100;
+    $cent = ($sum % 6000) % 100;
+    return sprintf("%dm%02d.%02ds",$min,$sec,$cent);
+  } else {
+    return $t1;
+  }
+}
+
+function group_array_by_mark($a) {
+  $rc = array();
+  foreach ($a as $x) {
+    if ($rc[$x['mark']] == NULL) {
+      $rc[$x['mark']] = $x;
+    } else {
+      foreach ($rc[$x['mark']] as $k => $v) {
+        $rc[$x['mark']][$k] = sum_time($v, $x[$k]);
+      }
+    }
+  }
+  return array_values($rc);
+}
+  
+function array_to_combo($l,$a) {
+  echo "<select name=\"$l\">";
+  echo "<option value=\"--\">--</option>";
+  foreach ($a as $k => $v) {
+    foreach( array_keys($v) as $k1 => $i) {
+      echo "<option value=\"{$v[$i]}\">{$v[$i]}</option>";
+    }
+  }
+  echo "</select>";
+}
+
+?>

diff --git a/helm/matita/scripts/public_html/composequery.php b/helm/matita/scripts/public_html/composequery.php
new file mode 100644 (file)
index 0000000..49a943e
--- /dev/null
+++ b/helm/matita/scripts/public_html/composequery.php
@@ -0,0 +1,46 @@
+<?php require("common.php"); 
+  
+  $c = array("mark", "options", "test", "result", "compilation");
+
+  function clause_for($c) {
+    $fst = true;
+    $rc = "";
+    foreach($c as $fake => $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 (file)
index 0000000..12fd7be
--- /dev/null
+++ b/helm/matita/scripts/public_html/index.html
@@ -0,0 +1,15 @@
+<?php require("common.php"); ?>
+
+<html>
+  <head>
+  <link type="text/css" rel="stylesheet" href="style.css"/>
+  </head>
+  <body>
+    <h1>MATITA BENCHMARKING SYSTEM</h1>
+    <p> 
+    <center> <!-- Yes, It sucks! :P -->
+      <a href="bench.php">Go to the benchmark query page</a>
+    </center>
+    </p>
+  </body>
+</html>

diff --git a/helm/matita/scripts/public_html/showquery.php b/helm/matita/scripts/public_html/showquery.php
new file mode 100644 (file)
index 0000000..e7db764
--- /dev/null
+++ b/helm/matita/scripts/public_html/showquery.php
@@ -0,0 +1,62 @@
+<?php require("common.php"); 
+
+  $query = stripslashes($_GET['query']);
+
+  $nqs = explode('###',$query);
+
+  $qs = array();
+  foreach($nqs as $v){
+    $x = explode("@@@",$v);
+    $qs[$x[0]] = $x[1];
+  }
+
+function prettify($s) {
+  if (preg_match("/^[0-9]{12}$/",$s)) {
+    $year = substr($s,0,4);
+    $month = substr($s,4,2);
+    $day = substr($s,6,2);
+    $hour = substr($s,8,2);
+    $minute = substr($s,10,2);
+    return $day . "/" . $month . "/" . $year . " " . $hour . ":" . $minute;
+  } else
+    return $s;
+}
+  
+?>
+<html>
+  <head>
+  <link type="text/css" rel="stylesheet" href="style.css"/>
+  </head>
+  <body>
+    <h1>QUERY results</h1>
+<? foreach( $qs as $name => $q) { ?>
+    <h2><? echo $name; ?></h2>
+    <p>
+    <tt><? print $q; ?></tt>
+    </p>
+    <table border=1>
+    <? 
+      $q = query($q);
+      echo "<tr>";
+      foreach( $q[0] as $name => $txt) {
+          echo "<th>$name</th>";
+        }
+      echo "</tr>\n";
+      $i=0;
+      foreach ($q as $k => $v) {
+        $i = $i + 1;
+        if ( $i%2 == 0)
+          echo "<tr class=\"even\">";      
+        else
+          echo "<tr class=\"odd\">";
+        foreach( $v as $name => $txt) {
+          echo "<td>" . prettify($txt) . "</td>";
+        }
+        echo "</tr>\n";      
+      }
+    ?>
+    </table>
+<? } ?>
+    <p><a href="bench.php">BACK to the query page</a></p>
+  </body>
+</html>

diff --git a/helm/matita/scripts/public_html/style.css b/helm/matita/scripts/public_html/style.css
new file mode 100644 (file)
index 0000000..dc2df47
--- /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 (executable)
index 0000000..a13005e
--- /dev/null
+++ b/helm/matita/scripts/shell_adder.php
@@ -0,0 +1,6 @@
+<?php
+ require($argv[1]);
+ $rc = query($argv[2]);
+ $a = array_values($rc[0]); 
+ print($a[0]);
+?>

diff --git a/helm/matita/scripts/shell_time2cents.php b/helm/matita/scripts/shell_time2cents.php
new file mode 100755 (executable)
index 0000000..4914fc2
--- /dev/null
+++ b/helm/matita/scripts/shell_time2cents.php
@@ -0,0 +1,4 @@
+<?php
+ require($argv[1]);
+ print(time_2_cents($argv[2]));
+?>

diff --git a/helm/matita/template_makefile.in b/helm/matita/template_makefile.in
new file mode 100644 (file)
index 0000000..8cbef1f
--- /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 (file)
index 0000000..34d4d12
--- /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 (file)
index 0000000..fe789a0
--- /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 (file)
index 0000000..abd4a94
--- /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 (file)
index 0000000..ef84002
--- /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 (file)
index 0000000..7620894
--- /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 (file)
index 0000000..a66efc5
--- /dev/null
+++ b/helm/matita/tests/bad_tests/auto.log
@@ -0,0 +1,100 @@
+\e[0;32mInfo:  \e[0mexecution of auto.ma started:
+\e[0;34mDebug: \e[0mExecuting: ``set "baseuri" "cic:/matita/tests/auto/"''
+\e[0;34mDebug: \e[0mExecuting: ``include cic:/Coq''
+\e[0;34mDebug: \e[0mExecuting: ``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
+\e[0;31mError: \e[0mBad name: a
+\e[0;34mDebug: \e[0mExecuting: ``intro.''
+\e[0;34mDebug: \e[0mExecuting: ``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
+\e[0;31mError: \e[0mTactic 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 (executable)
index 0000000..c7bd624
--- /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 (file)
index 0000000..9185479
--- /dev/null
+++ b/helm/matita/tests/bad_tests/baseuri.log
@@ -0,0 +1,4 @@
+\e[0;32mInfo:  \e[0mexecution of baseuri.ma started:
+\e[0;34mDebug: \e[0mExecuting: ``set "baseuri" "cic:/matita/tests/baseuri/"''
+\e[0;34mDebug: \e[0mExecuting: ``set "baseuri" "cic:/matita/tests/baseuri/"''
+\e[0;31mError: \e[0mError: 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 (file)
index 0000000..0e06223
--- /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 (file)
index 0000000..b2ae3b7
--- /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 (file)
index 0000000..5aaf6c0
--- /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 (file)
index 0000000..ca4b931
--- /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 (file)
index 0000000..20b15cd
--- /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 (file)
index 0000000..41e8e9b
--- /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 (file)
index 0000000..7ea26d4
--- /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 (file)
index 0000000..f45061b
--- /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 (file)
index 0000000..305a862
--- /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 (file)
index 0000000..a30fe2f
--- /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 (file)
index 0000000..fe72f71
--- /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 (file)
index 0000000..d8e4bf2
--- /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 (file)
index 0000000..67d7fad
--- /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 (file)
index 0000000..c6eb2a9
--- /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 (file)
index 0000000..4fca7b1
--- /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 (file)
index 0000000..82f0b1c
--- /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 (file)
index 0000000..a8cee10
--- /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 (file)
index 0000000..68492ba
--- /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 (file)
index 0000000..56212bd
--- /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 (file)
index 0000000..b8718cd
--- /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 (file)
index 0000000..aaf5700
--- /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 (file)
index 0000000..e48cc82
--- /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 (file)
index 0000000..4afdd37
--- /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 (file)
index 0000000..d7347ed
--- /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 (file)
index 0000000..7e02c0f
--- /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 (file)
index 0000000..3e49e06
--- /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 (file)
index 0000000..65dc75d
--- /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 (file)
index 0000000..55933cd
--- /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 (file)
index 0000000..0e27ce4
--- /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 (file)
index 0000000..fc354e6
--- /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 (file)
index 0000000..bd0eb8d
--- /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 (file)
index 0000000..311b945
--- /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 (file)
index 0000000..ed9ecfe
--- /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 (file)
index 0000000..2b174af
--- /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 (file)
index 0000000..580ad13
--- /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 (file)
index 0000000..450c676
--- /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 (file)
index 0000000..65e9d48
--- /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 (file)
index 0000000..92d9a53
--- /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 (file)
index 0000000..cdf5490
--- /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 (file)
index 0000000..6c3b7ec
--- /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 (file)
index 0000000..124cdc1
--- /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 (file)
index 0000000..99f3931
--- /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 (file)
index 0000000..2ffa155
--- /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 (file)
index 0000000..525cc9c
--- /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 (file)
index 0000000..51afe1b
--- /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 (file)
index 0000000..829efba
--- /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 (file)
index 0000000..f21ea6d
--- /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 (file)
index 0000000..6aacb1a
--- /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 (file)
index 0000000..d2e467a
--- /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 (file)
index 0000000..223a182
--- /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 (file)
index 0000000..bc4f2fc
--- /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 (file)
index 0000000..75e2d4d
--- /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 (file)
index 0000000..cd3d368
--- /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 (file)
index 0000000..bfee89e
--- /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 (file)
index 0000000..8a7badf
--- /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 (file)
index 0000000..0ae4a09
--- /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 (file)
index 0000000..c720372
--- /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 (file)
index 0000000..d921b55
--- /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 (file)
index 0000000..3c79fd9
--- /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 (file)
index 0000000..d06666f
--- /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 (file)
index 0000000..144141e
--- /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 (file)
index 0000000..35ab5dd
--- /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 (file)
index 0000000..d4955e0
--- /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 (file)
index 0000000..5b2e8d8
--- /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 (file)
index 0000000..df553d7
--- /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 (file)
index 0000000..c416820
--- /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 (file)
index 0000000..42275ab
--- /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 (file)
index 0000000..a5b1383
--- /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 (file)
index 0000000..34a25fe
--- /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 (file)
index 0000000..6949a57
--- /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 (file)
index 0000000..82d3640
--- /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 (file)
index 0000000..6e704ba
--- /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 (file)
index 0000000..dec21ee
--- /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 (file)
index 0000000..5253060
--- /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 (file)
index 0000000..ff18746
--- /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 (file)
index 0000000..c2da776
--- /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 (file)
index 0000000..20ea843
--- /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 (file)
index 0000000..626e644
--- /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 (file)
index 0000000..9cc9183
--- /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 (file)
index 0000000..af5ecab
--- /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 (file)
index 0000000..0c2d494
--- /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 (file)
index 0000000..e69de29

diff --git a/helm/ocaml/acic_content/.depend b/helm/ocaml/acic_content/.depend
new file mode 100644 (file)
index 0000000..f639932
--- /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 (file)
index 0000000..cc4da37
--- /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 (file)
index 0000000..d62786c
--- /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 (file)
index 0000000..0a9ec6a
--- /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 (file)
index 0000000..8f3b13c
--- /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 <asperti@cs.unibo.it>                    *)
+(*                             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 (file)
index 0000000..e1dfb82
--- /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 (file)
index 0000000..32d4f0d
--- /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 (file)
index 0000000..d4f8709
--- /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 (file)
index 0000000..5dc6fd8
--- /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 (file)
index 0000000..57a4d6b
--- /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 (file)
index 0000000..a66aa5f
--- /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, <pattern,action> 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
+
+  (** <name, inductive/coinductive, type, constructor 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 (file)
index 0000000..8e487ed
--- /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 (file)
index 0000000..5d309d6
--- /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 (file)
index 0000000..22733dc
--- /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 <asperti@cs.unibo.it>                    *)
+(*                             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 (file)
index 0000000..c1122b8
--- /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 (file)
index 0000000..9acea81
--- /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 <asperti@cs.unibo.it>                     *)
+(*                              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 (file)
index 0000000..9bb6509
--- /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 <asperti@cs.unibo.it>                    *)
+(*                             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 (file)
index 0000000..ca89fad
--- /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 <asperti@cs.unibo.it>                     *)
+(*                              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 (file)
index 0000000..a160ab1
--- /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 (file)
index 0000000..fddd777
--- /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 <name, type> 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 (file)
index 0000000..1fd57e0
--- /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 (file)
index 0000000..a351563
--- /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 (file)
index 0000000..4e36af0
--- /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 (file)
index 0000000..64825e5
--- /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 <sacerdot@cs.unibo.it>              *)
+(*                                 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 (file)
index 0000000..317bcb9
--- /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:
+   <!ELEMENT CurrentProof (Conjecture*,body)>
+   <!ELEMENT Sequent %sequent;>
+   <!ELEMENT Conjecture %sequent;>
+   <!ELEMENT Decl %term;>
+   <!ELEMENT Def %term;>
+   <!ELEMENT Hidden EMPTY>
+   <!ELEMENT Goal %term;>
+*)
+
+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 <tag_name,
+   * attribute_list> *)
+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 <name, value> _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 "</%s>" 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. <arity>) *)
+      push ctxt (Cic_term term)
+  | "substitution" ->   (* optional transparent elements (i.e. which _may_
+                         * contain a CIC) *)
+      set_top ctxt  (* replace <substitution> *)
+        (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 <arg> 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 <instantiate> *)
+      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 (file)
index 0000000..9472b4c
--- /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 (file)
index 0000000..669025f
--- /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 <tassi@cs.unibo.it>                     *)
+(*                                 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
+;;
+  
+\f
+(*****************************************************************************)
+(** _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'' (* ) *)
+;;
+
+\f
+(*****************************************************************************)
+(** 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'
+
+\f
+(*****************************************************************************)
+(** 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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\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
+
+\f
+(*****************************************************************************)
+(** 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 (file)
index 0000000..be8c28b
--- /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 (file)
index 0000000..7c6e3ea
--- /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 (file)
index 0000000..b6fd745
--- /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 (file)
index 0000000..f04f5aa
--- /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 (file)
index 0000000..89b18d2
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..0bef85a
--- /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 (file)
index 0000000..61631f4
--- /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 (file)
index 0000000..3038582
--- /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 (file)
index 0000000..6778798
--- /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 (file)
index 0000000..cc04322
--- /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 (file)
index 0000000..f870659
--- /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 (file)
index 0000000..c0e4bb2
--- /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 (file)
index 0000000..8999016
--- /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 (file)
index 0000000..e15468f
--- /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 (file)
index 0000000..e198bcd
--- /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 (file)
index 0000000..5582abc
--- /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 (file)
index 0000000..3fc1e0d
--- /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 (file)
index 0000000..a7f1e19
--- /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 (file)
index 0000000..7e97dea
--- /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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^ dtdname ^ "\">\n");
+            xml_for_current_proof_body
+         >] in
+        let xmlty =
+         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
+            xml_for_current_proof_type
+         >]
+        in
+         xmlty, Some xmlbo
+     | C.AConstant (id,idbody,n,bo,ty,params,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
+                  "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+                 X.xml_cdata
+                  ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata
+             ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+      X.xml_cdata
+       ("<!DOCTYPE InnerTypes SYSTEM \"" ^ dtdname ^ "\">\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 (file)
index 0000000..22c5669
--- /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 (file)
index 0000000..8540e0e
--- /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 (file)
index 0000000..e637928
--- /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 (file)
index 0000000..30a8f5c
--- /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 (file)
index 0000000..892e09f
--- /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 (file)
index 0000000..22d26e1
--- /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 (file)
index 0000000..c6c6811
--- /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 (file)
index 0000000..ca41244
--- /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 (file)
index 0000000..729590d
--- /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 (file)
index 0000000..667c507
--- /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
+(*
+      (* <benchmark> *)
+      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
+      (* </benchmark> *)
+*)
+
+      (* (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 (file)
index 0000000..a2cc0d0
--- /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 (file)
index 0000000..bdbc931
--- /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 (file)
index 0000000..0ad4981
--- /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 (file)
index 0000000..4a2e43a
--- /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 (file)
index 0000000..4f4b3c3
--- /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 (file)
index 0000000..09efea8
--- /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 (file)
index 0000000..2b3ce2d
--- /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 (file)
index 0000000..12b09ff
--- /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 (file)
index 0000000..6a826fc
--- /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 (file)
index 0000000..87bb015
--- /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 (file)
index 0000000..06b9188
--- /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 (file)
index 0000000..3fbe90d
--- /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 (file)
index 0000000..2284572
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                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 (file)
index 0000000..55566a6
--- /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 <sacerdot@cs.unibo.it>              *)
+(*                                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 (file)
index 0000000..5921c61
--- /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 (file)
index 0000000..408bc88
--- /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 (file)
index 0000000..5c88713
--- /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 (file)
index 0000000..c923c6a
--- /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 (file)
index 0000000..53f5227
--- /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 (file)
index 0000000..e84ae4f
--- /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 <sacerdot@cs.unibo.it>              *)
+(*                                 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 (file)
index 0000000..b7592f0
--- /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 (file)
index 0000000..e361905
--- /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 (file)
index 0000000..372c66f
--- /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 (file)
index 0000000..21a1f5d
--- /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 (file)
index 0000000..cd742d4
--- /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 (file)
index 0000000..e941917
--- /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 (file)
index 0000000..cd1aeba
--- /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 <tassi@cs.unibo.it>                      *)
+(*                                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 (file)
index 0000000..eb55a47
--- /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 (file)
index 0000000..f2e49d3
--- /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 (executable)
index 0000000..99c9e4d
--- /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 (file)
index 0000000..b90c0f2
--- /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 (file)
index 0000000..2cd98f8
--- /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 (file)
index 0000000..8a8524d
--- /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 <dumpfile> <uri_index>\n" ^
+             "  <dumpfile>   is the file where environment will be dumped\n" ^
+             "  <uri_index>  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 (file)
index 0000000..90ea516
--- /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 (file)
index 0000000..1d65291
--- /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 (file)
index 0000000..a442c1d
--- /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 (file)
index 0000000..3db00fe
--- /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 (file)
index 0000000..afd74d7
--- /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 (file)
index 0000000..96f8720
--- /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 (file)
index 0000000..3667922
--- /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 (file)
index 0000000..4762701
--- /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 (file)
index 0000000..f03752d
--- /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 (file)
index 0000000..224a758
--- /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 (file)
index 0000000..b1ef27f
--- /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<BEGIN>%s\n<END>" (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<BEGIN>%s\n<END>" (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<BEGIN>%s\n<END>" (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<BEGIN>%s\n<END>" (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 (file)
index 0000000..e1a6c28
--- /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 (file)
index 0000000..3d22c64
--- /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 (file)
index 0000000..357d101
--- /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 (file)
index 0000000..60e25ec
--- /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 (file)
index 0000000..642e3ce
--- /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> 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)
+# </cross>
+

diff --git a/helm/ocaml/content_pres/box.ml b/helm/ocaml/content_pres/box.ml
new file mode 100644 (file)
index 0000000..8b992e0
--- /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 <asperti@cs.unibo.it>                   *)
+(*                             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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\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 (file)
index 0000000..56c0869
--- /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 <asperti@cs.unibo.it>                   *)
+(*                             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 (file)
index 0000000..7a2fa99
--- /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 (file)
index 0000000..6b7c3ce
--- /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 (file)
index 0000000..8848a3c
--- /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<to>>);   ("=>", <:unicode<Rightarrow>>);
+      ("<=", <:unicode<leq>>);  (">=", <:unicode<geq>>);
+      ("<>", <:unicode<neq>>);  (":=", <:unicode<def>>);
+    ]
+
+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 (file)
index 0000000..cd5f087
--- /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 (file)
index 0000000..5750ad8
--- /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<Assign>> (* ≔ *); 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>>     (* Π *) -> `Pi
+(*     | SYMBOL <:unicode<exists>> |+ ∃ +| -> `Exists *)
+    | SYMBOL <:unicode<forall>> (* ∀ *) -> `Forall
+    | SYMBOL <:unicode<lambda>> (* λ *) -> `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<def>> (* ≝ *); 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<def>> (* ≝ *);
+      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<exists>> (* ∃ *);
+        (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<Rightarrow>> (* ⇒ *);
+          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 (file)
index 0000000..e25968b
--- /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 (file)
index 0000000..6412c3f
--- /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 (file)
index 0000000..04411df
--- /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 (file)
index 0000000..948eb7b
--- /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 <asperti@cs.unibo.it>                     *)
+(*                              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 (file)
index 0000000..793c31a
--- /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 <asperti@cs.unibo.it>                    *)
+(*                             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 (file)
index 0000000..7e080ea
--- /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 (file)
index 0000000..86b97b6
--- /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 (file)
index 0000000..1aa5db1
--- /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 <asperti@cs.unibo.it>                    *)
+(*                             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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\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 (file)
index 0000000..8252517
--- /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 (file)
index 0000000..cc692ab
--- /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 (file)
index 0000000..6432359
--- /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 (file)
index 0000000..88c804b
--- /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 <asperti@cs.unibo.it>                     *)
+(*                              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 (file)
index 0000000..615c8e3
--- /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 <asperti@cs.unibo.it>                     *)
+(*                              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 (file)
index 0000000..4c8bbc7
--- /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 (file)
index 0000000..5ff7100
--- /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 (file)
index 0000000..b032d7f
--- /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 (file)
index 0000000..93c122d
--- /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 (file)
index 0000000..d7f9cf8
--- /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 (file)
index 0000000..b11273f
--- /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 (file)
index 0000000..c67778a
--- /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 (file)
index 0000000..15a459c
--- /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 (file)
index 0000000..aed9b24
--- /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 (file)
index 0000000..4ad2b5b
--- /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   = "\e[0;34m"
+let yellow = "\e[0;33m"
+let green  = "\e[0;32m"
+let red    = "\e[0;31m"
+let black  = "\e[0m"
+
+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 (file)
index 0000000..6847ce3
--- /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 (file)
index 0000000..c578868
--- /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 (file)
index 0000000..90ce20d
--- /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 (file)
index 0000000..c1b436a
--- /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 (file)
index 0000000..2201ddf
--- /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 <pattern, pattern_id>)
+   * @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 (file)
index 0000000..f60b2d4
--- /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 (file)
index 0000000..b95157f
--- /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 (file)
index 0000000..9f77a24
--- /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 (file)
index 0000000..6512190
--- /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 (file)
index 0000000..9ebca23
--- /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 (file)
index 0000000..61930a4
--- /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 *)
+
+  (* <TODO> *)
+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"
+  (* </TODO> *)
+
+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 (file)
index 0000000..4bbc447
--- /dev/null
+++ b/helm/ocaml/getter/http_getter.mli
@@ -0,0 +1,66 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open 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 (file)
index 0000000..a29a44d
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_common.ml
@@ -0,0 +1,168 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..d1bc66f
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_common.mli
@@ -0,0 +1,70 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open 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 (file)
index 0000000..8103efc
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_const.ml
@@ -0,0 +1,102 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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
+"<?xml version=\"1.0\"?>
+<html xmlns=\"%s\" xmlns:helm=\"%s\">
+  <head>
+    <title>HTTP Getter's help message</title>
+  </head>
+  <body>
+    <h1>HTTP Getter, version %s</h1>
+    <h2>Usage information</h2>
+    <p>
+    Usage: <kbd>http://hostname:getterport/</kbd><em>command</em>
+    </p>
+    <p>
+    Available commands:
+    </p>
+    <p>
+      <b><kbd><a href=\"/help\">help</a></kbd></b><br />
+      display this help message
+    </p>
+    <p>
+      <b><kbd>getxml?uri=URI[&amp;format=(normal|gz)][&amp;patch_dtd=(yes|no)]</kbd></b><br />
+    </p>
+    <p>
+      <b><kbd>resolve?uri=URI</kbd></b><br />
+    </p>
+    <p>
+      <b><kbd>getdtd?uri=URI[&amp;patch_dtd=(yes|no)]</kbd></b><br />
+    </p>
+    <p>
+      <b><kbd>getxslt?uri=URI[&amp;patch_dtd=(yes|no)]</kbd></b><br />
+    </p>
+    <p>
+      <b><kbd><a href=\"/update\">update</a></kbd></b><br />
+    </p>
+    <p>
+      <b><kbd><a href=\"clean_cache\">clean_cache</a></kbd></b><br />
+    </p>
+    <p>
+      <b><kbd>ls?baseuri=regexp&amp;format=(txt|xml)</kbd></b><br />
+    </p>
+    <p>
+      <b><kbd>getalluris?format=(<a href=\"/getalluris?format=txt\">txt</a>|<a href=\"/getalluris?format=xml\">xml</a>)</kbd></b><br />
+    </p>
+    <p>
+      <b><kbd><a href=\"/getempty\">getempty</a></kbd></b><br />
+    </p>
+    <h2>Current configuration</h2>
+    <pre>%s</pre>
+  </body>
+</html>
+"
+  xhtml_ns helm_ns
+  version configuration
+
+let empty_xml =
+"<?xml version=\"1.0\"?>
+<!DOCTYPE empty [
+  <!ELEMENT empty EMPTY>
+]>
+<empty />
+"
+

diff --git a/helm/ocaml/getter/http_getter_const.mli b/helm/ocaml/getter/http_getter_const.mli
new file mode 100644 (file)
index 0000000..d532313
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_const.mli
@@ -0,0 +1,39 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+val 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 (file)
index 0000000..7a3891b
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_env.ml
@@ -0,0 +1,114 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..6a0f0f5
--- /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 (file)
index 0000000..1d774c1
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_logger.ml
@@ -0,0 +1,63 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..d39fe73
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_logger.mli
@@ -0,0 +1,49 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(** {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 (file)
index 0000000..45403ef
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_misc.ml
@@ -0,0 +1,315 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..e9b013e
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_misc.mli
@@ -0,0 +1,102 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+ (** '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 (file)
index 0000000..fc6f415
--- /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 (file)
index 0000000..24fc329
--- /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 (file)
index 0000000..fb0c30e
--- /dev/null
+++ b/helm/ocaml/getter/http_getter_types.ml
@@ -0,0 +1,72 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..2052e7b
--- /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 (file)
index 0000000..5d28df1
--- /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 (executable)
index 0000000..3107846
--- /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 = <LS>) {
+    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 (file)
index 0000000..54cdc25
--- /dev/null
+++ b/helm/ocaml/getter/sample.conf.xml
@@ -0,0 +1,50 @@
+<helm_registry>
+  <section name="getter">
+    <key name="cache_dir">/tmp/helm/cache</key>
+    <key name="dtd_dir">/projects/helm/xml/dtd</key>
+    <key name="port">58081</key>
+    <key name="log_level">180</key>
+    <key name="log_file">http_getter.log</key>
+    <key name="prefix">
+      theory:/  file:///projects/helm/library/theories/
+    </key>
+    <key name="prefix">
+      xslt:/    file:///projects/helm/xml/stylesheets_ccorn/
+    </key>
+    <key name="prefix">
+      xslt:/    file:///projects/helm/xml/stylesheets_hanane/
+    </key>
+    <key name="prefix">
+      xslt:/    file:///projects/helm/xml/on-line/xslt/
+    </key>
+    <key name="prefix">
+      xslt:/    file:///projects/helm/nuprl/NuPRL/nuprl_stylesheets/
+    </key>
+    <key name="prefix">
+      nuprl:/   http://www.cs.uwyo.edu/~nuprl/helm-library/
+    </key>
+    <key name="prefix">
+      xslt:/    file:///projects/helm/xml/stylesheets/
+    </key>
+    <key name="prefix">
+      xslt:/    file:///projects/helm/xml/stylesheets/generated/
+    </key>
+    <key name="prefix">
+      theory:/residual_theory_in_lambda_calculus/
+      http://helm.cs.unibo.it/~sacerdot/huet_lambda_calculus_mowgli/residual_theory_in_lambda_calculus/
+    </key>
+    <key name="prefix">
+      theory:/IDA/
+      http://mowgli.cs.unibo.it/~sacerdot/ida/IDA/
+    </key>
+    <key name="prefix">
+      cic:/     file:///projects/helm/library/coq_contribs/
+      legacy
+    </key>
+    <key name="prefix">
+      cic:/matita/
+      file:///projects/helm/library/matita/
+      ro
+    </key>
+  </section>
+</helm_registry>

diff --git a/helm/ocaml/getter/test.ml b/helm/ocaml/getter/test.ml
new file mode 100644 (file)
index 0000000..6fa236f
--- /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 (file)
index 0000000..dc225e2
--- /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 (file)
index 0000000..182cd45
--- /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 (file)
index 0000000..c956715
--- /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 (file)
index 0000000..6abfa4d
--- /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 (file)
index 0000000..f9b3b37
--- /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 (file)
index 0000000..e786d50
--- /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 (file)
index 0000000..e60ad39
--- /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 (file)
index 0000000..d0e9a3a
--- /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 (file)
index 0000000..e72acd2
--- /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 (file)
index 0000000..c0a453c
--- /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 (file)
index 0000000..ee5f3a1
--- /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 (file)
index 0000000..5b86293
--- /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 (file)
index 0000000..833bb63
--- /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 (file)
index 0000000..37a3132
--- /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 (file)
index 0000000..ce3c042
--- /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 (file)
index 0000000..0c02e1b
--- /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 (file)
index 0000000..a8b86c2
--- /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 (file)
index 0000000..3604296
--- /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 (file)
index 0000000..4b04b59
--- /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> 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)
+# </cross>
+#
+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 (file)
index 0000000..015d426
--- /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 (file)
index 0000000..00f184b
--- /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 (file)
index 0000000..fc49de6
--- /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 (file)
index 0000000..882d45f
--- /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 (file)
index 0000000..3d6f893
--- /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 (file)
index 0000000..b04aa3c
--- /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 (file)
index 0000000..d05351c
--- /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 =  (* <fresh_instances?, aliases, coercions?> *)
+    [ (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 (file)
index 0000000..b7c85f6
--- /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 (file)
index 0000000..90d1898
--- /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<vdash>>; 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<def>> ; 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<def>>; OPT SYMBOL "|";
+    fst_constructors = LIST0 constructor SEP SYMBOL "|";
+    tl = OPT [ "with";
+      types = LIST1 [
+        name = IDENT; SYMBOL ":"; typ = term; SYMBOL <:unicode<def>>;
+       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<def>>; 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<eta>> (* η *); 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<def>> ; 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<def>> (* ≝ *); body = term -> body ] ->
+        GrafiteAst.Obj (loc, Ast.Theorem (flavour, name, typ, body))
+    | flavour = theorem_flavour; name = IDENT; SYMBOL <:unicode<def>> (* ≝ *);
+      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 (file)
index 0000000..6a19800
--- /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 (file)
index 0000000..6a05865
--- /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 "@[<hov2>";
+          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 "{@[<hov2> ";
+        let todo = visit_symbol symbol todo is_son (nesting+1) in
+        Format.fprintf fmt "@]} @ ";
+        todo
+    | Slist0sep (symbol,sep) ->
+        Format.fprintf fmt "[@[<hov2> ";
+        let todo = visit_symbol symbol todo is_son (nesting + 1) in
+        Format.fprintf fmt "{@[<hov2> ";
+        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 "{@[<hov2> ";
+        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 "{@[<hov2> ";
+        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 "[@[<hov2> ";
+        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 "@[<hov2>( ";
+            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 "@[<hv2>%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 (file)
index 0000000..2d0f781
--- /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 (file)
index 0000000..2deef1b
--- /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\e[01;31m%s\e[00m%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 (file)
index 0000000..d6a85b9
--- /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 (file)
index 0000000..c38ac3e
--- /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 (file)
index 0000000..691f9d1
--- /dev/null
+++ b/helm/ocaml/hbugs/broker.ml
@@ -0,0 +1,293 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 "<help> not yet written </help>" 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 (file)
index 0000000..93114b3
--- /dev/null
+++ b/helm/ocaml/hbugs/client.ml
@@ -0,0 +1,46 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..947e351
--- /dev/null
+++ b/helm/ocaml/hbugs/data/hbugs_tutor.TPL.ml
@@ -0,0 +1,42 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+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 (file)
index 0000000..bd4baad
--- /dev/null
+++ b/helm/ocaml/hbugs/data/tutors_index.xml
@@ -0,0 +1,140 @@
+<!--
+  Data used to fill template "hbugs_tutor.TPL.ml"
+
+  @ADDR@              tutor ip address
+  @PORT@              tutor tcp port
+  @TACTIC@            tactic to use (OCaml function, must have type
+                      ProofEngineTypes.tactic)
+  @HINT@              hint to be sent to client (content of Hbugs_types.Eureka
+                      type constructor, must have type Hbugs_types.hint, see
+                      hbugs_types.ml)
+  @HINT_TYPE@         hint type (3rd argument of Hbugs_types.Register_tutor type
+                      constructor, must have type Hbugs_types.hint_type)
+  @DESCRIPTION@       human readable tutor description
+  @ENVIRONMENT_FILE@  file from which restore proof checking environment on boot
+
+  "source" attribute  corresponding OCaml source file
+
+  INVARIANT:  XML element name below are lowercase version of @TAGS@ used in
+              template
+
+  TODO: hint type isn't yet well formalized
+-->
+
+<tutors>
+
+  <!-- DEBUGGING -->
+<!--
+  <tutor source="wait_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50111</port>
+    <tactic>Wait.wait_tac</tactic>
+    <hint>Hbugs_types.Use_ring_Luke</hint>
+    <hint_type>Use Ring Luke</hint_type>
+    <description>WAIT FOREVER tutor</description>
+    <environment_file>wait.environment</environment_file>
+  </tutor>
+-->
+
+  <tutor source="ring_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50001</port>
+    <tactic>Ring.ring_tac</tactic>
+    <hint>Hbugs_types.Use_ring_Luke</hint>
+    <hint_type>Use Ring Luke</hint_type>
+    <description>Ring tutor</description>
+    <environment_file>ring.environment</environment_file>
+  </tutor>
+  <tutor source="fourier_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50002</port>
+    <tactic>FourierR.fourier_tac</tactic>
+    <hint>Hbugs_types.Use_fourier_Luke</hint>
+    <hint_type>Use Fourier Luke</hint_type>
+    <description>Fourier tutor</description>
+    <environment_file>fourier.environment</environment_file>
+  </tutor>
+  <tutor source="reflexivity_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50003</port>
+    <tactic>EqualityTactics.reflexivity_tac</tactic>
+    <hint>Hbugs_types.Use_reflexivity_Luke</hint>
+    <hint_type>Use Reflexivity Luke</hint_type>
+    <description>Reflexivity tutor</description>
+    <environment_file>reflexivity.environment</environment_file>
+  </tutor>
+  <tutor source="symmetry_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50004</port>
+    <tactic>EqualityTactics.symmetry_tac</tactic>
+    <hint>Hbugs_types.Use_symmetry_Luke</hint>
+    <hint_type>Use Symmetry Luke</hint_type>
+    <description>Symmetry tutor</description>
+    <environment_file>symmetry.environment</environment_file>
+  </tutor>
+  <tutor source="assumption_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50005</port>
+    <tactic>VariousTactics.assumption_tac</tactic>
+    <hint>Hbugs_types.Use_assumption_Luke</hint>
+    <hint_type>Use Assumption Luke</hint_type>
+    <description>Assumption tutor</description>
+    <environment_file>assumption.environment</environment_file>
+  </tutor>
+  <tutor source="contradiction_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50006</port>
+    <tactic>NegationTactics.contradiction_tac</tactic>
+    <hint>Hbugs_types.Use_contradiction_Luke</hint>
+    <hint_type>Use Contradiction Luke</hint_type>
+    <description>Contradiction tutor</description>
+    <environment_file>contradiction.environment</environment_file>
+  </tutor>
+  <tutor source="exists_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50007</port>
+    <tactic>IntroductionTactics.exists_tac</tactic>
+    <hint>Hbugs_types.Use_exists_Luke</hint>
+    <hint_type>Use Exists Luke</hint_type>
+    <description>Exists tutor</description>
+    <environment_file>exists.environment</environment_file>
+  </tutor>
+  <tutor source="split_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50008</port>
+    <tactic>IntroductionTactics.split_tac</tactic>
+    <hint>Hbugs_types.Use_split_Luke</hint>
+    <hint_type>Use Split Luke</hint_type>
+    <description>Split tutor</description>
+    <environment_file>split.environment</environment_file>
+  </tutor>
+  <tutor source="left_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50009</port>
+    <tactic>IntroductionTactics.left_tac</tactic>
+    <hint>Hbugs_types.Use_left_Luke</hint>
+    <hint_type>Use Left Luke</hint_type>
+    <description>Left tutor</description>
+    <environment_file>left.environment</environment_file>
+  </tutor>
+  <tutor source="right_tutor.ml">
+    <addr>127.0.0.1</addr>
+    <port>50010</port>
+    <tactic>IntroductionTactics.right_tac</tactic>
+    <hint>Hbugs_types.Use_right_Luke</hint>
+    <hint_type>Use Right Luke</hint_type>
+    <description>Right tutor</description>
+    <environment_file>right.environment</environment_file>
+  </tutor>
+  <tutor source="search_pattern_apply_tutor.ml">
+    <no_auto /> <!-- this imply that settings below are not significant -->
+    <addr>127.0.0.1</addr>
+    <port>50011</port>
+    <tactic>PrimitiveTactics.apply_tac</tactic>
+    <hint>Hbugs_types.Use_apply_Luke</hint>
+    <hint_type>Use Apply Luke (with argument)</hint_type>
+    <description>Search pattern apply tutor</description>
+    <environment_file>search_pattern_apply.environment</environment_file>
+  </tutor>
+</tutors>
+

diff --git a/helm/ocaml/hbugs/doc/hbugs.dia b/helm/ocaml/hbugs/doc/hbugs.dia
new file mode 100644 (file)
index 0000000..b1c4e64
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 (file)
index 0000000..4670b5e
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_broker_registry.ml
@@ -0,0 +1,317 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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
+(*
+    (* <DEBUGGING> *)
+    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
+    (* </DEBUGGING> *)
+*)
+
+    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 (
+      "<clients>\n" ^
+      (Hashtbl.fold
+        (fun id url dump ->
+          (dump ^
+          (sprintf "<client id=\"%s\" url=\"%s\">\n" id url) ^
+          "<subscriptions>\n" ^
+          (String.concat "\n" (* id's subscriptions *)
+            (List.map
+              (fun tutor_id -> sprintf "<tutor id=\"%s\" />\n" tutor_id)
+              (Hashtbl.find subscriptions id))) ^
+          "</subscriptions>\n</client>\n"))
+        urls "") ^
+      "</clients>"
+    ))
+    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
+(*
+    (* <DEBUGGING> *)
+    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
+    (* </DEBUGGING> *)
+*)
+
+    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 (
+      "<tutors>\n" ^
+      (Hashtbl.fold
+        (fun id (url, hint_type, dsc) dump ->
+          dump ^
+          (sprintf
+"<tutor id=\"%s\" url=\"%s\">\n<hint_type>%s</hint_type>\n<description>%s</description>\n</tutor>"
+            id url hint_type dsc))
+        tbl "") ^
+      "</tutors>"
+    ))
+    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
+(*
+    (* <DEBUGGING> *)
+    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
+    (* </DEBUGGING> *)
+*)
+
+    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 <musing_id, client_id, tutor_id> 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 (
+      "<musings>\n" ^
+      (Hashtbl.fold
+        (fun mid (cid, tid) dump ->
+          dump ^
+          (sprintf "<musing id=\"%s\" client=\"%s\" tutor=\"%s\" />\n"
+            mid cid tid))
+        musings "") ^
+      "</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 (file)
index 0000000..ece9e07
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_broker_registry.mli
@@ -0,0 +1,87 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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 (file)
index 0000000..c7b5fae
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_client.ml
@@ -0,0 +1,526 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..0c2e93d
--- /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 (file)
index 0000000..f88a8c3
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_client_gui.glade
@@ -0,0 +1,672 @@
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+<requires lib="gnome"/>
+
+<widget class="GtkWindow" id="hbugsMainWindow">
+  <property name="title" translatable="yes">Hbugs: your personal proof trainer!</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">False</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+
+  <child>
+    <widget class="GtkVBox" id="vbox1">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child>
+       <widget class="GtkMenuBar" id="menubar">
+
+         <child>
+           <widget class="GtkMenuItem" id="toolsMenu">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes">Tools</property>
+             <property name="use_underline">True</property>
+
+             <child>
+               <widget class="GtkMenu" id="toolsMenu_menu">
+                 <property name="visible">True</property>
+
+                 <child>
+                   <widget class="GtkCheckMenuItem" id="toggleDebuggingMenuItem">
+                     <property name="visible">True</property>
+                     <property name="label" translatable="yes">Debugging</property>
+                     <property name="use_underline">True</property>
+                     <property name="active">False</property>
+                   </widget>
+                 </child>
+               </widget>
+             </child>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHBox" id="hbox4">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">2</property>
+
+         <child>
+           <widget class="GtkLabel" id="label11">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes">My URL:</property>
+             <property name="use_underline">False</property>
+             <property name="use_markup">False</property>
+             <property name="justify">GTK_JUSTIFY_CENTER</property>
+             <property name="wrap">False</property>
+             <property name="selectable">False</property>
+             <property name="xalign">0.5</property>
+             <property name="yalign">0.5</property>
+             <property name="xpad">0</property>
+             <property name="ypad">0</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkEntry" id="clientUrlEntry">
+             <property name="visible">True</property>
+             <property name="tooltip" translatable="yes">Local HTTP daemon URL</property>
+             <property name="can_focus">True</property>
+             <property name="editable">False</property>
+             <property name="visibility">True</property>
+             <property name="max_length">0</property>
+             <property name="text" translatable="yes"></property>
+             <property name="has_frame">True</property>
+             <property name="invisible_char" translatable="yes">*</property>
+             <property name="activates_default">False</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="startLocalHttpDaemonButton">
+             <property name="visible">True</property>
+             <property name="tooltip" translatable="yes">Start the local HTTP daemon listening on the specified URL</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">Start!</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="testLocalHttpDaemonButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">Test!</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkVBox" id="vbox4">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">0</property>
+
+         <child>
+           <widget class="GtkHBox" id="hbox1">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">2</property>
+
+             <child>
+               <widget class="GtkLabel" id="label1">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">Broker:</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_CENTER</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">False</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkEntry" id="brokerUrlEntry">
+                 <property name="visible">True</property>
+                 <property name="tooltip" translatable="yes">HBugs broker URL</property>
+                 <property name="can_focus">True</property>
+                 <property name="editable">False</property>
+                 <property name="visibility">True</property>
+                 <property name="max_length">0</property>
+                 <property name="text" translatable="yes"></property>
+                 <property name="has_frame">True</property>
+                 <property name="invisible_char" translatable="yes">*</property>
+                 <property name="activates_default">False</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">True</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkButton" id="testBrokerButton">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="label" translatable="yes">Test!</property>
+                 <property name="use_underline">True</property>
+                 <property name="relief">GTK_RELIEF_NORMAL</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">False</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkHBox" id="hbox2">
+             <property name="visible">True</property>
+             <property name="homogeneous">False</property>
+             <property name="spacing">2</property>
+
+             <child>
+               <widget class="GtkLabel" id="label2">
+                 <property name="label" translatable="yes">Client ID:</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_CENTER</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">False</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkLabel" id="clientIdLabel">
+                 <property name="label" translatable="yes"></property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">True</property>
+                 <property name="fill">True</property>
+               </packing>
+             </child>
+
+             <child>
+               <widget class="GtkButton" id="registerClientButton">
+                 <property name="visible">True</property>
+                 <property name="can_focus">True</property>
+                 <property name="label" translatable="yes">(Re)Register</property>
+                 <property name="use_underline">True</property>
+                 <property name="relief">GTK_RELIEF_NORMAL</property>
+               </widget>
+               <packing>
+                 <property name="padding">0</property>
+                 <property name="expand">False</property>
+                 <property name="fill">False</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">False</property>
+             <property name="fill">False</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkVPaned" id="vpaned1">
+         <property name="visible">True</property>
+         <property name="position">0</property>
+
+         <child>
+           <widget class="GtkFrame" id="frame3">
+             <property name="border_width">4</property>
+             <property name="visible">True</property>
+             <property name="label_xalign">0</property>
+             <property name="label_yalign">0.5</property>
+             <property name="shadow_type">GTK_SHADOW_ETCHED_IN</property>
+
+             <child>
+               <widget class="GtkHBox" id="hbox6">
+                 <property name="visible">True</property>
+                 <property name="homogeneous">False</property>
+                 <property name="spacing">2</property>
+
+                 <child>
+                   <widget class="GtkScrolledWindow" id="scrolledwindow3">
+                     <property name="visible">True</property>
+                     <property name="hscrollbar_policy">GTK_POLICY_ALWAYS</property>
+                     <property name="vscrollbar_policy">GTK_POLICY_ALWAYS</property>
+                     <property name="shadow_type">GTK_SHADOW_IN</property>
+                     <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                     <child>
+                       <widget class="GtkTreeView" id="subscriptionCList">
+                         <property name="visible">True</property>
+                         <property name="can_focus">True</property>
+                         <property name="headers_visible">True</property>
+                         <property name="rules_hint">False</property>
+                         <property name="reorderable">False</property>
+                         <property name="enable_search">True</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">True</property>
+                     <property name="fill">True</property>
+                   </packing>
+                 </child>
+
+                 <child>
+                   <widget class="GtkFixed" id="fixed1">
+                     <property name="visible">True</property>
+
+                     <child>
+                       <widget class="GtkButton" id="showSubscriptionWindowButton">
+                         <property name="width_request">0</property>
+                         <property name="height_request">0</property>
+                         <property name="visible">True</property>
+                         <property name="can_focus">True</property>
+                         <property name="label" translatable="yes">Subscribe ...</property>
+                         <property name="use_underline">True</property>
+                         <property name="relief">GTK_RELIEF_NORMAL</property>
+                       </widget>
+                       <packing>
+                         <property name="x">0</property>
+                         <property name="y">0</property>
+                       </packing>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">False</property>
+                     <property name="fill">False</property>
+                   </packing>
+                 </child>
+               </widget>
+             </child>
+
+             <child>
+               <widget class="GtkLabel" id="label12">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">Subscriptions</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="type">label_item</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="shrink">False</property>
+             <property name="resize">False</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkFrame" id="frame2">
+             <property name="border_width">4</property>
+             <property name="visible">True</property>
+             <property name="label_xalign">0</property>
+             <property name="label_yalign">0.5</property>
+             <property name="shadow_type">GTK_SHADOW_ETCHED_IN</property>
+
+             <child>
+               <widget class="GtkVBox" id="vbox6">
+                 <property name="visible">True</property>
+                 <property name="homogeneous">False</property>
+                 <property name="spacing">0</property>
+
+                 <child>
+                   <widget class="GtkScrolledWindow" id="scrolledwindow2">
+                     <property name="visible">True</property>
+                     <property name="hscrollbar_policy">GTK_POLICY_ALWAYS</property>
+                     <property name="vscrollbar_policy">GTK_POLICY_ALWAYS</property>
+                     <property name="shadow_type">GTK_SHADOW_IN</property>
+                     <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+                     <child>
+                       <widget class="GtkTreeView" id="hintsCList">
+                         <property name="visible">True</property>
+                         <property name="can_focus">True</property>
+                         <property name="headers_visible">True</property>
+                         <property name="rules_hint">False</property>
+                         <property name="reorderable">False</property>
+                         <property name="enable_search">True</property>
+                       </widget>
+                     </child>
+                   </widget>
+                   <packing>
+                     <property name="padding">0</property>
+                     <property name="expand">True</property>
+                     <property name="fill">True</property>
+                   </packing>
+                 </child>
+               </widget>
+             </child>
+
+             <child>
+               <widget class="GtkLabel" id="label13">
+                 <property name="visible">True</property>
+                 <property name="label" translatable="yes">Hints</property>
+                 <property name="use_underline">False</property>
+                 <property name="use_markup">False</property>
+                 <property name="justify">GTK_JUSTIFY_LEFT</property>
+                 <property name="wrap">False</property>
+                 <property name="selectable">False</property>
+                 <property name="xalign">0.5</property>
+                 <property name="yalign">0.5</property>
+                 <property name="xpad">0</property>
+                 <property name="ypad">0</property>
+               </widget>
+               <packing>
+                 <property name="type">label_item</property>
+               </packing>
+             </child>
+           </widget>
+           <packing>
+             <property name="shrink">True</property>
+             <property name="resize">True</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkStatusbar" id="mainWindowStatusBar">
+         <property name="has_resize_grip">True</property>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkWindow" id="subscribeWindow">
+  <property name="title" translatable="yes">Hbugs: subscribe ...</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">False</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+
+  <child>
+    <widget class="GtkVBox" id="vbox8">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child>
+       <widget class="GtkButton" id="listTutorsButton">
+         <property name="visible">True</property>
+         <property name="can_focus">True</property>
+         <property name="label" translatable="yes">Refresh</property>
+         <property name="use_underline">True</property>
+         <property name="relief">GTK_RELIEF_NORMAL</property>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkScrolledWindow" id="scrolledwindow4">
+         <property name="visible">True</property>
+         <property name="hscrollbar_policy">GTK_POLICY_ALWAYS</property>
+         <property name="vscrollbar_policy">GTK_POLICY_ALWAYS</property>
+         <property name="shadow_type">GTK_SHADOW_IN</property>
+         <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+         <child>
+           <widget class="GtkTreeView" id="tutorsCList">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="headers_visible">True</property>
+             <property name="rules_hint">False</property>
+             <property name="reorderable">False</property>
+             <property name="enable_search">True</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkHBox" id="hbox5">
+         <property name="visible">True</property>
+         <property name="homogeneous">False</property>
+         <property name="spacing">0</property>
+
+         <child>
+           <widget class="GtkButton" id="subscribeButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">Subscribe to Selected</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+
+         <child>
+           <widget class="GtkButton" id="subscribeAllButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">Subscribe to All</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+           </widget>
+           <packing>
+             <property name="padding">0</property>
+             <property name="expand">True</property>
+             <property name="fill">True</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkStatusbar" id="subscribeWindowStatusBar">
+         <property name="visible">True</property>
+         <property name="has_resize_grip">True</property>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">False</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+<widget class="GtkDialog" id="messageDialog">
+  <property name="title" translatable="yes">Message</property>
+  <property name="type">GTK_WINDOW_TOPLEVEL</property>
+  <property name="window_position">GTK_WIN_POS_NONE</property>
+  <property name="modal">True</property>
+  <property name="default_width">220</property>
+  <property name="default_height">150</property>
+  <property name="resizable">True</property>
+  <property name="destroy_with_parent">False</property>
+  <property name="has_separator">True</property>
+
+  <child internal-child="vbox">
+    <widget class="GtkVBox" id="dialogVbox1">
+      <property name="visible">True</property>
+      <property name="homogeneous">False</property>
+      <property name="spacing">0</property>
+
+      <child internal-child="action_area">
+       <widget class="GtkHButtonBox" id="dialogAction_area1">
+         <property name="visible">True</property>
+         <property name="layout_style">GTK_BUTTONBOX_END</property>
+
+         <child>
+           <widget class="GtkButton" id="okDialogButton">
+             <property name="visible">True</property>
+             <property name="can_focus">True</property>
+             <property name="label" translatable="yes">OK</property>
+             <property name="use_underline">True</property>
+             <property name="relief">GTK_RELIEF_NORMAL</property>
+             <property name="response_id">0</property>
+           </widget>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">False</property>
+         <property name="fill">True</property>
+         <property name="pack_type">GTK_PACK_END</property>
+       </packing>
+      </child>
+
+      <child>
+       <widget class="GtkTable" id="table1">
+         <property name="border_width">5</property>
+         <property name="visible">True</property>
+         <property name="n_rows">1</property>
+         <property name="n_columns">1</property>
+         <property name="homogeneous">False</property>
+         <property name="row_spacing">0</property>
+         <property name="column_spacing">0</property>
+
+         <child>
+           <widget class="GtkLabel" id="dialogLabel">
+             <property name="visible">True</property>
+             <property name="label" translatable="yes"></property>
+             <property name="use_underline">False</property>
+             <property name="use_markup">False</property>
+             <property name="justify">GTK_JUSTIFY_CENTER</property>
+             <property name="wrap">True</property>
+             <property name="selectable">False</property>
+             <property name="xalign">0.5</property>
+             <property name="yalign">0.5</property>
+             <property name="xpad">0</property>
+             <property name="ypad">0</property>
+           </widget>
+           <packing>
+             <property name="left_attach">0</property>
+             <property name="right_attach">1</property>
+             <property name="top_attach">0</property>
+             <property name="bottom_attach">1</property>
+           </packing>
+         </child>
+       </widget>
+       <packing>
+         <property name="padding">0</property>
+         <property name="expand">True</property>
+         <property name="fill">True</property>
+       </packing>
+      </child>
+    </widget>
+  </child>
+</widget>
+
+</glade-interface>

diff --git a/helm/ocaml/hbugs/hbugs_common.ml b/helm/ocaml/hbugs/hbugs_common.ml
new file mode 100644 (file)
index 0000000..fe2ecfc
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_common.ml
@@ -0,0 +1,48 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..2d51075
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_common.mli
@@ -0,0 +1,32 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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 (file)
index 0000000..5b1998a
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_id_generator.ml
@@ -0,0 +1,67 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..dad0c93
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_id_generator.mli
@@ -0,0 +1,35 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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 (file)
index 0000000..4767b2a
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_messages.ml
@@ -0,0 +1,368 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 <?xml ... ?> declaration nor
+    DOCTYPE one *)
+    "<gTopLevelStatus>\n" ^
+    (sprintf "<CurrentGoal>%d</CurrentGoal>\n" goal) ^
+    type_string ^ "\n" ^
+    body_string ^ "\n" ^
+    "</gTopLevelStatus>\n"
+  | None -> "<gTopLevelStatus />\n"
+
+let rec pp_hint = function
+  | Use_ring -> sprintf "<ring />"
+  | Use_fourier -> sprintf "<fourier />"
+  | Use_reflexivity -> sprintf "<reflexivity />"
+  | Use_symmetry -> sprintf "<symmetry />"
+  | Use_assumption -> sprintf "<assumption />"
+  | Use_contradiction -> sprintf "<contradiction />"
+  | Use_exists -> sprintf "<exists />"
+  | Use_split -> sprintf "<split />"
+  | Use_left -> sprintf "<left />"
+  | Use_right -> sprintf "<right />"
+  | Use_apply term -> sprintf "<apply>%s</apply>" term
+  | Hints hints ->
+      sprintf "<hints>\n%s\n</hints>"
+        (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<tutor_dsc id=\"%s\">%s</tutor_dsc>" s id dsc)
+    ""
+let pp_tutor_ids =
+  List.fold_left (fun s id -> sprintf "%s<tutor id=\"%s\" />" s id) ""
+
+let string_of_msg = function
+  | Help -> "<help />"
+  | Usage usage_string -> sprintf "<usage>%s</usage>" usage_string
+  | Exception (name, value) ->
+      sprintf "<exception name=\"%s\">%s</exception>" name value
+  | Register_client (id, url) ->
+      sprintf "<register_client id=\"%s\" url=\"%s\" />" id url
+  | Unregister_client id -> sprintf "<unregister_client id=\"%s\" />" id
+  | List_tutors id -> sprintf "<list_tutors id=\"%s\" />" id
+  | Subscribe (id, tutor_ids) ->
+      sprintf "<subscribe id=\"%s\">%s</subscribe>"
+        id (pp_tutor_ids tutor_ids)
+  | State_change (id, state) ->
+      sprintf "<state_change id=\"%s\">%s</state_change>"
+        id (pp_state state)
+  | Wow id -> sprintf "<wow id=\"%s\" />" id
+  | Register_tutor (id, url, hint_type, dsc) ->
+      sprintf
+"<register_tutor id=\"%s\" url=\"%s\">
+<hint_type>%s</hint_type>
+<description>%s</description>
+</register_tutor>"
+        id url (pp_hint_type hint_type) dsc
+  | Unregister_tutor id -> sprintf "<unregister_tutor id=\"%s\" />" id
+  | Musing_started (id, musing_id) ->
+      sprintf "<musing_started id=\"%s\" musing_id=\"%s\" />" id musing_id
+  | Musing_aborted (id, musing_id) ->
+      sprintf "<musing_aborted id=\"%s\" musing_id=\"%s\" />" id musing_id
+  | Musing_completed (id, musing_id, result) ->
+      sprintf
+        "<musing_completed id=\"%s\" musing_id=\"%s\">%s</musing_completed>"
+        id musing_id
+        (match result with
+        | Sorry -> "<sorry />"
+        | Eureka hint -> sprintf "<eureka>%s</eureka>" (pp_hint hint))
+  | Client_registered id -> sprintf "<client_registered id=\"%s\" />" id
+  | Client_unregistered id -> sprintf "<client_unregistered id=\"%s\" />" id
+  | Tutor_list (id, tutor_dscs) ->
+      sprintf "<tutor_list id=\"%s\">%s</tutor_list>"
+        id (pp_tutor_dscs tutor_dscs)
+  | Subscribed (id, tutor_ids) ->
+      sprintf "<subscribed id=\"%s\">%s</subscribed>"
+        id (pp_tutor_ids tutor_ids)
+  | State_accepted (id, stop_ids, start_ids) ->
+      sprintf
+"<state_accepted id=\"%s\">
+<stopped>%s</stopped>
+<started>%s</started>
+</state_accepted>"
+        id
+        (String.concat ""
+          (List.map (fun id -> sprintf "<musing id=\"%s\" />" id) stop_ids))
+        (String.concat ""
+          (List.map (fun id -> sprintf "<musing id=\"%s\" />" id) start_ids))
+  | Hint (id, hint) -> sprintf "<hint id=\"%s\">%s</hint>" id (pp_hint hint)
+  | Tutor_registered id -> sprintf "<tutor_registered id=\"%s\" />" id
+  | Tutor_unregistered id -> sprintf "<tutor_unregistered id=\"%s\" />" id
+  | Start_musing (id, state) ->
+      sprintf "<start_musing id=\"%s\">%s</start_musing>"
+        id (pp_state (Some state))
+  | Abort_musing (id, musing_id) ->
+      sprintf "<abort_musing id=\"%s\" musing_id=\"%s\" />" id musing_id
+  | Thanks (id, musing_id) ->
+      sprintf "<thanks id=\"%s\" musing_id=\"%s\" />" id musing_id
+  | Too_late (id, musing_id) ->
+      sprintf "<too_late id=\"%s\" musing_id=\"%s\" />" id musing_id
+;;
+
+  (* debugging function that dump on stderr the sent messages *)
+let dump_msg msg =
+  if debug >= 2 then
+    prerr_endline
+      (sprintf "<SENDING_MESSAGE>\n%s\n</SENDING_MESSAGE>"
+        (match msg with
+        | State_change _ -> "<state_change>omissis ...</state_change>"
+        | 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 (file)
index 0000000..642c0b0
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_messages.mli
@@ -0,0 +1,49 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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 (file)
index 0000000..32b8e8b
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_misc.ml
@@ -0,0 +1,122 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..b0ef597
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_misc.mli
@@ -0,0 +1,50 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+  (** 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 (file)
index 0000000..6a73e2c
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_tutors.ml
@@ -0,0 +1,266 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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
+  "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n\n" ^
+  "<!DOCTYPE " ^ root ^ " SYSTEM \""^ dtdname ^ "\">\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 (file)
index 0000000..43cd99c
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_tutors.mli
@@ -0,0 +1,60 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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 (file)
index 0000000..e3067f2
--- /dev/null
+++ b/helm/ocaml/hbugs/hbugs_types.mli
@@ -0,0 +1,104 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+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 (executable)
index 0000000..3da998d
--- /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 (executable)
index 0000000..9b742d8
--- /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 <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+#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
+  <pattern,template> 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 (executable)
index 0000000..5fe796c
--- /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 <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* 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 (executable)
index 0000000..2031e29
--- /dev/null
+++ b/helm/ocaml/hbugs/scripts/sabba.sh
@@ -0,0 +1,47 @@
+#!/bin/sh
+# Copyright (C) 2003:
+#    Stefano Zacchiroli <zack@cs.unibo.it>
+#    for the HELM Team http://helm.cs.unibo.it/
+# 
+#  This file is part of HELM, an Hypertextual, Electronic
+#  Library of Mathematics, developed at the Computer Science
+#  Department, University of Bologna, Italy.
+# 
+#  HELM is free software; you can redistribute it and/or
+#  modify it under the terms of the GNU General Public License
+#  as published by the Free Software Foundation; either version 2
+#  of the License, or (at your option) any later version.
+# 
+#  HELM is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+# 
+#  You should have received a copy of the GNU General Public License
+#  along with HELM; if not, write to the Free Software
+#  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+#  MA  02111-1307, USA.
+# 
+#  For details, see the HELM World-Wide-Web page,
+#  http://helm.cs.unibo.it/
+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 (file)
index 0000000..79c94be
--- /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 (file)
index 0000000..cf15dde
--- /dev/null
+++ b/helm/ocaml/hbugs/test/HBUGS_MESSAGES.xml
@@ -0,0 +1,144 @@
+<test>
+
+    <!-- general purpose -->
+
+  <help />
+
+  <usage>usage string</usage>
+
+  <exception name='eccezione1'>corpo dell'exc</exception>
+
+    <!-- client -> broker -->
+
+  <register_client id='client_id' url='client_url' />
+
+  <unregister_client id='client_id' />
+
+  <list_tutors id='client_id' />
+
+  <subscribe id='client_id'>
+    <tutor id='tutor_id1' />
+    <tutor id='tutor_id2' />
+    <!-- .... -->
+    <tutor id='tutor_idN' />
+  </subscribe>
+
+  <state_change id='client_id'> <!-- new state received -->
+    <gTopLevelStatus>
+      <CurrentGoal>0</CurrentGoal>
+      <ConstantType>
+      </ConstantType>
+      <CurrentProof>
+      </CurrentProof>
+    </gTopLevelStatus>
+  </state_change>
+
+  <state_change id='client_id'> <!-- no state received: proof is completed -->
+    <gTopLevelStatus />
+  </state_change>
+
+  <wow id="client_id" />
+
+    <!-- tutor -> broker -->
+
+  <register_tutor id='tutor_id' url='tutor_url'>
+    <hint_type>
+      <!-- HINT TYPE -->
+    </hint_type>
+    <description>
+      descrizione del tutor
+    </description>
+  </register_tutor>
+
+  <unregister_tutor id='tutor_id' />
+
+  <musing_started id='tutor_id' musing_id='musing_id' />
+
+  <musing_aborted id='tutor_id' musing_id='musing_id' />
+
+  <musing_completed id='tutor_id' musing_id='musing_id'>
+    <sorry />
+  </musing_completed>
+
+  <musing_completed id='tutor_id' musing_id='musing_id'>
+    <eureka>
+      <ring />
+    </eureka>
+  </musing_completed>
+
+  <musing_completed id='tutor_id' musing_id='musing_id'>
+    <eureka>
+      <hints>
+        <ring />
+        <fourier />
+      </hints>
+    </eureka>
+  </musing_completed>
+
+    <!-- broker -> client -->
+
+  <client_registered id='broker_id' />
+
+  <client_unregistered id='broker_id' />
+
+  <tutor_list id='broker_id'>
+    <tutor_dsc id='tutor_id1'> description 1 </tutor_dsc>
+    <tutor_dsc id='tutor_id2'> description 2 </tutor_dsc>
+    <!-- ... -->
+    <tutor_dsc id='tutor_idN'> description N </tutor_dsc>
+  </tutor_list>
+
+  <subscribed id='broker_id'>
+    <tutor_dsc id='tutor_id1'> description 1 </tutor_dsc>
+    <tutor_dsc id='tutor_id2'> description 2 </tutor_dsc>
+    <!-- ... -->
+    <tutor_dsc id='tutor_idN'> description N </tutor_dsc>
+  </subscribed>
+
+  <state_accepted id='broker_id'>
+    <stopped>
+      <musing id='musing_id1' />
+      <!-- ... -->
+      <musing id='musing_idN' />
+    </stopped>
+    <started>
+      <musing id='musing_id1' />
+      <!-- ... -->
+      <musing id='musing_idM' />
+    </started>
+  </state_accepted>
+
+  <hint id='broker_id'>
+    <ring />
+  </hint>
+
+  <hint id='broker_id'>
+    <hints>
+      <ring />
+      <fourier />
+    </hints>
+  </hint>
+
+    <!-- broker -> tutor -->
+
+  <tutor_registered id='broker_id' />
+
+  <tutor_unregistered id='broker_id' />
+
+  <start_musing id='broker_id'>
+    <gTopLevelStatus>
+      <CurrentGoal>0</CurrentGoal>
+      <ConstantType>
+      </ConstantType>
+      <CurrentProof>
+      </CurrentProof>
+    </gTopLevelStatus>
+  </start_musing>
+
+  <abort_musing id='broker_id' musing_id='musing_id' />
+
+  <thanks id='broker_id' musing_id='musing_id' />
+
+  <too_late id='broker_id' musing_id='musing_id' />
+
+</test>

diff --git a/helm/ocaml/hbugs/test/Makefile b/helm/ocaml/hbugs/test/Makefile
new file mode 100644 (file)
index 0000000..0b3debf
--- /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 (file)
index 0000000..1afd743
--- /dev/null
+++ b/helm/ocaml/hbugs/test/test_serialization.ml
@@ -0,0 +1,70 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+open 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 (file)
index 0000000..bf9c09a
--- /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 (file)
index 0000000..a7bb4db
--- /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 (file)
index 0000000..97a15b7
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..25d642b
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..eb6a764
--- /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 <?xml ...?> 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 (file)
index 0000000..45d0e95
--- /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 (file)
index 0000000..e67a066
--- /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 (file)
index 0000000..2ae1d4e
--- /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 (file)
index 0000000..94f3efe
--- /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 (file)
index 0000000..a5b9059
--- /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 (file)
index 0000000..452167c
--- /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 (file)
index 0000000..0e9c095
--- /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 (file)
index 0000000..1d18691
--- /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 (file)
index 0000000..944438d
--- /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 (file)
index 0000000..5f65124
--- /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 (file)
index 0000000..e8d9b94
--- /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 (file)
index 0000000..aed4b0b
--- /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 (file)
index 0000000..e49a66f
--- /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 (file)
index 0000000..b7ad59f
--- /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 (file)
index 0000000..aec759c
--- /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 (file)
index 0000000..a2232fe
--- /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 (file)
index 0000000..7b9422d
--- /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 (file)
index 0000000..930d73f
--- /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 (file)
index 0000000..d7fa27f
--- /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 (file)
index 0000000..62d8b97
--- /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 (file)
index 0000000..5054959
--- /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 (file)
index 0000000..74a61ae
--- /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 (file)
index 0000000..fe636ee
--- /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 (file)
index 0000000..c9eaf0a
--- /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 (file)
index 0000000..fb3c065
--- /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 (file)
index 0000000..f1f84c9
--- /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 (file)
index 0000000..775292c
--- /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 (file)
index 0000000..b966f31
--- /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 (file)
index 0000000..0106532
--- /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 (file)
index 0000000..9e8bf5e
--- /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 (file)
index 0000000..cd958a8
--- /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 (file)
index 0000000..1923a96
--- /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 (file)
index 0000000..d09769f
--- /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 (file)
index 0000000..deca8f4
--- /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 (file)
index 0000000..f040433
--- /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 (file)
index 0000000..39aa7c0
--- /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 (file)
index 0000000..3f1931e
--- /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 (file)
index 0000000..e4d07fa
--- /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 (file)
index 0000000..9ac42a5
--- /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 (file)
index 0000000..1521f45
--- /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 (file)
index 0000000..fe631ed
--- /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 (file)
index 0000000..43ac34d
--- /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 (file)
index 0000000..c67e1fc
--- /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 (file)
index 0000000..28268d2
--- /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 (file)
index 0000000..dab9f5c
--- /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 (file)
index 0000000..c416747
--- /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 "<ul>\n%s\n</ul>"
+        (String.concat "\n"
+          (List.map
+            (fun msg -> sprintf "<li>%s</li>" (html_of_html_tag msg))
+            msgs))
+  | `BR -> "<br />\n"
+  | `DIV (indent, color, tag) ->
+      sprintf "<div style=\"%smargin-left:%fcm\">\n%s\n</div>"
+        (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 -> "<b>Error: " ^ html_of_html_tag tag ^ "</b>"
+    | `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 (file)
index 0000000..633b5c3
--- /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 (file)
index 0000000..e69de29

diff --git a/helm/ocaml/mathql/Makefile b/helm/ocaml/mathql/Makefile
new file mode 100644 (file)
index 0000000..17cafb4
--- /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 (file)
index 0000000..2504cfb
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..0dc5572
--- /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 (file)
index 0000000..cf8e820
--- /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 (file)
index 0000000..261b293
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..b6a5140
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..0a67c2d
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..a9fbef4
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..1d7e859
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..5282833
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..9ed2ce2
--- /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        <fguidi@cs.unibo.it>
+ *          Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> 
+ *)
+
+(* $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 (file)
index 0000000..7603ab9
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..065abb1
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* 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 (file)
index 0000000..784bc11
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..decaa0e
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* 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 (file)
index 0000000..186c817
--- /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 (file)
index 0000000..bdd7381
--- /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 (file)
index 0000000..270d1f9
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..35c8b3e
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..a5b6654
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..50f5bb0
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..3380e1f
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..8afaf40
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..bef0723
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..cbbf392
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..0e3e2be
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..f8159aa
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..ad4a8cb
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..3f3fe65
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..76735a8
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..9280a2c
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..9d7081f
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..ca51751
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+{ 
+   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 (file)
index 0000000..2f88961
--- /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 <fguidi@cs.unibo.it>
+ */ 
+
+%{
+   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    <string> 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     <string>        qstr      
+   %type     <MathQL.query>  query
+   %type     <MathQL.result> 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 (file)
index 0000000..6323cc9
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+(* $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 (file)
index 0000000..5754002
--- /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 <fguidi@cs.unibo.it>
+ *)
+
+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 (file)
index 0000000..0419795
--- /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 (file)
index 0000000..29ca2d3
--- /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 (executable)
index 0000000..e7b4366
--- /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 (file)
index 0000000..e69de29

diff --git a/helm/ocaml/metadata/extractor/Makefile b/helm/ocaml/metadata/extractor/Makefile
new file mode 100644 (file)
index 0000000..e58064b
--- /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 (file)
index 0000000..8dbc9a9
--- /dev/null
+++ b/helm/ocaml/metadata/extractor/extractor.conf.xml
@@ -0,0 +1,19 @@
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+  <section name="tmp">
+    <key name="dir">.tmp/</key>
+  </section>   
+  <section name="db">
+    <key name="host">localhost</key>
+    <key name="user">helm</key>
+    <key name="database">mowgli</key>
+  </section>
+  <section name="getter">
+    <key name="servers">
+      file:///projects/helm/library/coq_contribs
+    </key>
+    <key name="cache_dir">$(tmp.dir)/cache</key>
+    <key name="maps_dir">$(tmp.dir)/maps</key>
+    <key name="dtd_dir">/projects/helm/xml/dtd</key>
+  </section>
+</helm_registry>

diff --git a/helm/ocaml/metadata/extractor/extractor.ml b/helm/ocaml/metadata/extractor/extractor.ml
new file mode 100644 (file)
index 0000000..418d5ff
--- /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 (file)
index 0000000..05393b6
--- /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 (file)
index 0000000..07fcc73
--- /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 (file)
index 0000000..63757ae
--- /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, constants>
+  * 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 (file)
index 0000000..457545d
--- /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 (file)
index 0000000..86820aa
--- /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 (file)
index 0000000..4fbae1b
--- /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 (file)
index 0000000..68af269
--- /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 <uri, shortname, metadata> *)
+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 (file)
index 0000000..373ec54
--- /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 (file)
index 0000000..cffb24c
--- /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 (file)
index 0000000..e186b37
--- /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 (file)
index 0000000..f86ff84
--- /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 (file)
index 0000000..a080739
--- /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 (file)
index 0000000..9f9af55
--- /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 <table name, table type>; 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 (file)
index 0000000..1cf113d
--- /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 (file)
index 0000000..cb8ab76
--- /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 (executable)
index 0000000..7b20138
--- /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 (file)
index 0000000..423edfb
--- /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 (file)
index 0000000..7c6673b
--- /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 (file)
index 0000000..35b650e
--- /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 (file)
index 0000000..98deef5
--- /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 (file)
index 0000000..1dffb63
--- /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 (file)
index 0000000..d7c3bec
--- /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 (file)
index 0000000..2d9076a
--- /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 (file)
index 0000000..04cdb0a
--- /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 (file)
index 0000000..30927dc
--- /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 (file)
index 0000000..bec5976
--- /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 (file)
index 0000000..eb4a35d
--- /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 (file)
index 0000000..ba6b2eb
--- /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 (file)
index 0000000..5eb591c
--- /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 (file)
index 0000000..d52483d
--- /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 (executable)
index 0000000..cd9f09c
--- /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 (file)
index 0000000..cf4f36b
--- /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 (file)
index 0000000..9aee600
--- /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 (file)
index 0000000..4d3e0a5
--- /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 (file)
index 0000000..42316a2
--- /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))
+
+  (** <helpers> *)
+
+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 []
+
+  (** </helpers> *)
+
+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
+    (* <section> elements entered so far *)
+  let in_key = ref false in (* have we entered a <key> element? *)
+  let cdata = ref "" in     (* collected cdata (inside <key> *)
+  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 (file)
index 0000000..1ef1aa3
--- /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 <application>.<setting>:
+ *   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 (file)
index 0000000..d0b91a2
--- /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 (file)
index 0000000..b0f91f3
--- /dev/null
+++ b/helm/ocaml/registry/tests/sample.xml
@@ -0,0 +1,34 @@
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+  <section name="annotations">
+    <key name="dir">file:///home/zack/miohelm/objects</key>
+    <key name="url">file:///home/zack/miohelm/objects</key>
+  </section>
+  <section name="getter">
+    <key name="mode">remote</key>
+    <key name="url">http://localhost:58081</key>
+  </section>
+  <section name="triciclo">
+    <key name="merge1">yes</key>
+  </section>
+  <section name="triciclo">
+    <include href="sample_include.xml" />
+  </section>
+  <section name="triciclo">
+    <key name="merge2">yes</key>
+  </section>
+  <section name="types">
+    <key name="string">debian</key>
+    <key name="int">1</key>
+    <key name="bool">false</key>
+    <key name="float">2.5</key>
+    <key name="int_list">11</key>
+    <key name="int_list">13</key>
+    <key name="int_list">17</key>
+    <key name="int_list">19</key>
+    <key name="int_float_pair">19 23.2</key>
+  </section>
+  <section name="uwobo">
+    <key name="url">http://localhost:58080/</key>
+  </section>
+</helm_registry>

diff --git a/helm/ocaml/registry/tests/sample_include.xml b/helm/ocaml/registry/tests/sample_include.xml
new file mode 100644 (file)
index 0000000..8a68519
--- /dev/null
+++ b/helm/ocaml/registry/tests/sample_include.xml
@@ -0,0 +1,15 @@
+<helm_registry>
+  <section name="foo1">
+    <key name="bar2">aaa</key>
+    <key name="bar3">bbb</key>
+  </section>
+  <section name="foo2">
+    <key name="bar1">quux</key>
+  </section>
+  <key name="basedir">/public/helm_library</key>
+  <key name="constant_type_file">$(triciclo.basedir)/constanttype</key>
+  <key name="environment_file">$(triciclo.basedir)/environment</key>
+  <key name="inner_types_file">$(triciclo.basedir)/innertypes</key>
+  <key name="proof_file">$(triciclo.basedir)/currentproof</key>
+  <key name="proof_file_type">$(triciclo.basedir)/currentprooftype</key>
+</helm_registry>

diff --git a/helm/ocaml/tactics/.depend b/helm/ocaml/tactics/.depend
new file mode 100644 (file)
index 0000000..95131ec
--- /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 (file)
index 0000000..1595fb3
--- /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 (file)
index 0000000..dc5b832
--- /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 (file)
index 0000000..696c970
--- /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 (file)
index 0000000..3ed167a
--- /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 <abs>"
+
+  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 (file)
index 0000000..d40202d
--- /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 (file)
index 0000000..9e5bc7f
--- /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 (file)
index 0000000..f115325
--- /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 (file)
index 0000000..b7d8fb4
--- /dev/null
+++ b/helm/ocaml/tactics/doc/Makefile
@@ -0,0 +1,124 @@
+
+#
+# Generic makefile for latex
+#
+# Author: Stefano Zacchiroli <zack@bononia.it>
+#
+# 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 (file)
index 0000000..8b7bbc9
--- /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 (file)
index 0000000..fc4afea
--- /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 <return> 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&#2\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 (file)
index 0000000..a914d91
--- /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 <return> 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 (file)
index 0000000..06952d6
--- /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 (file)
index 0000000..c0d56b8
--- /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 <return> 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 <return> 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 (file)
index 0000000..98257ca
--- /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 <return> 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 (file)
index 0000000..b73af44
--- /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 <return> 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 (file)
index 0000000..02202b3
--- /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 <return> 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 <return> 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 <return> 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 (file)
index 0000000..e98bcd3
--- /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 (file)
index 0000000..cf6589f
--- /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 (file)
index 0000000..8304d7b
--- /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 (file)
index 0000000..1d60ae1
--- /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 (file)
index 0000000..d7728c0
--- /dev/null
+++ b/helm/ocaml/tactics/fourier.ml
@@ -0,0 +1,244 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Méthode d'élimination de Fourier *)
+(* Référence:
+Auteur(s) : Fourier, Jean-Baptiste-Joseph
+ 
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+ 
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+ 
+Pages: 326-327
+
+http://gallica.bnf.fr/
+*)
+
+(** @author The Coq Development Team *)
+
+
+(* Un peu de calcul sur les rationnels... 
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
+*)
+
+
+(** Type for coefficents *)
+type rational = {
+num:int; (** Numerator *)
+den:int;  (** Denumerator *)
+};;
+
+(** Debug function.
+    @param x the rational to print*)
+let print_rational x =
+        print_int x.num;
+        print_string "/";
+        print_int x.den
+;;
+
+let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
+
+(** The constant 0*)
+let r0 = {num=0;den=1};;
+(** The constant 1*)
+let r1 = {num=1;den=1};;
+
+let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
+              if x.num=0 then r0
+              else (let d=pgcd x.num x.den in
+                   let d= (if d<0 then -d else d) in
+                    {num=(x.num)/d;den=(x.den)/d});;
+
+(** Calculates the opposite of a rational.
+    @param x The rational
+    @return -x*)
+let rop x = rnorm {num=(-x.num);den=x.den};;
+
+(** Sums two rationals.
+    @param x A rational
+    @param y Another rational
+    @return x+y*)
+let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
+(** Substracts two rationals.
+    @param x A rational
+    @param y Another rational
+    @return x-y*)
+let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
+(** Multiplyes two rationals.
+    @param x A rational
+    @param y Another rational
+    @return x*y*)
+let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
+(** Inverts arational.
+    @param x A rational
+    @return x{^ -1} *)
+let rinv x = rnorm {num=x.den;den=x.num};;
+(** Divides two rationals.
+    @param x A rational
+    @param y Another rational
+    @return x/y*)
+let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
+
+let rinf x y = x.num*y.den < y.num*x.den;;
+let rinfeq x y = x.num*y.den <= y.num*x.den;;
+
+
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+c1x1+...+cnxn < d si strict=true, <= sinon,
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+*)
+
+type ineq = {coef:rational list;
+             hist:rational list;
+             strict:bool};;
+
+let pop x l = l:=x::(!l);;
+
+(* sépare la liste d'inéquations s selon que leur premier coefficient est 
+négatif, nul ou positif. *)
+let partitionne s =
+   let lpos=ref [] in
+   let lneg=ref [] in
+   let lnul=ref [] in
+   List.iter (fun ie -> match ie.coef with
+                        [] ->  raise (Failure "empty ineq")
+                       |(c::r) -> if rinf c r0
+                                 then pop ie lneg
+                                  else if rinf r0 c then pop ie lpos
+                                              else pop ie lnul)
+             s;
+   [!lneg;!lnul;!lpos]
+;;
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
+=
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
+ ...
+ {équation n, [0;0;...;1], sn}]
+*)
+let add_hist le =
+   let n = List.length le in
+   let i=ref 0 in
+   List.map (fun (ie,s) -> 
+              let h =ref [] in
+              for k=1 to (n-(!i)-1) do pop r0 h; done;
+              pop r1 h;
+              for k=1 to !i do pop r0 h; done;
+              i:=!i+1;
+              {coef=ie;hist=(!h);strict=s})
+             le
+;;
+(* additionne deux inéquations *)      
+let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
+                      hist=List.map2 rplus ie1.hist ie2.hist;
+                     strict=ie1.strict || ie2.strict}
+;;
+(* multiplication d'une inéquation par un rationnel (positif) *)
+let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
+                     hist=List.map (fun x -> rmult a x) ie.hist;
+                    strict= ie.strict}
+;;
+(* on enlève le premier coefficient *)
+let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
+;;
+(* le premier coefficient: "tête" de l'inéquation *)
+let hd_coef ie = List.hd ie.coef
+;;
+
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+*)
+let deduce_add lneg lpos =
+   let res=ref [] in
+   List.iter (fun i1 ->
+                List.iter (fun i2 ->
+                               let a = rop (hd_coef i1) in
+                               let b = hd_coef i2 in
+                               pop (ie_tl (ie_add (ie_emult b i1)
+                                                  (ie_emult a i2))) res)
+                          lpos)
+             lneg;
+   !res
+;;
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
+*)
+let deduce1 s i=
+    match (partitionne s) with 
+      [lneg;lnul;lpos] ->
+         let lnew = deduce_add lneg lpos in
+        (match lneg with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->();
+         match lpos with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->());
+         (List.map ie_tl lnul)@lnew
+   |_->assert false
+;;
+(* algorithme de Fourier: on élimine successivement toutes les variables.
+*)
+let deduce lie =
+   let n = List.length (fst (List.hd lie)) in
+   let lie=ref (add_hist lie) in
+   for i=1 to n-1 do
+      lie:= deduce1 !lie i;
+   done;
+   !lie
+;;
+
+(* donne [] si le système a des  find solutions,
+sinon donne [c,s,lc]
+où lc est la combinaison linéaire des inéquations de départ
+qui donne 0 < c si s=true
+       ou 0 <= c sinon
+cette inéquation étant absurde.
+*)
+(** Tryes to find if the system admits solutions.
+    @param lie the list of inequations 
+    @return a list that can be empty if the system has solutions. Otherwise it returns a
+            one elements list [\[(c,s,lc)\]]. {b c} is the rational that can be obtained solving the system,
+           {b s} is true if the inequation that proves that the system is absurd is of type [c < 0], false if 
+           [c <= 0], {b lc} is a list of rational that represents the liear combination to obtain the
+           absurd inequation *)
+let unsolvable lie =
+   let lr = deduce lie in
+   let res = ref [] in
+   (try (List.iter (fun e ->
+         match e with
+           {coef=[c];hist=lc;strict=s} ->
+                 if (rinf c r0 && (not s)) || (rinfeq c r0 && s) 
+                  then (res := [c,s,lc];
+                       raise (Failure "contradiction found"))
+          |_->assert false)
+                            lr)
+   with _ -> ());
+   !res
+;;
+
+(* Exemples:
+
+let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
+deduce test1;;
+unsolvable test1;;
+
+let test2=[
+[r1;r1;r0;r0;r0],false;
+[r0;r1;r1;r0;r0],false;
+[r0;r0;r1;r1;r0],false;
+[r0;r0;r0;r1;r1],false;
+[r1;r0;r0;r0;r1],false;
+[rop r1;rop r1;r0;r0;r0],false;
+[r0;rop r1;rop r1;r0;r0],false;
+[r0;r0;rop r1;rop r1;r0],false;
+[r0;r0;r0;rop r1;rop r1],false;
+[rop r1;r0;r0;r0;rop r1],false
+];;
+deduce test2;;
+unsolvable test2;;
+
+*)

diff --git a/helm/ocaml/tactics/fourier.mli b/helm/ocaml/tactics/fourier.mli
new file mode 100644 (file)
index 0000000..8b26bc2
--- /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 (file)
index 0000000..5418e11
--- /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<n*1/d
+*)
+
+let tac_zero_inf_pos (n,d) =
+ let tac_zero_inf_pos (n,d) status =
+   (*let cste = pf_parse_constr gl in*)
+   let pall str (proof,goal) t =
+     debug ("tac "^str^" :\n" );
+     let curi,metasenv,pbo,pty = proof in
+     let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+     debug ("th = "^ CicPp.ppterm t ^"\n"); 
+     debug ("ty = "^ CicPp.ppterm ty^"\n"); 
+   in
+   let tacn=ref (mk_tactic (fun status -> 
+        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 (file)
index 0000000..e5790ec
--- /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 (file)
index 0000000..0bae64f
--- /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 (file)
index 0000000..d75b833
--- /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 (file)
index 0000000..8644826
--- /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 (file)
index 0000000..d2608b8
--- /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 (file)
index 0000000..7559f36
--- /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 (file)
index 0000000..86bad46
--- /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 (file)
index 0000000..9ed3647
--- /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 (file)
index 0000000..c3a1272
--- /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 (file)
index 0000000..6b563fe
--- /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 (file)
index 0000000..50bdf58
--- /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 (file)
index 0000000..b9c0536
--- /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 (file)
index 0000000..b65a23f
--- /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 (file)
index 0000000..7ee79e5
--- /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 (file)
index 0000000..bfa3e8d
--- /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 (file)
index 0000000..7a732a5
--- /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 (file)
index 0000000..01d200e
--- /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 (file)
index 0000000..cf7df2d
--- /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 (file)
index 0000000..a7c0e5b
--- /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 (file)
index 0000000..755a098
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..6724787
--- /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 (file)
index 0000000..4677a33
--- /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 (file)
index 0000000..91ebfec
--- /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 (file)
index 0000000..68ea561
--- /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 (file)
index 0000000..4396ea7
--- /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 (file)
index 0000000..115faa8
--- /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 (file)
index 0000000..16e2bc2
--- /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 (file)
index 0000000..4c58f10
--- /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 <uri, typeno, consno> where uri is the uri of an inductive
+    type, typeno is the type number in a mutind structure (0 based), consno is
+    the constructor number (1 based)
+    @exp_named_subst explicit named substitution
+  *)
+let mkCtor ~uri:(uri, typeno, consno) ~exp_named_subst =
+ Cic.MutConstruct (uri, typeno, consno, exp_named_subst)
+
+  (**
+    Create a Cic term consisting of a type member of a mutual induction
+    @param uri pair <uri, typeno> where uri is the uri of a mutual inductive
+    type and typeno is the type number (0 based) in the mutual induction
+    @exp_named_subst explicit named substitution
+  *)
+let mkMutInd ~uri:(uri, typeno) ~exp_named_subst =
+ Cic.MutInd (uri, typeno, exp_named_subst)
+
+(** EXCEPTIONS *)
+
+  (**
+    raised when the current goal is not ringable; a goal is ringable when is an
+    equality on reals (@see r_uri)
+  *)
+exception GoalUnringable
+
+(** RING's FUNCTIONS LIBRARY *)
+
+  (**
+    Check whether the ring tactic can be applied on a given term (i.e. that is
+    an equality on reals)
+    @param term to be tested
+    @return true if the term is ringable, false otherwise
+  *)
+let ringable =
+  let is_equality = function
+    | Cic.MutInd (uri, 0, []) when (eq uri 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 ("<term1>" ^ (CicPp.ppterm t1) ^ "</term1>"));
+        warn (lazy ("<term2>" ^ (CicPp.ppterm t2) ^ "</term2>"));
+        (t1, t2)
+  | _ -> raise GoalUnringable
+
+  (**
+    @param i an integer index representing a 1 based number of node in a binary
+    search tree counted in a fbs manner (i.e.: 1 is the root, 2 is the left
+    child of the root (if any), 3 is the right child of the root (if any), 4 is
+    the left child of the left child of the root (if any), ....)
+    @param proof the current proof
+    @return an index representing the same node in a varmap (@see varmap_uri),
+    the returned index is as defined in index (@see index_uri)
+  *)
+let path_of_int n =
+  let rec digits_of_int n =
+    if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+  in
+  List.fold_right
+    (fun digit path ->
+      Cic.Appl [
+        mkCtor (if (digit = true) then right_idx_uri else left_idx_uri) [];
+        path])
+    (List.rev (digits_of_int n)) (* remove leading true (i.e. digit 1) *)
+    (mkCtor end_idx_uri [])
+
+  (**
+    Build a variable map (@see varmap_uri) from a variables array.
+    A variable map is almost a binary tree so this function receiving a var list
+    like [v;w;x;y;z] will build a varmap of shape:       v
+                                                        / \
+                                                       w   x
+                                                      / \
+                                                     y   z
+    @param vars variables array
+    @return a cic term representing the variable map containing vars variables
+  *)
+let btree_of_array ~vars =
+  let r = 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 <aterms, varmap> where aterms is a list of abstract polynoms
+    and varmap is the variable map needed to interpret them
+  *)
+let abstract_poly ~terms =
+  let varhash = Hashtbl.create 19 in (* vars hash, to speed up lookup *)
+  let varlist = ref [] in  (* vars list in reverse order *)
+  let counter = ref 1 in  (* index of next new variable *)
+  let rec aux = function  (* TODO not tail recursive *)
+    (* "bop" -> binary operator | "uop" -> unary operator *)
+    | Cic.Appl (bop::t1::t2::[])
+      when (cic_is_const ~uri:(Some 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 (file)
index 0000000..b6eb34b
--- /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 (file)
index 0000000..9529c89
--- /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 (file)
index 0000000..4198876
--- /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 (file)
index 0000000..cb700f7
--- /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 <sacerdot@cs.unibo.it>              *)
+(*                                 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' =
+              "<h1 color=\"red\"> ^ Exception raised trying to apply " ^
+               uri ^ ": " ^ Printexc.to_string e ^ " </h1>" ^ exc
+             in
+              tl',exc'
+    in
+     filter_out uris
+  in
+    let html' =
+     " <h1>Objects that can actually be applied: </h1> " ^
+     String.concat "<br>" uris' ^ exc ^
+     " <h1>Number of false matches: " ^
+      string_of_int (List.length uris - List.length uris') ^ "</h1>" ^
+     " <h1>Number of good matches: " ^
+      string_of_int (List.length uris') ^ "</h1>"
+    in
+     output_html html' ;
+     uris'
+;;
+
+
+(*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 (file)
index 0000000..a674fe3
--- /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 <tactic> 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 (file)
index 0000000..88fafc1
--- /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 (file)
index 0000000..170d688
--- /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 (file)
index 0000000..25e479b
--- /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 (file)
index 0000000..fc6413e
--- /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 (file)
index 0000000..3557632
--- /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 (file)
index 0000000..7759190
--- /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 (file)
index 0000000..24a96b6
--- /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 (file)
index 0000000..d59cccd
--- /dev/null
+++ b/helm/ocaml/thread/extThread.ml
@@ -0,0 +1,110 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 (file)
index 0000000..5fb3bd4
--- /dev/null
+++ b/helm/ocaml/thread/extThread.mli
@@ -0,0 +1,35 @@
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(** {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 (file)
index 0000000..b2c4277
--- /dev/null
+++ b/helm/ocaml/thread/fake/threadSafe.ml
@@ -0,0 +1,35 @@
+(*
+ * Copyright (C) 2003-2005:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+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 (file)
index 0000000..78166ab
--- /dev/null
+++ b/helm/ocaml/thread/fake/threadSafe.mli
@@ -0,0 +1,44 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+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 (file)
index 0000000..afe9533
--- /dev/null
+++ b/helm/ocaml/thread/threadSafe.ml
@@ -0,0 +1,100 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+(* $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 "<doCritical>");
+        (try
+          Mutex.lock mutex;
+          let res = Lazy.force action in
+          Mutex.unlock mutex;
+          debug_print (lazy "</doCritical>");
+          res
+        with e ->
+          Mutex.unlock mutex;
+          raise e);
+
+    method private doReader: 'a. 'a lazy_t -> 'a =
+      fun action ->
+        debug_print (lazy "<doReader>");
+        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 "</doReader>");
+        res
+
+      (* TODO may starve!!!! is what we want or not? *)
+    method private doWriter: 'a. 'a lazy_t -> 'a =
+      fun action ->
+        debug_print (lazy "<doWriter>");
+        self#doCritical (lazy (
+          while readersCount > 0 do
+            Condition.wait noReaders mutex
+          done;
+          let res = Lazy.force action in
+          debug_print (lazy "</doWriter>");
+          res
+        ))
+
+  end
+

diff --git a/helm/ocaml/thread/threadSafe.mli b/helm/ocaml/thread/threadSafe.mli
new file mode 100644 (file)
index 0000000..78166ab
--- /dev/null
+++ b/helm/ocaml/thread/threadSafe.mli
@@ -0,0 +1,44 @@
+(*
+ * Copyright (C) 2003-2004:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
+ *)
+
+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 (file)
index 0000000..4821484
--- /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 (file)
index 0000000..afd7d44
--- /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 (file)
index 0000000..9ff6a79
--- /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 (file)
index 0000000..8250cc8
--- /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 (file)
index 0000000..f3c6a8b
--- /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 (file)
index 0000000..e3afd40
--- /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 (file)
index 0000000..210ecc0
--- /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<lambda>>
+
+  ---------------
+
+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 (file)
index 0000000..4799545
--- /dev/null
+++ b/helm/ocaml/utf8_macros/data/dictionary-tex.xml
@@ -0,0 +1,378 @@
+<?xml version="1.0"?>
+
+<!--
+ This file is part of EdiTeX, an editor of mathematical
+ expressions based on TeX syntax.
+ 
+ Copyright (C) 2002-2003 Luca Padovani <lpadovan@cs.unibo.it>,
+                    2003 Paolo Marinelli <pmarinel@cs.unibo.it>.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+ For more information, please visit the project's home page
+ http://helm.cs.unibo.it/editex/
+ or send an email to <lpadovan@cs.unibo.it>
+-->
+
+<dictionary name="TeX">
+
+  <include href="dictionary-basic.xml"/>
+
+  <!-- Greek Letters (lower case) -->
+
+  <entry name="alpha"      class="i" val="&#x03b1;"/>
+  <entry name="beta"       class="i" val="&#x03b2;"/>
+  <entry name="gamma"      class="i" val="&#x03b3;"/>
+  <entry name="delta"      class="i" val="&#x03b4;"/>
+  <entry name="epsilon"    class="i" val="&#x03f5;"/>
+  <entry name="varepsilon" class="i" val="&#x03b5;"/>
+  <entry name="zeta"       class="i" val="&#x03b6;"/>
+  <entry name="eta"        class="i" val="&#x03b7;"/>
+  <entry name="theta"      class="i" val="&#x03b8;"/>
+  <entry name="vartheta"   class="i" val="&#x03d1;"/>
+  <entry name="iota"       class="i" val="&#x03b9;"/>
+  <entry name="kappa"      class="i" val="&#x03ba;"/>
+  <entry name="lambda"     class="i" val="&#x03bb;"/>
+  <entry name="mu"         class="i" val="&#x03bc;"/>
+  <entry name="nu"         class="i" val="&#x03bd;"/>
+  <entry name="xi"         class="i" val="&#x03be;"/>
+  <entry name="o"          class="i" val="&#x03bf;"/>
+  <entry name="pi"         class="i" val="&#x03c0;"/>
+  <entry name="varpi"      class="i" val="&#x03d6;"/>
+  <entry name="rho"        class="i" val="&#x03c1;"/>
+  <entry name="varrho"     class="i" val="&#x03f1;"/>
+  <entry name="sigma"      class="i" val="&#x03c3;"/>
+  <entry name="varsigma"   class="i" val="&#x03c2;"/>
+  <entry name="tau"        class="i" val="&#x03c4;"/>
+  <entry name="upsilon"    class="i" val="&#x03c5;"/>
+  <entry name="phi"        class="i" val="&#x03d5;"/>
+  <entry name="varphi"     class="i" val="&#x03c6;"/>
+  <entry name="chi"        class="i" val="&#x03c7;"/>
+  <entry name="psi"        class="i" val="&#x03c8;"/>
+  <entry name="omega"      class="i" val="&#x03c9;"/>
+
+  <!-- Greek Letters (upper case) -->
+
+  <entry name="Gamma"   class="i" val="&#x0393;"/>
+  <entry name="Delta"   class="i" val="&#x0394;"/>
+  <entry name="Theta"   class="i" val="&#x0398;"/>
+  <entry name="Lambda"  class="i" val="&#x039b;"/>
+  <entry name="Xi"      class="i" val="&#x039e;"/>
+  <entry name="Pi"      class="i" val="&#x03a0;"/>
+  <entry name="Sigma"   class="i" val="&#x03a3;"/>
+  <entry name="Upsilon" class="i" val="&#x03d2;"/>
+  <entry name="Phi"     class="i" val="&#x03a6;"/>
+  <entry name="Psi"     class="i" val="&#x03a8;"/>
+  <entry name="Omega"   class="i" val="&#x03a9;"/>
+
+  <!-- Symbols of Type Ord -->
+
+  <entry name="aleph"       class="i" val="&#x2135;"/>
+  <entry name="hbar"        class="i" val="&#x210f;&#xfe00;"/>
+  <entry name="imath"       class="i" val="&#x0131;"/>
+  <entry name="jmath"       class="i" val="&#x006a;&#xfe00;"/>
+  <entry name="ell"         class="i" val="&#x2113;"/>
+  <entry name="wp"          class="i" val="&#x2118;"/>
+  <entry name="Re"          class="o" val="&#x211c;"/>
+  <entry name="Im"          class="o" val="&#x2111;"/>
+  <entry name="partial"     class="o" val="&#x2202;"/>
+  <entry name="infty"       class="i" val="&#x221e;"/>
+  <entry name="prime"       class="o" val="&#x2032;"/>
+  <entry name="emptyset"    class="i" val="&#x2205;&#xfe00;"/>
+  <entry name="nabla"       class="o" val="&#x2207;"/>
+  <entry name="surd"        class="o" val="????"/>
+  <entry name="top"         class="i" val="&#x22a4;"/>
+  <entry name="bot"         class="i" val="&#x22a5;"/>
+  <entry name="|"           class="o" val="|" delimiter="1"/>
+  <entry name="angle"       class="o" val="&#x2220;"/>
+  <entry name="triangle"    class="o" val="&#x25b5;"/>
+  <entry name="backslash"   class="o" val="\"/>
+  <entry name="forall"      class="o" val="&#x2200;"/>
+  <entry name="exists"      class="o" val="&#x2203;"/>
+  <entry name="neg"         class="o" val="&#x00ac;"/>
+  <entry name="lnot"        class="o" val="&#x00ac;"/>
+  <entry name="flat"        class="i" val="&#x266d;"/>
+  <entry name="natural"     class="i" val="&#x266e;"/>
+  <entry name="sharp"       class="i" val="&#x266f;"/>
+  <entry name="clubsuit"    class="i" val="&#x2663;"/>
+  <entry name="diamondsuit" class="i" val="&#x2662;"/>
+  <entry name="heartsuit"   class="i" val="&#x2661;"/>
+  <entry name="spadesuit"   class="i" val="&#x2660;"/>
+
+  <!-- Large Operators -->
+
+  <entry name="sum"         class="o" val="&#x2211;" limits="1"/>
+  <entry name="prod"        class="o" val="&#x220f;" limits="1"/>
+  <entry name="coprod"      class="o" val="&#x2210;" limits="1"/>
+  <entry name="int"         class="o" val="&#x222b;" limits="1"/>
+  <entry name="oint"        class="o" val="&#x222e;" limits="1"/>
+  <entry name="bigcap"      class="o" val="&#x22c2;" limits="1"/>
+  <entry name="bigcup"      class="o" val="&#x22c3;" limits="1"/>
+  <entry name="bigsqcup"    class="o" val="&#x2294;" limits="1"/>
+  <entry name="bigvee"      class="o" val="&#x22c1;" limits="1"/>
+  <entry name="bigwedge"    class="o" val="&#x22c0;" limits="1"/>
+  <entry name="bigodot"     class="o" val="&#x2299;" limits="1"/>
+  <entry name="bigotimes"   class="o" val="&#x2297;" limits="1"/>
+  <entry name="bigoplus"    class="o" val="&#x2295;" limits="1"/>
+  <entry name="biguplus"    class="o" val="&#x228e;" limits="1"/>
+
+  <!-- Binary Operations -->
+
+  <entry name="pm"              class="o" val="&#x00b1;"/>
+  <entry name="mp"              class="o" val="&#x2213;"/>
+  <entry name="setminus"        class="o" val="&#x2216;"/>
+  <entry name="cdot"            class="o" val="&#x010b;"/>
+  <entry name="times"           class="o" val="&#x00d7;"/>
+  <entry name="ast"             class="o" val="&#x002a;"/>
+  <entry name="star"            class="o" val="&#x22c6;"/>
+  <entry name="diamond"         class="o" val="&#x22c4;"/>
+  <entry name="circ"            class="o" val="&#x005e;"/>
+  <entry name="bullet"          class="o" val="&#x2022;"/>
+  <entry name="div"             class="o" val="&#x00f7;"/>
+  <entry name="cap"             class="o" val="&#x2229;"/>
+  <entry name="cup"             class="o" val="&#x222a;"/>
+  <entry name="uplus"           class="o" val="&#x228e;"/>
+  <entry name="sqcap"           class="o" val="&#x2293;"/>
+  <entry name="sqcup"           class="o" val="&#x2294;"/>
+  <entry name="triangleleft"    class="o" val="&#x25c3;"/>
+  <entry name="triangleright"   class="o" val="&#x25b9;"/>
+  <entry name="wr"              class="o" val="&#x2240;"/>
+  <entry name="bigcirc"         class="o" val="&#x25ef;"/>
+  <entry name="bigtriangleup"   class="o" val="&#x25b3;"/>
+  <entry name="bigtriangledown" class="o" val="&#x25bd;"/>
+  <entry name="vee"             class="o" val="&#x2228;"/>
+  <entry name="lor"             class="o" val="&#x2228;"/>
+  <entry name="wedge"           class="o" val="&#x2227;"/>
+  <entry name="land"            class="o" val="&#x2227;"/>
+  <entry name="oplus"           class="o" val="&#x2295;"/>
+  <entry name="ominus"          class="o" val="&#x2296;"/>
+  <entry name="otimes"          class="o" val="&#x2297;"/>
+  <entry name="oslash"          class="o" val="&#x00f8;"/>
+  <entry name="odot"            class="o" val="&#x2299;"/>
+  <entry name="dagger"          class="o" val="&#x2020;"/>
+  <entry name="ddagger"         class="o" val="&#x2021;"/>
+  <entry name="amalg"           class="o" val="&#x2a3f;"/>
+
+  <!-- Relations -->
+
+  <entry name="leq"            class="o" val="&#x2264;"/>
+  <entry name="le"             class="o" val="&#x2264;"/>
+  <entry name="prec"           class="o" val="&#x227a;"/>
+  <entry name="preceq"         class="o" val="&#x2aaf;"/>
+  <entry name="ll"             class="o" val="&#x226a;"/>
+  <entry name="subset"         class="o" val="&#x2282;"/>
+  <entry name="subseteq"       class="o" val="&#x2286;"/>
+  <entry name="in"             class="o" val="&#x2208;"/>
+  <entry name="vdash"          class="o" val="&#x22a2;"/>
+  <entry name="smile"          class="o" val="&#x2323;"/>
+  <entry name="frown"          class="o" val="&#x2322;"/>
+  <entry name="propto"         class="o" val="&#x221d;"/>
+  <entry name="geq"            class="o" val="&#x2265;"/>
+  <entry name="ge"             class="o" val="&#x2265;"/>
+  <entry name="succ"           class="o" val="&#x227b;"/>
+  <entry name="succeq"         class="o" val="&#x227d;"/>
+  <entry name="gg"             class="o" val="&#x226b;"/>
+  <entry name="supset"         class="o" val="&#x2283;"/>
+  <entry name="supseteq"       class="o" val="&#x2287;"/>
+  <entry name="sqsupseteq"     class="o" val="&#x2292;"/>
+  <entry name="notin"          class="o" val="&#x2209;"/>
+  <entry name="dashv"          class="o" val="&#x22a3;"/>
+  <entry name="mid"            class="o" val="&#x2223;"/>
+  <entry name="parallet"       class="o" val="????"/>
+  <entry name="equiv"          class="o" val="&#x2261;"/>
+  <entry name="sim"            class="o" val="&#x223c;"/>
+  <entry name="simeq"          class="o" val="&#x2243;"/>
+  <entry name="asymp"          class="o" val="&#x224d;"/>
+  <entry name="approx"         class="o" val="&#x2248;"/>
+  <entry name="cong"           class="o" val="&#x2245;"/>
+  <entry name="bowtie"         class="o" val="&#x22c8;"/>
+  <entry name="ni"             class="o" val="&#x220b;"/>
+  <entry name="owns"           class="o" val="&#x220b;"/>
+  <entry name="models"         class="o" val="&#x22a7;"/>
+  <entry name="doteq"          class="o" val="&#x2250;"/>
+  <entry name="perp"           class="o" val="&#x22a5;"/>
+
+  <entry name="not"            pattern="#1" embellishment="1"/>
+  <entry name="ne"             class="o" val="&#x2260;"/>
+
+  <!-- Arrows -->
+
+  <entry name="leftarrow"                 class="o" val="&#x2190;"/>
+  <entry name="gets"                      class="o" val="&#x2190;"/>
+  <entry name="Leftarrow"                 class="o" val="&#x21d0;"/>
+  <entry name="rightarrow"                class="o" val="&#x2192;"/>
+  <entry name="to"                        class="o" val="&#x2192;"/>
+  <entry name="Rightarrow"                class="o" val="&#x21d2;"/>
+  <entry name="leftrightarrow"            class="o" val="&#x2194;"/>
+  <entry name="Leftrightarrow"            class="o" val="&#x21d4;"/>
+  <entry name="mapsto"                    class="o" val="&#x21a6;"/>
+  <entry name="hookleftarrow"             class="o" val="&#x21a9;"/>
+  <entry name="uparrow"                   class="o" val="&#x2191;"/>
+  <entry name="downarrow"                 class="o" val="&#x2193;"/>
+  <entry name="updownarrow"               class="o" val="&#x2195;"/>
+  <entry name="nearrow"                   class="o" val="&#x2197;"/>
+  <entry name="nwarrow"                   class="o" val="&#x2196;"/>
+  <entry name="longleftarrow"             class="o" val="????;"/>
+  <entry name="Longleftarrow"             class="o" val="????"/>
+  <entry name="longrightarrow"            class="o" val="????"/>
+  <entry name="Longrightarrow"            class="o" val="&#x21d2;"/>
+  <entry name="longleftrightarrow" class="o" val="????"/>
+  <entry name="Longleftrightarrow" class="o" val="????"/>
+  <entry name="longmapsto"                class="o" val="????"/>
+  <entry name="hookrightarrow"            class="o" val="&#x21aa;"/>
+  <entry name="Uparrow"                   class="o" val="&#x21d1;"/>
+  <entry name="Downarrow"                 class="o" val="&#x21d3;"/>
+  <entry name="searrow"                   class="o" val="&#x2198;"/>
+  <entry name="swarrow"                   class="o" val="&#x2199;"/>
+
+  <entry name="buildrel" pattern="#1\over#2" embellishment="1"/>
+
+  <!-- Delimiters -->
+
+  <entry name="lbrack"         class="o" val="[" delimiter="1"/>
+  <entry name="rbrack"         class="o" val="]" delimiter="1"/>
+  <entry name="vert"           class="o" val="|" delimiter="1"/>
+  <entry name="Vert"           class="o" val="&#x2016;" delimiter="1"/>
+  <entry name="lbrace"         class="o" val="{" delimiter="1"/>
+  <entry name="{"              class="o" val="{" delimiter="1"/>
+  <entry name="rbrace"         class="o" val="}" delimiter="1"/>
+  <entry name="}"              class="o" val="}" delimiter="1"/>
+  <entry name="lfloor"         class="o" val="&#x230a;" delimiter="1"/>
+  <entry name="rfloor"         class="o" val="&#x230b;" delimiter="1"/>
+  <entry name="langle"         class="o" val="&#x2329;" delimiter="1"/>
+  <entry name="rangle"         class="o" val="&#x232a;" delimiter="1"/>
+  <entry name="lceil"          class="o" val="&#x2308;" delimiter="1"/>
+  <entry name="rceil"          class="o" val="&#x2309;" delimiter="1"/>
+
+  <entry name="left"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="right"          pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="bigl"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="bigr"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="bigm"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="big"            pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="Bigl"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="Bigr"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="Bigm"           pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="biggl"          pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="biggr"          pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="biggm"          pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="Biggl"          pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="Biggr"          pattern="#1" embellishment="1" delimiter="1"/>
+  <entry name="Biggm"          pattern="#1" embellishment="1" delimiter="1"/>
+
+  <!-- Accents -->
+
+  <entry name="hat"       pattern="#1" embellishment="1"/>
+  <entry name="widehat"   pattern="#1" embellishment="1"/>
+  <entry name="check"     pattern="#1" embellishment="1"/>
+  <entry name="tilde"     pattern="#1" embellishment="1"/>
+  <entry name="widetilde" pattern="#1" embellishment="1"/>
+  <entry name="acute"     pattern="#1" embellishment="1"/>
+  <entry name="grave"     pattern="#1" embellishment="1"/>
+  <entry name="dot"       pattern="#1" embellishment="1"/>
+  <entry name="ddot"      pattern="#1" embellishment="1"/>
+  <entry name="breve"     pattern="#1" embellishment="1"/>
+  <entry name="bar"       pattern="#1" embellishment="1"/>
+  <entry name="vec"       pattern="#1" embellishment="1"/>
+
+  <!-- Elementary Math Control Sequences -->
+
+  <entry name="overline"  pattern="#1"/>
+  <entry name="underline" pattern="#1"/>
+  <entry name="sqrt"      pattern="#1"/>
+  <entry name="root"      pattern="#1\of#2"/>
+  <entry name="over"      pattern="{}"/>
+  <entry name="atop"      pattern="{}"/>
+  <entry name="choose"    pattern="{}"/>
+  <entry name="brace"     pattern="{}"/>
+  <entry name="brack"     pattern="{}"/>
+
+  <!-- Style -->
+
+  <entry name="displaystyle"      pattern="}"/>
+  <entry name="textstyle"         pattern="}"/>
+  <entry name="scriptstyle"       pattern="}"/>
+  <entry name="scriptscriptstyle" pattern="}"/>
+
+  <!-- Non-Italic Function Names -->
+
+  <entry name="arccos" class="i" val="arccos"/>
+  <entry name="arcsin" class="i" val="arcsin"/>
+  <entry name="arctan" class="i" val="arctan"/>
+  <entry name="arg"    class="i" val="arg"/>
+  <entry name="cos"    class="i" val="cos"/>
+  <entry name="cosh"   class="i" val="cosh"/>
+  <entry name="cot"    class="i" val="cot"/>
+  <entry name="coth"   class="i" val="coth"/>
+  <entry name="csc"    class="i" val="csc"/>
+  <entry name="exp"    class="i" val="exp"/>
+  <entry name="deg"    class="i" val="deg"/>
+  <entry name="det"    class="o" val="det" limits="1"/>
+  <entry name="dim"    class="i" val="dim"/>
+  <entry name="gcd"    class="o" val="gcd" limits="1"/>
+  <entry name="hom"    class="i" val="hom"/>
+  <entry name="inf"    class="o" val="inf" limits="1"/>
+  <entry name="ker"    class="i" val="ker"/>
+  <entry name="lg"     class="i" val="lg"/>
+  <entry name="lim"    class="o" val="lim" limits="1"/>
+  <entry name="liminf" class="o" val="liminf" limits="1"/>
+  <entry name="limsup" class="o" val="limsup" limits="1"/>
+  <entry name="ln"     class="i" val="ln"/>
+  <entry name="log"    class="i" val="log"/>
+  <entry name="max"    class="o" val="max" limits="1"/>
+  <entry name="min"    class="o" val="max" limits="1"/>
+  <entry name="Pr"     class="o" val="Pr" limits="1"/>
+  <entry name="sec"    class="i" val="sec"/>
+  <entry name="sin"    class="i" val="sin"/>
+  <entry name="sinh"   class="i" val="sinh"/>
+  <entry name="sup"    class="o" limits="1"/>
+  <entry name="tan"    class="i" val="tan"/>
+  <entry name="tanh"   class="i" val="tanh"/>
+  <entry name="pmod"   pattern="#1"/>
+  <entry name="bmod"   class="o" val="mod"/>
+
+  <!-- Ellipses -->
+
+  <entry name="dots"          class="i" val="&#x2026;"/>
+  <entry name="ldots"         class="i" val="&#x2026;"/>
+  <entry name="cdots"         class="i" val="&#x22ef;"/>
+  <entry name="vdots"         class="i" val="&#x22ee;"/>
+  <entry name="ddots"         class="i" val="&#x22f1;"/>
+
+  <!-- Fonts -->
+
+  <entry name="rm" pattern="}"/>
+  <entry name="bf" pattern="}"/>
+  <entry name="tt" pattern="}"/>
+  <entry name="sl" pattern="}"/>
+  <entry name="it" pattern="}"/>
+
+  <!-- Horizontal Spacing -->
+
+  <entry name=","/>
+  <entry name="&gt;"/>
+  <entry name=";"/>
+  <entry name="!"/>
+
+  <!-- Braces and Matrices -->
+
+  <entry name="matrix"       pattern="#1" table="1"/>
+  <entry name="pmatrix"      pattern="#1" table="1"/>
+  <entry name="bordermatrix" pattern="#1" table="1"/>
+  <entry name="overbrace"    pattern="#1" limits="1"/>
+  <entry name="underbrace"   pattern="#1" limits="1"/>
+  <entry name="cases"        pattern="#1" table="1"/>
+
+</dictionary>

diff --git a/helm/ocaml/utf8_macros/data/entities-table.xml b/helm/ocaml/utf8_macros/data/entities-table.xml
new file mode 100644 (file)
index 0000000..c283631
--- /dev/null
+++ b/helm/ocaml/utf8_macros/data/entities-table.xml
@@ -0,0 +1,2079 @@
+<?xml version="1.0"?>
+
+<entities-table>
+  <entity name="aacute" value="&#x000E1;"/>
+  <entity name="Aacute" value="&#x000C1;"/>
+  <entity name="abreve" value="&#x00103;"/>
+  <entity name="Abreve" value="&#x00102;"/>
+  <entity name="ac" value="&#x0290F;"/>
+  <entity name="acd" value="&#x0223F;"/>
+  <entity name="acE" value="&#x029DB;"/>
+  <entity name="acirc" value="&#x000E2;"/>
+  <entity name="Acirc" value="&#x000C2;"/>
+  <entity name="acute" value="&#x000B4;"/>
+  <entity name="acy" value="&#x00430;"/>
+  <entity name="Acy" value="&#x00410;"/>
+  <entity name="aelig" value="&#x000E6;"/>
+  <entity name="AElig" value="&#x000C6;"/>
+  <entity name="af" value="&#x02061;"/>
+  <entity name="afr" value="&#x1D51E;"/>
+  <entity name="Afr" value="&#x1D504;"/>
+  <entity name="agrave" value="&#x000E0;"/>
+  <entity name="Agrave" value="&#x000C0;"/>
+  <entity name="aleph" value="&#x02135;"/>
+  <entity name="alpha" value="&#x003B1;"/>
+  <entity name="amacr" value="&#x00101;"/>
+  <entity name="Amacr" value="&#x00100;"/>
+  <entity name="amalg" value="&#x02A3F;"/>
+  <entity name="amp" value="&#x00026;"/>
+  <entity name="and" value="&#x02227;"/>
+  <entity name="And" value="&#x02A53;"/>
+  <entity name="andand" value="&#x02A55;"/>
+  <entity name="andd" value="&#x02A5C;"/>
+  <entity name="andslope" value="&#x02A58;"/>
+  <entity name="andv" value="&#x02A5A;"/>
+  <entity name="ang" value="&#x02220;"/>
+  <entity name="ange" value="&#x029A4;"/>
+  <entity name="angle" value="&#x02220;"/>
+  <entity name="angmsd" value="&#x02221;"/>
+  <entity name="angmsdaa" value="&#x029A8;"/>
+  <entity name="angmsdab" value="&#x029A9;"/>
+  <entity name="angmsdac" value="&#x029AA;"/>
+  <entity name="angmsdad" value="&#x029AB;"/>
+  <entity name="angmsdae" value="&#x029AC;"/>
+  <entity name="angmsdaf" value="&#x029AD;"/>
+  <entity name="angmsdag" value="&#x029AE;"/>
+  <entity name="angmsdah" value="&#x029AF;"/>
+  <entity name="angrt" value="&#x0221F;"/>
+  <entity name="angrtvb" value="&#x0299D;&#x0FE00;"/>
+  <entity name="angrtvbd" value="&#x0299D;"/>
+  <entity name="angsph" value="&#x02222;"/>
+  <entity name="angst" value="&#x0212B;"/>
+  <entity name="angzarr" value="&#x0237C;"/>
+  <entity name="aogon" value="&#x00105;"/>
+  <entity name="Aogon" value="&#x00104;"/>
+  <entity name="aopf" value="&#x1D552;"/>
+  <entity name="Aopf" value="&#x1D538;"/>
+  <entity name="ap" value="&#x02248;"/>
+  <entity name="apacir" value="&#x02A6F;"/>
+  <entity name="ape" value="&#x0224A;"/>
+  <entity name="apE" value="&#x0224A;"/>
+  <entity name="apid" value="&#x0224B;"/>
+  <entity name="apos" value="&#x00027;"/>
+  <entity name="ApplyFunction" value="&#x02061;"/>
+  <entity name="approx" value="&#x02248;"/>
+  <entity name="approxeq" value="&#x0224A;"/>
+  <entity name="aring" value="&#x000E5;"/>
+  <entity name="Aring" value="&#x000C5;"/>
+  <entity name="ascr" value="&#x1D4B6;"/>
+  <entity name="Ascr" value="&#x1D49C;"/>
+  <entity name="Assign" value="&#x02254;"/>
+  <entity name="ast" value="&#x0002A;"/>
+  <entity name="asymp" value="&#x0224D;"/>
+  <entity name="atilde" value="&#x000E3;"/>
+  <entity name="Atilde" value="&#x000C3;"/>
+  <entity name="auml" value="&#x000E4;"/>
+  <entity name="Auml" value="&#x000C4;"/>
+  <entity name="awconint" value="&#x02233;"/>
+  <entity name="awint" value="&#x02A11;"/>
+  <entity name="backcong" value="&#x0224C;"/>
+  <entity name="backepsilon" value="&#x003F6;"/>
+  <entity name="backprime" value="&#x02035;"/>
+  <entity name="backsim" value="&#x0223D;"/>
+  <entity name="backsimeq" value="&#x022CD;"/>
+  <entity name="Backslash" value="&#x02216;"/>
+  <entity name="Barv" value="&#x02AE7;"/>
+  <entity name="barvee" value="&#x022BD;"/>
+  <entity name="barwed" value="&#x022BC;"/>
+  <entity name="Barwed" value="&#x02306;"/>
+  <entity name="barwedge" value="&#x022BC;"/>
+  <entity name="bbrk" value="&#x023B5;"/>
+  <entity name="bcong" value="&#x0224C;"/>
+  <entity name="bcy" value="&#x00431;"/>
+  <entity name="Bcy" value="&#x00411;"/>
+  <entity name="becaus" value="&#x02235;"/>
+  <entity name="because" value="&#x02235;"/>
+  <entity name="Because" value="&#x02235;"/>
+  <entity name="bemptyv" value="&#x029B0;"/>
+  <entity name="bepsi" value="&#x003F6;"/>
+  <entity name="bernou" value="&#x0212C;"/>
+  <entity name="Bernoullis" value="&#x0212C;"/>
+  <entity name="beta" value="&#x003B2;"/>
+  <entity name="beth" value="&#x02136;"/>
+  <entity name="between" value="&#x0226C;"/>
+  <entity name="bfr" value="&#x1D51F;"/>
+  <entity name="Bfr" value="&#x1D505;"/>
+  <entity name="bigcap" value="&#x022C2;"/>
+  <entity name="bigcirc" value="&#x025EF;"/>
+  <entity name="bigcup" value="&#x022C3;"/>
+  <entity name="bigodot" value="&#x02299;"/>
+  <entity name="bigoplus" value="&#x02295;"/>
+  <entity name="bigotimes" value="&#x02297;"/>
+  <entity name="bigsqcup" value="&#x02294;"/>
+  <entity name="bigstar" value="&#x02605;"/>
+  <entity name="bigtriangledown" value="&#x025BD;"/>
+  <entity name="bigtriangleup" value="&#x025B3;"/>
+  <entity name="biguplus" value="&#x0228E;"/>
+  <entity name="bigvee" value="&#x022C1;"/>
+  <entity name="bigwedge" value="&#x022C0;"/>
+  <entity name="bkarow" value="&#x0290D;"/>
+  <entity name="blacklozenge" value="&#x029EB;"/>
+  <entity name="blacksquare" value="&#x025AA;"/>
+  <entity name="blacktriangle" value="&#x025B4;"/>
+  <entity name="blacktriangledown" value="&#x025BE;"/>
+  <entity name="blacktriangleleft" value="&#x025C2;"/>
+  <entity name="blacktriangleright" value="&#x025B8;"/>
+  <entity name="blank" value="&#x02423;"/>
+  <entity name="blk12" value="&#x02592;"/>
+  <entity name="blk14" value="&#x02591;"/>
+  <entity name="blk34" value="&#x02593;"/>
+  <entity name="block" value="&#x02588;"/>
+  <entity name="bne" value="&#x0003D;&#x020E5;"/>
+  <entity name="bnequiv" value="&#x02261;&#x020E5;"/>
+  <entity name="bnot" value="&#x02310;"/>
+  <entity name="bNot" value="&#x02AED;"/>
+  <entity name="bopf" value="&#x1D553;"/>
+  <entity name="Bopf" value="&#x1D539;"/>
+  <entity name="bot" value="&#x022A5;"/>
+  <entity name="bottom" value="&#x022A5;"/>
+  <entity name="bowtie" value="&#x022C8;"/>
+  <entity name="boxbox" value="&#x029C9;"/>
+  <entity name="boxdl" value="&#x02510;"/>
+  <entity name="boxdL" value="&#x02555;"/>
+  <entity name="boxDl" value="&#x02556;"/>
+  <entity name="boxDL" value="&#x02557;"/>
+  <entity name="boxdr" value="&#x0250C;"/>
+  <entity name="boxdR" value="&#x02552;"/>
+  <entity name="boxDr" value="&#x02553;"/>
+  <entity name="boxDR" value="&#x02554;"/>
+  <entity name="boxh" value="&#x02500;"/>
+  <entity name="boxH" value="&#x02550;"/>
+  <entity name="boxhd" value="&#x0252C;"/>
+  <entity name="boxhD" value="&#x02565;"/>
+  <entity name="boxHd" value="&#x02564;"/>
+  <entity name="boxHD" value="&#x02566;"/>
+  <entity name="boxhu" value="&#x02534;"/>
+  <entity name="boxhU" value="&#x02568;"/>
+  <entity name="boxHu" value="&#x02567;"/>
+  <entity name="boxHU" value="&#x02569;"/>
+  <entity name="boxminus" value="&#x0229F;"/>
+  <entity name="boxplus" value="&#x0229E;"/>
+  <entity name="boxtimes" value="&#x022A0;"/>
+  <entity name="boxul" value="&#x02518;"/>
+  <entity name="boxuL" value="&#x0255B;"/>
+  <entity name="boxUl" value="&#x0255C;"/>
+  <entity name="boxUL" value="&#x0255D;"/>
+  <entity name="boxur" value="&#x02514;"/>
+  <entity name="boxuR" value="&#x02558;"/>
+  <entity name="boxUr" value="&#x02559;"/>
+  <entity name="boxUR" value="&#x0255A;"/>
+  <entity name="boxv" value="&#x02502;"/>
+  <entity name="boxV" value="&#x02551;"/>
+  <entity name="boxvh" value="&#x0253C;"/>
+  <entity name="boxvH" value="&#x0256A;"/>
+  <entity name="boxVh" value="&#x0256B;"/>
+  <entity name="boxVH" value="&#x0256C;"/>
+  <entity name="boxvl" value="&#x02524;"/>
+  <entity name="boxvL" value="&#x02561;"/>
+  <entity name="boxVl" value="&#x02562;"/>
+  <entity name="boxVL" value="&#x02563;"/>
+  <entity name="boxvr" value="&#x0251C;"/>
+  <entity name="boxvR" value="&#x0255E;"/>
+  <entity name="boxVr" value="&#x0255F;"/>
+  <entity name="boxVR" value="&#x02560;"/>
+  <entity name="bprime" value="&#x02035;"/>
+  <entity name="breve" value="&#x002D8;"/>
+  <entity name="Breve" value="&#x002D8;"/>
+  <entity name="brvbar" value="&#x000A6;"/>
+  <entity name="bscr" value="&#x1D4B7;"/>
+  <entity name="Bscr" value="&#x0212C;"/>
+  <entity name="bsemi" value="&#x0204F;"/>
+  <entity name="bsim" value="&#x0223D;"/>
+  <entity name="bsime" value="&#x022CD;"/>
+  <entity name="bsol" value="&#x0005C;"/>
+  <entity name="bsolb" value="&#x029C5;"/>
+  <entity name="bsolhsub" value="&#x0005C;&#x02282;"/>
+  <entity name="bull" value="&#x02022;"/>
+  <entity name="bullet" value="&#x02022;"/>
+  <entity name="bump" value="&#x0224E;"/>
+  <entity name="bumpe" value="&#x0224F;"/>
+  <entity name="bumpE" value="&#x02AAE;"/>
+  <entity name="bumpeq" value="&#x0224F;"/>
+  <entity name="Bumpeq" value="&#x0224E;"/>
+  <entity name="cacute" value="&#x00107;"/>
+  <entity name="Cacute" value="&#x00106;"/>
+  <entity name="cap" value="&#x02229;"/>
+  <entity name="Cap" value="&#x022D2;"/>
+  <entity name="capand" value="&#x02A44;"/>
+  <entity name="capbrcup" value="&#x02A49;"/>
+  <entity name="capcap" value="&#x02A4B;"/>
+  <entity name="capcup" value="&#x02A47;"/>
+  <entity name="capdot" value="&#x02A40;"/>
+  <entity name="CapitalDifferentialD" value="&#x02145;"/>
+  <entity name="caps" value="&#x02229;&#x0FE00;"/>
+  <entity name="caret" value="&#x02041;"/>
+  <entity name="caron" value="&#x002C7;"/>
+  <entity name="Cayleys" value="&#x0212D;"/>
+  <entity name="ccaps" value="&#x02A4D;"/>
+  <entity name="ccaron" value="&#x0010D;"/>
+  <entity name="Ccaron" value="&#x0010C;"/>
+  <entity name="ccedil" value="&#x000E7;"/>
+  <entity name="Ccedil" value="&#x000C7;"/>
+  <entity name="ccirc" value="&#x00109;"/>
+  <entity name="Ccirc" value="&#x00108;"/>
+  <entity name="Cconint" value="&#x02230;"/>
+  <entity name="ccups" value="&#x02A4C;"/>
+  <entity name="ccupssm" value="&#x02A50;"/>
+  <entity name="cdot" value="&#x0010B;"/>
+  <entity name="Cdot" value="&#x0010A;"/>
+  <entity name="cedil" value="&#x000B8;"/>
+  <entity name="Cedilla" value="&#x000B8;"/>
+  <entity name="cemptyv" value="&#x029B2;"/>
+  <entity name="cent" value="&#x000A2;"/>
+  <entity name="centerdot" value="&#x000B7;"/>
+  <entity name="CenterDot" value="&#x000B7;"/>
+  <entity name="cfr" value="&#x1D520;"/>
+  <entity name="Cfr" value="&#x0212D;"/>
+  <entity name="chcy" value="&#x00447;"/>
+  <entity name="CHcy" value="&#x00427;"/>
+  <entity name="check" value="&#x02713;"/>
+  <entity name="checkmark" value="&#x02713;"/>
+  <entity name="chi" value="&#x003C7;"/>
+  <entity name="cir" value="&#x025CB;"/>
+  <entity name="circ" value="&#x0005E;"/>
+  <entity name="circeq" value="&#x02257;"/>
+  <entity name="circlearrowleft" value="&#x021BA;"/>
+  <entity name="circlearrowright" value="&#x021BB;"/>
+  <entity name="circledast" value="&#x0229B;"/>
+  <entity name="circledcirc" value="&#x0229A;"/>
+  <entity name="circleddash" value="&#x0229D;"/>
+  <entity name="CircleDot" value="&#x02299;"/>
+  <entity name="circledR" value="&#x000AE;"/>
+  <entity name="circledS" value="&#x024C8;"/>
+  <entity name="CircleMinus" value="&#x02296;"/>
+  <entity name="CirclePlus" value="&#x02295;"/>
+  <entity name="CircleTimes" value="&#x02297;"/>
+  <entity name="cire" value="&#x02257;"/>
+  <entity name="cirE" value="&#x029C3;"/>
+  <entity name="cirfnint" value="&#x02A10;"/>
+  <entity name="cirmid" value="&#x02AEF;"/>
+  <entity name="cirscir" value="&#x029C2;"/>
+  <entity name="ClockwiseContourIntegral" value="&#x02232;"/>
+  <entity name="CloseCurlyDoubleQuote" value="&#x0201D;"/>
+  <entity name="CloseCurlyQuote" value="&#x02019;"/>
+  <entity name="clubs" value="&#x02663;"/>
+  <entity name="clubsuit" value="&#x02663;"/>
+  <entity name="colon" value="&#x0003A;"/>
+  <entity name="Colon" value="&#x02237;"/>
+  <entity name="colone" value="&#x02254;"/>
+  <entity name="Colone" value="&#x02A74;"/>
+  <entity name="coloneq" value="&#x02254;"/>
+  <entity name="comma" value="&#x0002C;"/>
+  <entity name="commat" value="&#x00040;"/>
+  <entity name="comp" value="&#x02201;"/>
+  <entity name="compfn" value="&#x02218;"/>
+  <entity name="complement" value="&#x02201;"/>
+  <entity name="complexes" value="&#x02102;"/>
+  <entity name="cong" value="&#x02245;"/>
+  <entity name="congdot" value="&#x02A6D;"/>
+  <entity name="Congruent" value="&#x02261;"/>
+  <entity name="conint" value="&#x0222E;"/>
+  <entity name="Conint" value="&#x0222F;"/>
+  <entity name="ContourIntegral" value="&#x0222E;"/>
+  <entity name="copf" value="&#x1D554;"/>
+  <entity name="Copf" value="&#x02102;"/>
+  <entity name="coprod" value="&#x02210;"/>
+  <entity name="Coproduct" value="&#x02210;"/>
+  <entity name="copy" value="&#x000A9;"/>
+  <entity name="copysr" value="&#x02117;"/>
+  <entity name="CounterClockwiseContourIntegral" value="&#x02233;"/>
+  <entity name="cross" value="&#x02717;"/>
+  <entity name="Cross" value="&#x02A2F;"/>
+  <entity name="cscr" value="&#x1D4B8;"/>
+  <entity name="Cscr" value="&#x1D49E;"/>
+  <entity name="csub" value="&#x02ACF;"/>
+  <entity name="csube" value="&#x02AD1;"/>
+  <entity name="csup" value="&#x02AD0;"/>
+  <entity name="csupe" value="&#x02AD2;"/>
+  <entity name="ctdot" value="&#x022EF;"/>
+  <entity name="cudarrl" value="&#x02938;"/>
+  <entity name="cudarrr" value="&#x02935;"/>
+  <entity name="cuepr" value="&#x022DE;"/>
+  <entity name="cuesc" value="&#x022DF;"/>
+  <entity name="cularr" value="&#x021B6;"/>
+  <entity name="cularrp" value="&#x0293D;"/>
+  <entity name="cup" value="&#x0222A;"/>
+  <entity name="Cup" value="&#x022D3;"/>
+  <entity name="cupbrcap" value="&#x02A48;"/>
+  <entity name="cupcap" value="&#x02A46;"/>
+  <entity name="CupCap" value="&#x0224D;"/>
+  <entity name="cupcup" value="&#x02A4A;"/>
+  <entity name="cupdot" value="&#x0228D;"/>
+  <entity name="cupor" value="&#x02A45;"/>
+  <entity name="cups" value="&#x0222A;&#x0FE00;"/>
+  <entity name="curarr" value="&#x021B7;"/>
+  <entity name="curarrm" value="&#x0293C;"/>
+  <entity name="curlyeqprec" value="&#x022DE;"/>
+  <entity name="curlyeqsucc" value="&#x022DF;"/>
+  <entity name="curlyvee" value="&#x022CE;"/>
+  <entity name="curlywedge" value="&#x022CF;"/>
+  <entity name="curren" value="&#x000A4;"/>
+  <entity name="curvearrowleft" value="&#x021B6;"/>
+  <entity name="curvearrowright" value="&#x021B7;"/>
+  <entity name="cuvee" value="&#x022CE;"/>
+  <entity name="cuwed" value="&#x022CF;"/>
+  <entity name="cwconint" value="&#x02232;"/>
+  <entity name="cwint" value="&#x02231;"/>
+  <entity name="cylcty" value="&#x0232D;"/>
+  <entity name="dagger" value="&#x02020;"/>
+  <entity name="dagger" value="&#x02020;"/>
+  <entity name="Dagger" value="&#x02021;"/>
+  <entity name="Dagger" value="&#x02021;"/>
+  <entity name="daleth" value="&#x02138;"/>
+  <entity name="darr" value="&#x02193;"/>
+  <entity name="dArr" value="&#x021D3;"/>
+  <entity name="Darr" value="&#x021A1;"/>
+  <entity name="dash" value="&#x02010;"/>
+  <entity name="dashv" value="&#x022A3;"/>
+  <entity name="Dashv" value="&#x02AE4;"/>
+  <entity name="dbkarow" value="&#x0290F;"/>
+  <entity name="dblac" value="&#x002DD;"/>
+  <entity name="dcaron" value="&#x0010F;"/>
+  <entity name="Dcaron" value="&#x0010E;"/>
+  <entity name="dcy" value="&#x00434;"/>
+  <entity name="Dcy" value="&#x00414;"/>
+  <entity name="dd" value="&#x02146;"/>
+  <entity name="DD" value="&#x02145;"/>
+  <entity name="ddagger" value="&#x02021;"/>
+  <entity name="ddarr" value="&#x021CA;"/>
+  <entity name="DDotrahd" value="&#x02911;"/>
+  <entity name="ddotseq" value="&#x02A77;"/>
+  <entity name="deg" value="&#x000B0;"/>
+  <entity name="Del" value="&#x02207;"/>
+  <entity name="delta" value="&#x003B4;"/>
+  <entity name="Delta" value="&#x00394;"/>
+  <entity name="demptyv" value="&#x029B1;"/>
+  <entity name="dfisht" value="&#x0297F;"/>
+  <entity name="dfr" value="&#x1D521;"/>
+  <entity name="Dfr" value="&#x1D507;"/>
+  <entity name="dHar" value="&#x02965;"/>
+  <entity name="dharl" value="&#x021C3;"/>
+  <entity name="dharr" value="&#x021C2;"/>
+  <entity name="DiacriticalAcute" value="&#x000B4;"/>
+  <entity name="DiacriticalDot" value="&#x002D9;"/>
+  <entity name="DiacriticalDoubleAcute" value="&#x002DD;"/>
+  <entity name="DiacriticalGrave" value="&#x00060;"/>
+  <entity name="DiacriticalTilde" value="&#x002DC;"/>
+  <entity name="diam" value="&#x022C4;"/>
+  <entity name="diamond" value="&#x022C4;"/>
+  <entity name="Diamond" value="&#x022C4;"/>
+  <entity name="diamondsuit" value="&#x02666;"/>
+  <entity name="diams" value="&#x02666;"/>
+  <entity name="die" value="&#x000A8;"/>
+  <entity name="DifferentialD" value="&#x02146;"/>
+  <entity name="digamma" value="&#x003DC;"/>
+  <entity name="disin" value="&#x022F2;"/>
+  <entity name="div" value="&#x000F7;"/>
+  <entity name="divide" value="&#x000F7;"/>
+  <entity name="divideontimes" value="&#x022C7;"/>
+  <entity name="divonx" value="&#x022C7;"/>
+  <entity name="djcy" value="&#x00452;"/>
+  <entity name="DJcy" value="&#x00402;"/>
+  <entity name="dlcorn" value="&#x0231E;"/>
+  <entity name="dlcrop" value="&#x0230D;"/>
+  <entity name="dollar" value="&#x00024;"/>
+  <entity name="dopf" value="&#x1D555;"/>
+  <entity name="Dopf" value="&#x1D53B;"/>
+  <entity name="dot" value="&#x002D9;"/>
+  <entity name="Dot" value="&#x000A8;"/>
+  <entity name="DotDot" value="&#x020DC;"/>
+  <entity name="doteq" value="&#x02250;"/>
+  <entity name="doteqdot" value="&#x02251;"/>
+  <entity name="DotEqual" value="&#x02250;"/>
+  <entity name="dotminus" value="&#x02238;"/>
+  <entity name="dotplus" value="&#x02214;"/>
+  <entity name="dotsquare" value="&#x022A1;"/>
+  <entity name="doublebarwedge" value="&#x02306;"/>
+  <entity name="DoubleContourIntegral" value="&#x0222F;"/>
+  <entity name="DoubleDot" value="&#x000A8;"/>
+  <entity name="DoubleDownArrow" value="&#x021D3;"/>
+  <entity name="DoubleLeftArrow" value="&#x021D0;"/>
+  <entity name="DoubleLeftRightArrow" value="&#x021D4;"/>
+  <entity name="DoubleLeftTee" value="&#x02AE4;"/>
+  <entity name="DoubleLongLeftArrow" value="&#x0F579;"/>
+  <entity name="DoubleLongLeftRightArrow" value="&#x0F57B;"/>
+  <entity name="DoubleLongRightArrow" value="&#x0F57A;"/>
+  <entity name="DoubleRightArrow" value="&#x021D2;"/>
+  <entity name="DoubleRightTee" value="&#x022A8;"/>
+  <entity name="DoubleUpArrow" value="&#x021D1;"/>
+  <entity name="DoubleUpDownArrow" value="&#x021D5;"/>
+  <entity name="DoubleVerticalBar" value="&#x02225;"/>
+  <entity name="downarrow" value="&#x02193;"/>
+  <entity name="Downarrow" value="&#x021D3;"/>
+  <entity name="DownArrow" value="&#x02193;"/>
+  <entity name="DownArrowBar" value="&#x02913;"/>
+  <entity name="DownArrowUpArrow" value="&#x021F5;"/>
+  <entity name="DownBreve" value="&#x00311;"/>
+  <entity name="downdownarrows" value="&#x021CA;"/>
+  <entity name="downharpoonleft" value="&#x021C3;"/>
+  <entity name="downharpoonright" value="&#x021C2;"/>
+  <entity name="DownLeftRightVector" value="&#x02950;"/>
+  <entity name="DownLeftTeeVector" value="&#x0295E;"/>
+  <entity name="DownLeftVector" value="&#x021BD;"/>
+  <entity name="DownLeftVectorBar" value="&#x02956;"/>
+  <entity name="DownRightTeeVector" value="&#x0295F;"/>
+  <entity name="DownRightVector" value="&#x021C1;"/>
+  <entity name="DownRightVectorBar" value="&#x02957;"/>
+  <entity name="DownTee" value="&#x022A4;"/>
+  <entity name="DownTeeArrow" value="&#x021A7;"/>
+  <entity name="drbkarow" value="&#x02910;"/>
+  <entity name="drcorn" value="&#x0231F;"/>
+  <entity name="drcrop" value="&#x0230C;"/>
+  <entity name="dscr" value="&#x1D4B9;"/>
+  <entity name="Dscr" value="&#x1D49F;"/>
+  <entity name="dscy" value="&#x00455;"/>
+  <entity name="DScy" value="&#x00405;"/>
+  <entity name="dsol" value="&#x029F6;"/>
+  <entity name="dstrok" value="&#x00111;"/>
+  <entity name="Dstrok" value="&#x00110;"/>
+  <entity name="dtdot" value="&#x022F1;"/>
+  <entity name="dtri" value="&#x025BF;"/>
+  <entity name="dtrif" value="&#x025BE;"/>
+  <entity name="duarr" value="&#x021F5;"/>
+  <entity name="duhar" value="&#x0296F;"/>
+  <entity name="dwangle" value="&#x029A6;"/>
+  <entity name="dzcy" value="&#x0045F;"/>
+  <entity name="DZcy" value="&#x0040F;"/>
+  <entity name="dzigrarr" value="&#x0F5A2;"/>
+  <entity name="eacute" value="&#x000E9;"/>
+  <entity name="Eacute" value="&#x000C9;"/>
+  <entity name="easter" value="&#x0225B;"/>
+  <entity name="ecaron" value="&#x0011B;"/>
+  <entity name="Ecaron" value="&#x0011A;"/>
+  <entity name="ecir" value="&#x02256;"/>
+  <entity name="ecirc" value="&#x000EA;"/>
+  <entity name="Ecirc" value="&#x000CA;"/>
+  <entity name="ecolon" value="&#x02255;"/>
+  <entity name="ecy" value="&#x0044D;"/>
+  <entity name="Ecy" value="&#x0042D;"/>
+  <entity name="eDDot" value="&#x02A77;"/>
+  <entity name="edot" value="&#x00117;"/>
+  <entity name="eDot" value="&#x02251;"/>
+  <entity name="Edot" value="&#x00116;"/>
+  <entity name="ee" value="&#x02147;"/>
+  <entity name="efDot" value="&#x02252;"/>
+  <entity name="efr" value="&#x1D522;"/>
+  <entity name="Efr" value="&#x1D508;"/>
+  <entity name="eg" value="&#x02A9A;"/>
+  <entity name="egrave" value="&#x000E8;"/>
+  <entity name="Egrave" value="&#x000C8;"/>
+  <entity name="egs" value="&#x022DD;"/>
+  <entity name="egsdot" value="&#x02A98;"/>
+  <entity name="el" value="&#x02A99;"/>
+  <entity name="Element" value="&#x02208;"/>
+  <entity name="ell" value="&#x02113;"/>
+  <entity name="els" value="&#x022DC;"/>
+  <entity name="elsdot" value="&#x02A97;"/>
+  <entity name="emacr" value="&#x00113;"/>
+  <entity name="Emacr" value="&#x00112;"/>
+  <entity name="empty" value="&#x02205;&#x0FE00;"/>
+  <entity name="emptyset" value="&#x02205;&#x0FE00;"/>
+  <entity name="EmptySmallSquare" value="&#x025FD;"/>
+  <entity name="emptyv" value="&#x02205;"/>
+  <entity name="EmptyVerySmallSquare" value="&#x0F59C;"/>
+  <entity name="emsp" value="&#x02003;"/>
+  <entity name="emsp13" value="&#x02004;"/>
+  <entity name="emsp14" value="&#x02005;"/>
+  <entity name="eng" value="&#x0014B;"/>
+  <entity name="ENG" value="&#x0014A;"/>
+  <entity name="ensp" value="&#x02002;"/>
+  <entity name="eogon" value="&#x00119;"/>
+  <entity name="Eogon" value="&#x00118;"/>
+  <entity name="eopf" value="&#x1D556;"/>
+  <entity name="Eopf" value="&#x1D53C;"/>
+  <entity name="epar" value="&#x022D5;"/>
+  <entity name="eparsl" value="&#x029E3;"/>
+  <entity name="eplus" value="&#x02A71;"/>
+  <entity name="epsi" value="&#x003B5;"/>
+  <entity name="epsiv" value="&#x0025B;"/>
+  <entity name="eqcirc" value="&#x02256;"/>
+  <entity name="eqcolon" value="&#x02255;"/>
+  <entity name="eqsim" value="&#x02242;"/>
+  <entity name="eqslantgtr" value="&#x022DD;"/>
+  <entity name="eqslantless" value="&#x022DC;"/>
+  <entity name="Equal" value="&#x02A75;"/>
+  <entity name="equals" value="&#x0003D;"/>
+  <entity name="EqualTilde" value="&#x02242;"/>
+  <entity name="equest" value="&#x0225F;"/>
+  <entity name="Equilibrium" value="&#x021CC;"/>
+  <entity name="equiv" value="&#x02261;"/>
+  <entity name="equivDD" value="&#x02A78;"/>
+  <entity name="eqvparsl" value="&#x029E5;"/>
+  <entity name="erarr" value="&#x02971;"/>
+  <entity name="erDot" value="&#x02253;"/>
+  <entity name="escr" value="&#x0212F;"/>
+  <entity name="Escr" value="&#x02130;"/>
+  <entity name="esdot" value="&#x02250;"/>
+  <entity name="esim" value="&#x02242;"/>
+  <entity name="Esim" value="&#x02A73;"/>
+  <entity name="eta" value="&#x003B7;"/>
+  <entity name="eth" value="&#x000F0;"/>
+  <entity name="ETH" value="&#x000D0;"/>
+  <entity name="euml" value="&#x000EB;"/>
+  <entity name="Euml" value="&#x000CB;"/>
+  <entity name="excl" value="&#x00021;"/>
+  <entity name="exist" value="&#x02203;"/>
+  <entity name="Exists" value="&#x02203;"/>
+  <entity name="expectation" value="&#x02130;"/>
+  <entity name="exponentiale" value="&#x02147;"/>
+  <entity name="ExponentialE" value="&#x02147;"/>
+  <entity name="fallingdotseq" value="&#x02252;"/>
+  <entity name="fcy" value="&#x00444;"/>
+  <entity name="Fcy" value="&#x00424;"/>
+  <entity name="female" value="&#x02640;"/>
+  <entity name="ffilig" value="&#x0FB03;"/>
+  <entity name="fflig" value="&#x0FB00;"/>
+  <entity name="ffllig" value="&#x0FB04;"/>
+  <entity name="ffr" value="&#x1D523;"/>
+  <entity name="Ffr" value="&#x1D509;"/>
+  <entity name="filig" value="&#x0FB01;"/>
+  <entity name="FilledSmallSquare" value="&#x025FE;"/>
+  <entity name="FilledVerySmallSquare" value="&#x0F59B;"/>
+  <entity name="flat" value="&#x0266D;"/>
+  <entity name="fllig" value="&#x0FB02;"/>
+  <entity name="fnof" value="&#x00192;"/>
+  <entity name="fopf" value="&#x1D557;"/>
+  <entity name="Fopf" value="&#x1D53D;"/>
+  <entity name="forall" value="&#x02200;"/>
+  <entity name="ForAll" value="&#x02200;"/>
+  <entity name="fork" value="&#x022D4;"/>
+  <entity name="forkv" value="&#x02AD9;"/>
+  <entity name="Fouriertrf" value="&#x02131;"/>
+  <entity name="fpartint" value="&#x02A0D;"/>
+  <entity name="frac12" value="&#x000BD;"/>
+  <entity name="frac13" value="&#x02153;"/>
+  <entity name="frac14" value="&#x000BC;"/>
+  <entity name="frac15" value="&#x02155;"/>
+  <entity name="frac16" value="&#x02159;"/>
+  <entity name="frac18" value="&#x0215B;"/>
+  <entity name="frac23" value="&#x02154;"/>
+  <entity name="frac25" value="&#x02156;"/>
+  <entity name="frac34" value="&#x000BE;"/>
+  <entity name="frac35" value="&#x02157;"/>
+  <entity name="frac38" value="&#x0215C;"/>
+  <entity name="frac45" value="&#x02158;"/>
+  <entity name="frac56" value="&#x0215A;"/>
+  <entity name="frac58" value="&#x0215D;"/>
+  <entity name="frac78" value="&#x0215E;"/>
+  <entity name="frown" value="&#x02322;"/>
+  <entity name="fscr" value="&#x1D4BB;"/>
+  <entity name="Fscr" value="&#x02131;"/>
+  <entity name="gacute" value="&#x001F5;"/>
+  <entity name="gamma" value="&#x003B3;"/>
+  <entity name="Gamma" value="&#x00393;"/>
+  <entity name="gammad" value="&#x003DC;"/>
+  <entity name="Gammad" value="&#x003DC;"/>
+  <entity name="gap" value="&#x02273;"/>
+  <entity name="gbreve" value="&#x0011F;"/>
+  <entity name="Gbreve" value="&#x0011E;"/>
+  <entity name="Gcedil" value="&#x00122;"/>
+  <entity name="gcirc" value="&#x0011D;"/>
+  <entity name="Gcirc" value="&#x0011C;"/>
+  <entity name="gcy" value="&#x00433;"/>
+  <entity name="Gcy" value="&#x00413;"/>
+  <entity name="gdot" value="&#x00121;"/>
+  <entity name="Gdot" value="&#x00120;"/>
+  <entity name="ge" value="&#x02265;"/>
+  <entity name="gE" value="&#x02267;"/>
+  <entity name="gel" value="&#x022DB;"/>
+  <entity name="gEl" value="&#x022DB;"/>
+  <entity name="geq" value="&#x02265;"/>
+  <entity name="geqq" value="&#x02267;"/>
+  <entity name="geqslant" value="&#x02A7E;"/>
+  <entity name="ges" value="&#x02A7E;"/>
+  <entity name="gescc" value="&#x02AA9;"/>
+  <entity name="gesdot" value="&#x02A80;"/>
+  <entity name="gesdoto" value="&#x02A82;"/>
+  <entity name="gesdotol" value="&#x02A84;"/>
+  <entity name="gesl" value="&#x022DB;&#x0FE00;"/>
+  <entity name="gesles" value="&#x02A94;"/>
+  <entity name="gfr" value="&#x1D524;"/>
+  <entity name="Gfr" value="&#x1D50A;"/>
+  <entity name="gg" value="&#x0226B;"/>
+  <entity name="Gg" value="&#x022D9;"/>
+  <entity name="ggg" value="&#x022D9;"/>
+  <entity name="gimel" value="&#x02137;"/>
+  <entity name="gjcy" value="&#x00453;"/>
+  <entity name="GJcy" value="&#x00403;"/>
+  <entity name="gl" value="&#x02277;"/>
+  <entity name="gla" value="&#x02AA5;"/>
+  <entity name="glE" value="&#x02A92;"/>
+  <entity name="glj" value="&#x02AA4;"/>
+  <entity name="gnap" value="&#x02A8A;"/>
+  <entity name="gnapprox" value="&#x02A8A;"/>
+  <entity name="gne" value="&#x02269;"/>
+  <entity name="gnE" value="&#x02269;"/>
+  <entity name="gneq" value="&#x02269;"/>
+  <entity name="gneqq" value="&#x02269;"/>
+  <entity name="gnsim" value="&#x022E7;"/>
+  <entity name="gopf" value="&#x1D558;"/>
+  <entity name="Gopf" value="&#x1D53E;"/>
+  <entity name="grave" value="&#x00060;"/>
+  <entity name="GreaterEqual" value="&#x02265;"/>
+  <entity name="GreaterEqualLess" value="&#x022DB;"/>
+  <entity name="GreaterFullEqual" value="&#x02267;"/>
+  <entity name="GreaterGreater" value="&#x02AA2;"/>
+  <entity name="GreaterLess" value="&#x02277;"/>
+  <entity name="GreaterSlantEqual" value="&#x02A7E;"/>
+  <entity name="GreaterTilde" value="&#x02273;"/>
+  <entity name="gscr" value="&#x0210A;"/>
+  <entity name="Gscr" value="&#x1D4A2;"/>
+  <entity name="gsim" value="&#x02273;"/>
+  <entity name="gsime" value="&#x02A8E;"/>
+  <entity name="gsiml" value="&#x02A90;"/>
+  <entity name="gt" value="&#x0003E;"/>
+  <entity name="Gt" value="&#x0226B;"/>
+  <entity name="gtcc" value="&#x02AA7;"/>
+  <entity name="gtcir" value="&#x02A7A;"/>
+  <entity name="gtdot" value="&#x022D7;"/>
+  <entity name="gtlPar" value="&#x02995;"/>
+  <entity name="gtquest" value="&#x02A7C;"/>
+  <entity name="gtrapprox" value="&#x02273;"/>
+  <entity name="gtrarr" value="&#x02978;"/>
+  <entity name="gtrdot" value="&#x022D7;"/>
+  <entity name="gtreqless" value="&#x022DB;"/>
+  <entity name="gtreqqless" value="&#x022DB;"/>
+  <entity name="gtrless" value="&#x02277;"/>
+  <entity name="gtrsim" value="&#x02273;"/>
+  <entity name="gvertneqq" value="&#x02269;&#x0FE00;"/>
+  <entity name="gvnE" value="&#x02269;&#x0FE00;"/>
+  <entity name="Hacek" value="&#x002C7;"/>
+  <entity name="hairsp" value="&#x0200A;"/>
+  <entity name="half" value="&#x000BD;"/>
+  <entity name="hamilt" value="&#x0210B;"/>
+  <entity name="hardcy" value="&#x0044A;"/>
+  <entity name="HARDcy" value="&#x0042A;"/>
+  <entity name="harr" value="&#x02194;"/>
+  <entity name="hArr" value="&#x021D4;"/>
+  <entity name="harrcir" value="&#x02948;"/>
+  <entity name="harrw" value="&#x021AD;"/>
+  <entity name="Hat" value="&#x00302;"/>
+  <entity name="hbar" value="&#x0210F;&#x0FE00;"/>
+  <entity name="hcirc" value="&#x00125;"/>
+  <entity name="Hcirc" value="&#x00124;"/>
+  <entity name="heartsuit" value="&#x02661;"/>
+  <entity name="hellip" value="&#x02026;"/>
+  <entity name="hercon" value="&#x022B9;"/>
+  <entity name="hfr" value="&#x1D525;"/>
+  <entity name="Hfr" value="&#x0210C;"/>
+  <entity name="HilbertSpace" value="&#x0210B;"/>
+  <entity name="hksearow" value="&#x02925;"/>
+  <entity name="hkswarow" value="&#x02926;"/>
+  <entity name="hoarr" value="&#x021FF;"/>
+  <entity name="homtht" value="&#x0223B;"/>
+  <entity name="hookleftarrow" value="&#x021A9;"/>
+  <entity name="hookrightarrow" value="&#x021AA;"/>
+  <entity name="hopf" value="&#x1D559;"/>
+  <entity name="Hopf" value="&#x0210D;"/>
+  <entity name="horbar" value="&#x02015;"/>
+  <entity name="HorizontalLine" value="&#x02500;"/>
+  <entity name="hscr" value="&#x1D4BD;"/>
+  <entity name="Hscr" value="&#x0210B;"/>
+  <entity name="hslash" value="&#x0210F;"/>
+  <entity name="hstrok" value="&#x00127;"/>
+  <entity name="Hstrok" value="&#x00126;"/>
+  <entity name="HumpDownHump" value="&#x0224E;"/>
+  <entity name="HumpEqual" value="&#x0224F;"/>
+  <entity name="hybull" value="&#x02043;"/>
+  <entity name="hyphen" value="&#x02010;"/>
+  <entity name="iacute" value="&#x000ED;"/>
+  <entity name="Iacute" value="&#x000CD;"/>
+  <entity name="ic" value="&#x0200B;"/>
+  <entity name="icirc" value="&#x000EE;"/>
+  <entity name="Icirc" value="&#x000CE;"/>
+  <entity name="icy" value="&#x00438;"/>
+  <entity name="Icy" value="&#x00418;"/>
+  <entity name="Idot" value="&#x00130;"/>
+  <entity name="iecy" value="&#x00435;"/>
+  <entity name="IEcy" value="&#x00415;"/>
+  <entity name="iexcl" value="&#x000A1;"/>
+  <entity name="iff" value="&#x021D4;"/>
+  <entity name="ifr" value="&#x1D526;"/>
+  <entity name="Ifr" value="&#x02111;"/>
+  <entity name="igrave" value="&#x000EC;"/>
+  <entity name="Igrave" value="&#x000CC;"/>
+  <entity name="ii" value="&#x02148;"/>
+  <entity name="iiiint" value="&#x02A0C;"/>
+  <entity name="iiint" value="&#x0222D;"/>
+  <entity name="iinfin" value="&#x029DC;"/>
+  <entity name="iiota" value="&#x02129;"/>
+  <entity name="ijlig" value="&#x00133;"/>
+  <entity name="IJlig" value="&#x00132;"/>
+  <entity name="Im" value="&#x02111;"/>
+  <entity name="imacr" value="&#x0012B;"/>
+  <entity name="Imacr" value="&#x0012A;"/>
+  <entity name="image" value="&#x02111;"/>
+  <entity name="ImaginaryI" value="&#x02148;"/>
+  <entity name="imagline" value="&#x02110;"/>
+  <entity name="imagpart" value="&#x02111;"/>
+  <entity name="imath" value="&#x00131;"/>
+  <entity name="imof" value="&#x022B7;"/>
+  <entity name="imped" value="&#x1D543;"/>
+  <entity name="Implies" value="&#x021D2;"/>
+  <entity name="in" value="&#x02208;"/>
+  <entity name="incare" value="&#x02105;"/>
+  <entity name="infin" value="&#x0221E;"/>
+  <entity name="inodot" value="&#x00131;"/>
+  <entity name="int" value="&#x0222B;"/>
+  <entity name="Int" value="&#x0222C;"/>
+  <entity name="intcal" value="&#x022BA;"/>
+  <entity name="integers" value="&#x02124;"/>
+  <entity name="Integral" value="&#x0222B;"/>
+  <entity name="intercal" value="&#x022BA;"/>
+  <entity name="Intersection" value="&#x022C2;"/>
+  <entity name="intlarhk" value="&#x02A17;"/>
+  <entity name="intprod" value="&#x02A3C;"/>
+  <entity name="InvisibleComma" value="&#x0200B;"/>
+  <entity name="InvisibleTimes" value="&#x02062;"/>
+  <entity name="iocy" value="&#x00451;"/>
+  <entity name="IOcy" value="&#x00401;"/>
+  <entity name="iogon" value="&#x0012F;"/>
+  <entity name="Iogon" value="&#x0012E;"/>
+  <entity name="iopf" value="&#x1D55A;"/>
+  <entity name="Iopf" value="&#x1D540;"/>
+  <entity name="iota" value="&#x003B9;"/>
+  <entity name="iprod" value="&#x02A3C;"/>
+  <entity name="iquest" value="&#x000BF;"/>
+  <entity name="iscr" value="&#x1D4BE;"/>
+  <entity name="Iscr" value="&#x02110;"/>
+  <entity name="isin" value="&#x02208;"/>
+  <entity name="isindot" value="&#x022F5;"/>
+  <entity name="isinE" value="&#x022F9;"/>
+  <entity name="isins" value="&#x022F4;"/>
+  <entity name="isinsv" value="&#x022F3;"/>
+  <entity name="isinv" value="&#x02208;"/>
+  <entity name="it" value="&#x02062;"/>
+  <entity name="itilde" value="&#x00129;"/>
+  <entity name="Itilde" value="&#x00128;"/>
+  <entity name="iukcy" value="&#x00456;"/>
+  <entity name="Iukcy" value="&#x00406;"/>
+  <entity name="iuml" value="&#x000EF;"/>
+  <entity name="Iuml" value="&#x000CF;"/>
+  <entity name="jcirc" value="&#x00135;"/>
+  <entity name="Jcirc" value="&#x00134;"/>
+  <entity name="jcy" value="&#x00439;"/>
+  <entity name="Jcy" value="&#x00419;"/>
+  <entity name="jfr" value="&#x1D527;"/>
+  <entity name="Jfr" value="&#x1D50D;"/>
+  <entity name="jmath" value="&#x0006A;&#x0FE00;"/>
+  <entity name="jopf" value="&#x1D55B;"/>
+  <entity name="Jopf" value="&#x1D541;"/>
+  <entity name="jscr" value="&#x1D4BF;"/>
+  <entity name="Jscr" value="&#x1D4A5;"/>
+  <entity name="jsercy" value="&#x00458;"/>
+  <entity name="Jsercy" value="&#x00408;"/>
+  <entity name="jukcy" value="&#x00454;"/>
+  <entity name="Jukcy" value="&#x00404;"/>
+  <entity name="kappa" value="&#x003BA;"/>
+  <entity name="kappav" value="&#x003F0;"/>
+  <entity name="kcedil" value="&#x00137;"/>
+  <entity name="Kcedil" value="&#x00136;"/>
+  <entity name="kcy" value="&#x0043A;"/>
+  <entity name="Kcy" value="&#x0041A;"/>
+  <entity name="kfr" value="&#x1D528;"/>
+  <entity name="Kfr" value="&#x1D50E;"/>
+  <entity name="kgreen" value="&#x00138;"/>
+  <entity name="khcy" value="&#x00445;"/>
+  <entity name="KHcy" value="&#x00425;"/>
+  <entity name="kjcy" value="&#x0045C;"/>
+  <entity name="KJcy" value="&#x0040C;"/>
+  <entity name="kopf" value="&#x1D55C;"/>
+  <entity name="Kopf" value="&#x1D542;"/>
+  <entity name="kscr" value="&#x1D4C0;"/>
+  <entity name="Kscr" value="&#x1D4A6;"/>
+  <entity name="lAarr" value="&#x021DA;"/>
+  <entity name="lacute" value="&#x0013A;"/>
+  <entity name="Lacute" value="&#x00139;"/>
+  <entity name="laemptyv" value="&#x029B4;"/>
+  <entity name="lagran" value="&#x02112;"/>
+  <entity name="lambda" value="&#x003BB;"/>
+  <entity name="Lambda" value="&#x0039B;"/>
+  <entity name="lang" value="&#x02329;"/>
+  <entity name="Lang" value="&#x0300A;"/>
+  <entity name="langd" value="&#x02991;"/>
+  <entity name="langle" value="&#x02329;"/>
+  <entity name="lap" value="&#x02272;"/>
+  <entity name="Laplacetrf" value="&#x02112;"/>
+  <entity name="laquo" value="&#x000AB;"/>
+  <entity name="larr" value="&#x02190;"/>
+  <entity name="lArr" value="&#x021D0;"/>
+  <entity name="Larr" value="&#x0219E;"/>
+  <entity name="larrb" value="&#x021E4;"/>
+  <entity name="larrbfs" value="&#x0291F;"/>
+  <entity name="larrfs" value="&#x0291D;"/>
+  <entity name="larrhk" value="&#x021A9;"/>
+  <entity name="larrlp" value="&#x021AB;"/>
+  <entity name="larrpl" value="&#x02939;"/>
+  <entity name="larrsim" value="&#x02973;"/>
+  <entity name="larrtl" value="&#x021A2;"/>
+  <entity name="lat" value="&#x02AAB;"/>
+  <entity name="latail" value="&#x02919;"/>
+  <entity name="lAtail" value="&#x0291B;"/>
+  <entity name="late" value="&#x02AAD;"/>
+  <entity name="lates" value="&#x02AAD;&#x0FE00;"/>
+  <entity name="lbarr" value="&#x0290C;"/>
+  <entity name="lBarr" value="&#x0290E;"/>
+  <entity name="lbbrk" value="&#x03014;"/>
+  <entity name="lbrace" value="&#x0007B;"/>
+  <entity name="lbrack" value="&#x0005B;"/>
+  <entity name="lbrke" value="&#x0298B;"/>
+  <entity name="lbrksld" value="&#x0298F;"/>
+  <entity name="lbrkslu" value="&#x0298D;"/>
+  <entity name="lcaron" value="&#x0013E;"/>
+  <entity name="Lcaron" value="&#x0013D;"/>
+  <entity name="lcedil" value="&#x0013C;"/>
+  <entity name="Lcedil" value="&#x0013B;"/>
+  <entity name="lceil" value="&#x02308;"/>
+  <entity name="lcub" value="&#x0007B;"/>
+  <entity name="lcy" value="&#x0043B;"/>
+  <entity name="Lcy" value="&#x0041B;"/>
+  <entity name="ldca" value="&#x02936;"/>
+  <entity name="ldquo" value="&#x0201C;"/>
+  <entity name="ldquor" value="&#x0201E;"/>
+  <entity name="ldrdhar" value="&#x02967;"/>
+  <entity name="ldrushar" value="&#x0294B;"/>
+  <entity name="ldsh" value="&#x021B2;"/>
+  <entity name="le" value="&#x02264;"/>
+  <entity name="lE" value="&#x02266;"/>
+  <entity name="LeftAngleBracket" value="&#x02329;"/>
+  <entity name="leftarrow" value="&#x02190;"/>
+  <entity name="Leftarrow" value="&#x021D0;"/>
+  <entity name="LeftArrow" value="&#x02190;"/>
+  <entity name="LeftArrowBar" value="&#x021E4;"/>
+  <entity name="LeftArrowRightArrow" value="&#x021C6;"/>
+  <entity name="leftarrowtail" value="&#x021A2;"/>
+  <entity name="LeftCeiling" value="&#x02308;"/>
+  <entity name="LeftDoubleBracket" value="&#x0301A;"/>
+  <entity name="LeftDownTeeVector" value="&#x02961;"/>
+  <entity name="LeftDownVector" value="&#x021C3;"/>
+  <entity name="LeftDownVectorBar" value="&#x02959;"/>
+  <entity name="LeftFloor" value="&#x0230A;"/>
+  <entity name="leftharpoondown" value="&#x021BD;"/>
+  <entity name="leftharpoonup" value="&#x021BC;"/>
+  <entity name="leftleftarrows" value="&#x021C7;"/>
+  <entity name="leftrightarrow" value="&#x02194;"/>
+  <entity name="Leftrightarrow" value="&#x021D4;"/>
+  <entity name="LeftRightArrow" value="&#x02194;"/>
+  <entity name="leftrightarrows" value="&#x021C6;"/>
+  <entity name="leftrightharpoons" value="&#x021CB;"/>
+  <entity name="leftrightsquigarrow" value="&#x021AD;"/>
+  <entity name="LeftRightVector" value="&#x0294E;"/>
+  <entity name="LeftTee" value="&#x022A3;"/>
+  <entity name="LeftTeeArrow" value="&#x021A4;"/>
+  <entity name="LeftTeeVector" value="&#x0295A;"/>
+  <entity name="leftthreetimes" value="&#x022CB;"/>
+  <entity name="LeftTriangle" value="&#x022B2;"/>
+  <entity name="LeftTriangleBar" value="&#x029CF;"/>
+  <entity name="LeftTriangleEqual" value="&#x022B4;"/>
+  <entity name="LeftUpDownVector" value="&#x02951;"/>
+  <entity name="LeftUpTeeVector" value="&#x02960;"/>
+  <entity name="LeftUpVector" value="&#x021BF;"/>
+  <entity name="LeftUpVectorBar" value="&#x02958;"/>
+  <entity name="LeftVector" value="&#x021BC;"/>
+  <entity name="LeftVectorBar" value="&#x02952;"/>
+  <entity name="leg" value="&#x022DA;"/>
+  <entity name="lEg" value="&#x022DA;"/>
+  <entity name="leq" value="&#x02264;"/>
+  <entity name="leqq" value="&#x02266;"/>
+  <entity name="leqslant" value="&#x02A7D;"/>
+  <entity name="les" value="&#x02A7D;"/>
+  <entity name="lescc" value="&#x02AA8;"/>
+  <entity name="lesdot" value="&#x02A7F;"/>
+  <entity name="lesdoto" value="&#x02A81;"/>
+  <entity name="lesdotor" value="&#x02A83;"/>
+  <entity name="lesg" value="&#x022DA;&#x0FE00;"/>
+  <entity name="lesges" value="&#x02A93;"/>
+  <entity name="lessapprox" value="&#x02272;"/>
+  <entity name="lessdot" value="&#x022D6;"/>
+  <entity name="lesseqgtr" value="&#x022DA;"/>
+  <entity name="lesseqqgtr" value="&#x022DA;"/>
+  <entity name="LessEqualGreater" value="&#x022DA;"/>
+  <entity name="LessFullEqual" value="&#x02266;"/>
+  <entity name="LessGreater" value="&#x02276;"/>
+  <entity name="lessgtr" value="&#x02276;"/>
+  <entity name="LessLess" value="&#x02AA1;"/>
+  <entity name="lesssim" value="&#x02272;"/>
+  <entity name="LessSlantEqual" value="&#x02A7D;"/>
+  <entity name="LessTilde" value="&#x02272;"/>
+  <entity name="lfisht" value="&#x0297C;"/>
+  <entity name="lfloor" value="&#x0230A;"/>
+  <entity name="lfr" value="&#x1D529;"/>
+  <entity name="Lfr" value="&#x1D50F;"/>
+  <entity name="lg" value="&#x02276;"/>
+  <entity name="lgE" value="&#x02A91;"/>
+  <entity name="lHar" value="&#x02962;"/>
+  <entity name="lhard" value="&#x021BD;"/>
+  <entity name="lharu" value="&#x021BC;"/>
+  <entity name="lharul" value="&#x0296A;"/>
+  <entity name="lhblk" value="&#x02584;"/>
+  <entity name="ljcy" value="&#x00459;"/>
+  <entity name="LJcy" value="&#x00409;"/>
+  <entity name="ll" value="&#x0226A;"/>
+  <entity name="Ll" value="&#x022D8;"/>
+  <entity name="llarr" value="&#x021C7;"/>
+  <entity name="llcorner" value="&#x0231E;"/>
+  <entity name="Lleftarrow" value="&#x021DA;"/>
+  <entity name="llhard" value="&#x0296B;"/>
+  <entity name="lltri" value="&#x025FA;"/>
+  <entity name="lmidot" value="&#x00140;"/>
+  <entity name="Lmidot" value="&#x0013F;"/>
+  <entity name="lmoust" value="&#x023B0;"/>
+  <entity name="lmoustache" value="&#x023B0;"/>
+  <entity name="lnap" value="&#x02A89;"/>
+  <entity name="lnapprox" value="&#x02A89;"/>
+  <entity name="lne" value="&#x02268;"/>
+  <entity name="lnE" value="&#x02268;"/>
+  <entity name="lneq" value="&#x02268;"/>
+  <entity name="lneqq" value="&#x02268;"/>
+  <entity name="lnsim" value="&#x022E6;"/>
+  <entity name="loang" value="&#x0F558;"/>
+  <entity name="loarr" value="&#x021FD;"/>
+  <entity name="lobrk" value="&#x0301A;"/>
+  <entity name="longleftarrow" value="&#x0F576;"/>
+  <entity name="Longleftarrow" value="&#x0F579;"/>
+  <entity name="LongLeftArrow" value="&#x0F576;"/>
+  <entity name="longleftrightarrow" value="&#x0F578;"/>
+  <entity name="Longleftrightarrow" value="&#x0F57B;"/>
+  <entity name="LongLeftRightArrow" value="&#x0F578;"/>
+  <entity name="longmapsto" value="&#x0F57D;"/>
+  <entity name="longrightarrow" value="&#x0F577;"/>
+  <entity name="Longrightarrow" value="&#x0F57A;"/>
+  <entity name="LongRightArrow" value="&#x0F577;"/>
+  <entity name="looparrowleft" value="&#x021AB;"/>
+  <entity name="looparrowright" value="&#x021AC;"/>
+  <entity name="lopar" value="&#x03018;"/>
+  <entity name="lopf" value="&#x1D55D;"/>
+  <entity name="Lopf" value="&#x1D543;"/>
+  <entity name="loplus" value="&#x02A2D;"/>
+  <entity name="lotimes" value="&#x02A34;"/>
+  <entity name="lowast" value="&#x02217;"/>
+  <entity name="lowbar" value="&#x0005F;"/>
+  <entity name="LowerLeftArrow" value="&#x02199;"/>
+  <entity name="LowerRightArrow" value="&#x02198;"/>
+  <entity name="loz" value="&#x025CA;"/>
+  <entity name="lozenge" value="&#x025CA;"/>
+  <entity name="lozf" value="&#x029EB;"/>
+  <entity name="lpar" value="&#x00028;"/>
+  <entity name="lparlt" value="&#x02993;"/>
+  <entity name="lrarr" value="&#x021C6;"/>
+  <entity name="lrcorner" value="&#x0231F;"/>
+  <entity name="lrhar" value="&#x021CB;"/>
+  <entity name="lrhard" value="&#x0296D;"/>
+  <entity name="lrtri" value="&#x022BF;"/>
+  <entity name="lscr" value="&#x02113;"/>
+  <entity name="Lscr" value="&#x02112;"/>
+  <entity name="lsh" value="&#x021B0;"/>
+  <entity name="Lsh" value="&#x021B0;"/>
+  <entity name="lsim" value="&#x02272;"/>
+  <entity name="lsime" value="&#x02A8D;"/>
+  <entity name="lsimg" value="&#x02A8F;"/>
+  <entity name="lsqb" value="&#x0005B;"/>
+  <entity name="lsquo" value="&#x02018;"/>
+  <entity name="lsquor" value="&#x0201A;"/>
+  <entity name="lstrok" value="&#x00142;"/>
+  <entity name="Lstrok" value="&#x00141;"/>
+  <entity name="lt" value="&#x0003C;"/>
+  <entity name="Lt" value="&#x0226A;"/>
+  <entity name="ltcc" value="&#x02AA6;"/>
+  <entity name="ltcir" value="&#x02A79;"/>
+  <entity name="ltdot" value="&#x022D6;"/>
+  <entity name="lthree" value="&#x022CB;"/>
+  <entity name="ltimes" value="&#x022C9;"/>
+  <entity name="ltlarr" value="&#x02976;"/>
+  <entity name="ltquest" value="&#x02A7B;"/>
+  <entity name="ltri" value="&#x025C3;"/>
+  <entity name="ltrie" value="&#x022B4;"/>
+  <entity name="ltrif" value="&#x025C2;"/>
+  <entity name="ltrPar" value="&#x02996;"/>
+  <entity name="lurdshar" value="&#x0294A;"/>
+  <entity name="luruhar" value="&#x02966;"/>
+  <entity name="lvertneqq" value="&#x02268;&#x0FE00;"/>
+  <entity name="lvnE" value="&#x02268;&#x0FE00;"/>
+  <entity name="macr" value="&#x000AF;"/>
+  <entity name="male" value="&#x02642;"/>
+  <entity name="malt" value="&#x02720;"/>
+  <entity name="maltese" value="&#x02720;"/>
+  <entity name="map" value="&#x021A6;"/>
+  <entity name="Map" value="&#x02905;"/>
+  <entity name="mapsto" value="&#x021A6;"/>
+  <entity name="mapstodown" value="&#x021A7;"/>
+  <entity name="mapstoleft" value="&#x021A4;"/>
+  <entity name="mapstoup" value="&#x021A5;"/>
+  <entity name="marker" value="&#x025AE;"/>
+  <entity name="mcomma" value="&#x02A29;"/>
+  <entity name="mcy" value="&#x0043C;"/>
+  <entity name="Mcy" value="&#x0041C;"/>
+  <entity name="mdash" value="&#x02014;"/>
+  <entity name="mDDot" value="&#x0223A;"/>
+  <entity name="measuredangle" value="&#x02221;"/>
+  <entity name="MediumSpace" value="&#x0205F;"/>
+  <entity name="Mellintrf" value="&#x02133;"/>
+  <entity name="mfr" value="&#x1D52A;"/>
+  <entity name="Mfr" value="&#x1D510;"/>
+  <entity name="mho" value="&#x02127;"/>
+  <entity name="micro" value="&#x000B5;"/>
+  <entity name="mid" value="&#x02223;"/>
+  <entity name="midast" value="&#x0002A;"/>
+  <entity name="midcir" value="&#x02AF0;"/>
+  <entity name="middot" value="&#x000B7;"/>
+  <entity name="minus" value="&#x02212;"/>
+  <entity name="minusb" value="&#x0229F;"/>
+  <entity name="minusd" value="&#x02238;"/>
+  <entity name="minusdu" value="&#x02A2A;"/>
+  <entity name="MinusPlus" value="&#x02213;"/>
+  <entity name="mlcp" value="&#x02ADB;"/>
+  <entity name="mldr" value="&#x02026;"/>
+  <entity name="mnplus" value="&#x02213;"/>
+  <entity name="models" value="&#x022A7;"/>
+  <entity name="mopf" value="&#x1D55E;"/>
+  <entity name="Mopf" value="&#x1D544;"/>
+  <entity name="mp" value="&#x02213;"/>
+  <entity name="mscr" value="&#x1D4C2;"/>
+  <entity name="Mscr" value="&#x02133;"/>
+  <entity name="mstpos" value="&#x0223E;"/>
+  <entity name="mu" value="&#x003BC;"/>
+  <entity name="multimap" value="&#x022B8;"/>
+  <entity name="mumap" value="&#x022B8;"/>
+  <entity name="nabla" value="&#x02207;"/>
+  <entity name="nacute" value="&#x00144;"/>
+  <entity name="Nacute" value="&#x00143;"/>
+  <entity name="nang" value="&#x02220;&#x00338;"/>
+  <entity name="nap" value="&#x02249;"/>
+  <entity name="napE" value="&#x02A70;&#x00338;"/>
+  <entity name="napid" value="&#x0224B;&#x00338;"/>
+  <entity name="napos" value="&#x00149;"/>
+  <entity name="napprox" value="&#x02249;"/>
+  <entity name="natur" value="&#x0266E;"/>
+  <entity name="natural" value="&#x0266E;"/>
+  <entity name="naturals" value="&#x02115;"/>
+  <entity name="nbsp" value="&#x000A0;"/>
+  <entity name="nbump" value="&#x0224E;&#x00338;"/>
+  <entity name="nbumpe" value="&#x0224F;&#x00338;"/>
+  <entity name="ncap" value="&#x02A43;"/>
+  <entity name="ncaron" value="&#x00148;"/>
+  <entity name="Ncaron" value="&#x00147;"/>
+  <entity name="ncedil" value="&#x00146;"/>
+  <entity name="Ncedil" value="&#x00145;"/>
+  <entity name="ncong" value="&#x02247;"/>
+  <entity name="ncongdot" value="&#x02A6D;&#x00338;"/>
+  <entity name="ncup" value="&#x02A42;"/>
+  <entity name="ncy" value="&#x0043D;"/>
+  <entity name="Ncy" value="&#x0041D;"/>
+  <entity name="ndash" value="&#x02013;"/>
+  <entity name="ne" value="&#x02260;"/>
+  <entity name="nearhk" value="&#x02924;"/>
+  <entity name="nearr" value="&#x02197;"/>
+  <entity name="neArr" value="&#x021D7;"/>
+  <entity name="nearrow" value="&#x02197;"/>
+  <entity name="nedot" value="&#x02260;&#x0FE00;"/>
+  <entity name="NegativeMediumSpace" value="&#x0205F;&#x0FE00;"/>
+  <entity name="NegativeThickSpace" value="&#x02005;&#x0FE00;"/>
+  <entity name="NegativeThinSpace" value="&#x02009;&#x0FE00;"/>
+  <entity name="NegativeVeryThinSpace" value="&#x0200A;&#x0FE00;"/>
+  <entity name="nequiv" value="&#x02262;"/>
+  <entity name="nesear" value="&#x02928;"/>
+  <entity name="nesim" value="&#x02242;&#x00338;"/>
+  <entity name="NestedGreaterGreater" value="&#x0226B;"/>
+  <entity name="NestedLessLess" value="&#x0226A;"/>
+  <entity name="NewLine" value="&#x0000A;"/>
+  <entity name="nexist" value="&#x02204;"/>
+  <entity name="nexists" value="&#x02204;"/>
+  <entity name="nfr" value="&#x1D52B;"/>
+  <entity name="Nfr" value="&#x1D511;"/>
+  <entity name="nge" value="&#x02271;&#x020E5;"/>
+  <entity name="ngE" value="&#x02271;"/>
+  <entity name="ngeq" value="&#x02271;&#x020E5;"/>
+  <entity name="ngeqq" value="&#x02271;"/>
+  <entity name="ngeqslant" value="&#x02271;"/>
+  <entity name="nges" value="&#x02271;"/>
+  <entity name="nGg" value="&#x022D9;&#x00338;"/>
+  <entity name="ngsim" value="&#x02275;"/>
+  <entity name="ngt" value="&#x0226F;"/>
+  <entity name="nGt" value="&#x0226B;&#x00338;"/>
+  <entity name="ngtr" value="&#x0226F;"/>
+  <entity name="nGtv" value="&#x0226B;&#x00338;&#x0FE00;"/>
+  <entity name="nharr" value="&#x021AE;"/>
+  <entity name="nhArr" value="&#x021CE;"/>
+  <entity name="nhpar" value="&#x02AF2;"/>
+  <entity name="ni" value="&#x0220B;"/>
+  <entity name="nis" value="&#x022FC;"/>
+  <entity name="nisd" value="&#x022FA;"/>
+  <entity name="niv" value="&#x0220B;"/>
+  <entity name="njcy" value="&#x0045A;"/>
+  <entity name="NJcy" value="&#x0040A;"/>
+  <entity name="nlarr" value="&#x0219A;"/>
+  <entity name="nlArr" value="&#x021CD;"/>
+  <entity name="nldr" value="&#x02025;"/>
+  <entity name="nle" value="&#x02270;&#x020E5;"/>
+  <entity name="nlE" value="&#x02270;"/>
+  <entity name="nleftarrow" value="&#x0219A;"/>
+  <entity name="nLeftarrow" value="&#x021CD;"/>
+  <entity name="nleftrightarrow" value="&#x021AE;"/>
+  <entity name="nLeftrightarrow" value="&#x021CE;"/>
+  <entity name="nleq" value="&#x02270;&#x020E5;"/>
+  <entity name="nleqq" value="&#x02270;"/>
+  <entity name="nleqslant" value="&#x02270;"/>
+  <entity name="nles" value="&#x02270;"/>
+  <entity name="nless" value="&#x0226E;"/>
+  <entity name="nLl" value="&#x022D8;&#x00338;"/>
+  <entity name="nlsim" value="&#x02274;"/>
+  <entity name="nlt" value="&#x0226E;"/>
+  <entity name="nLt" value="&#x0226A;&#x00338;"/>
+  <entity name="nltri" value="&#x022EA;"/>
+  <entity name="nltrie" value="&#x022EC;"/>
+  <entity name="nLtv" value="&#x0226A;&#x00338;&#x0FE00;"/>
+  <entity name="nmid" value="&#x02224;"/>
+  <entity name="NoBreak" value="&#x0FEFF;"/>
+  <entity name="NonBreakingSpace" value="&#x000A0;"/>
+  <entity name="nopf" value="&#x1D55F;"/>
+  <entity name="Nopf" value="&#x02115;"/>
+  <entity name="not" value="&#x000AC;"/>
+  <entity name="Not" value="&#x02AEC;"/>
+  <entity name="NotCongruent" value="&#x02262;"/>
+  <entity name="NotCupCap" value="&#x0226D;"/>
+  <entity name="NotDoubleVerticalBar" value="&#x02226;"/>
+  <entity name="NotElement" value="&#x02209;"/>
+  <entity name="NotEqual" value="&#x02260;"/>
+  <entity name="NotEqualTilde" value="&#x02242;&#x00338;"/>
+  <entity name="NotExists" value="&#x02204;"/>
+  <entity name="NotGreater" value="&#x0226F;"/>
+  <entity name="NotGreaterEqual" value="&#x02271;&#x020E5;"/>
+  <entity name="NotGreaterFullEqual" value="&#x02270;"/>
+  <entity name="NotGreaterGreater" value="&#x0226B;&#x00338;&#x0FE00;"/>
+  <entity name="NotGreaterLess" value="&#x02279;"/>
+  <entity name="NotGreaterSlantEqual" value="&#x02271;"/>
+  <entity name="NotGreaterTilde" value="&#x02275;"/>
+  <entity name="NotHumpDownHump" value="&#x0224E;&#x00338;"/>
+  <entity name="NotHumpEqual" value="&#x0224F;&#x00338;"/>
+  <entity name="notin" value="&#x02209;"/>
+  <entity name="notindot" value="&#x022F6;&#x0FE00;"/>
+  <entity name="notinva" value="&#x02209;&#x00338;"/>
+  <entity name="notinvb" value="&#x022F7;"/>
+  <entity name="notinvc" value="&#x022F6;"/>
+  <entity name="NotLeftTriangle" value="&#x022EA;"/>
+  <entity name="NotLeftTriangleBar" value="&#x029CF;&#x00338;"/>
+  <entity name="NotLeftTriangleEqual" value="&#x022EC;"/>
+  <entity name="NotLess" value="&#x0226E;"/>
+  <entity name="NotLessEqual" value="&#x02270;&#x020E5;"/>
+  <entity name="NotLessGreater" value="&#x02278;"/>
+  <entity name="NotLessLess" value="&#x0226A;&#x00338;&#x0FE00;"/>
+  <entity name="NotLessSlantEqual" value="&#x02270;"/>
+  <entity name="NotLessTilde" value="&#x02274;"/>
+  <entity name="NotNestedGreaterGreater" value="&#x024A2;&#x00338;"/>
+  <entity name="NotNestedLessLess" value="&#x024A1;&#x00338;"/>
+  <entity name="notni" value="&#x0220C;"/>
+  <entity name="notniva" value="&#x0220C;"/>
+  <entity name="notnivb" value="&#x022FE;"/>
+  <entity name="notnivc" value="&#x022FD;"/>
+  <entity name="NotPrecedes" value="&#x02280;"/>
+  <entity name="NotPrecedesEqual" value="&#x02AAF;&#x00338;"/>
+  <entity name="NotPrecedesSlantEqual" value="&#x022E0;"/>
+  <entity name="NotReverseElement" value="&#x0220C;"/>
+  <entity name="NotRightTriangle" value="&#x022EB;"/>
+  <entity name="NotRightTriangleBar" value="&#x029D0;&#x00338;"/>
+  <entity name="NotRightTriangleEqual" value="&#x022ED;"/>
+  <entity name="NotSquareSubset" value="&#x0228F;&#x00338;"/>
+  <entity name="NotSquareSubsetEqual" value="&#x022E2;"/>
+  <entity name="NotSquareSuperset" value="&#x02290;&#x00338;"/>
+  <entity name="NotSquareSupersetEqual" value="&#x022E3;"/>
+  <entity name="NotSubset" value="&#x02284;"/>
+  <entity name="NotSubsetEqual" value="&#x02288;"/>
+  <entity name="NotSucceeds" value="&#x02281;"/>
+  <entity name="NotSucceedsEqual" value="&#x02AB0;&#x00338;"/>
+  <entity name="NotSucceedsSlantEqual" value="&#x022E1;"/>
+  <entity name="NotSucceedsTilde" value="&#x0227F;&#x00338;"/>
+  <entity name="NotSuperset" value="&#x02285;"/>
+  <entity name="NotSupersetEqual" value="&#x02289;"/>
+  <entity name="NotTilde" value="&#x02241;"/>
+  <entity name="NotTildeEqual" value="&#x02244;"/>
+  <entity name="NotTildeFullEqual" value="&#x02247;"/>
+  <entity name="NotTildeTilde" value="&#x02249;"/>
+  <entity name="NotVerticalBar" value="&#x02224;"/>
+  <entity name="npar" value="&#x02226;"/>
+  <entity name="nparallel" value="&#x02226;"/>
+  <entity name="nparsl" value="&#x02225;&#x0FE00;&#x020E5;"/>
+  <entity name="npart" value="&#x02202;&#x00338;"/>
+  <entity name="npolint" value="&#x02A14;"/>
+  <entity name="npr" value="&#x02280;"/>
+  <entity name="nprcue" value="&#x022E0;"/>
+  <entity name="npre" value="&#x02AAF;&#x00338;"/>
+  <entity name="nprec" value="&#x02280;"/>
+  <entity name="npreceq" value="&#x02AAF;&#x00338;"/>
+  <entity name="nrarr" value="&#x0219B;"/>
+  <entity name="nrArr" value="&#x021CF;"/>
+  <entity name="nrarrc" value="&#x02933;&#x00338;"/>
+  <entity name="nrarrw" value="&#x0219D;&#x00338;"/>
+  <entity name="nrightarrow" value="&#x0219B;"/>
+  <entity name="nRightarrow" value="&#x021CF;"/>
+  <entity name="nrtri" value="&#x022EB;"/>
+  <entity name="nrtrie" value="&#x022ED;"/>
+  <entity name="nsc" value="&#x02281;"/>
+  <entity name="nsccue" value="&#x022E1;"/>
+  <entity name="nsce" value="&#x02AB0;&#x00338;"/>
+  <entity name="nscr" value="&#x1D4C3;"/>
+  <entity name="Nscr" value="&#x1D4A9;"/>
+  <entity name="nshortmid" value="&#x02224;&#x0FE00;"/>
+  <entity name="nshortparallel" value="&#x02226;&#x0FE00;"/>
+  <entity name="nsim" value="&#x02241;"/>
+  <entity name="nsime" value="&#x02244;"/>
+  <entity name="nsimeq" value="&#x02244;"/>
+  <entity name="nsmid" value="&#x02224;&#x0FE00;"/>
+  <entity name="nspar" value="&#x02226;&#x0FE00;"/>
+  <entity name="nsqsube" value="&#x022E2;"/>
+  <entity name="nsqsupe" value="&#x022E3;"/>
+  <entity name="nsub" value="&#x02284;"/>
+  <entity name="nsube" value="&#x02288;"/>
+  <entity name="nsubE" value="&#x02288;"/>
+  <entity name="nsubset" value="&#x02284;"/>
+  <entity name="nsubseteq" value="&#x02288;"/>
+  <entity name="nsubseteqq" value="&#x02288;"/>
+  <entity name="nsucc" value="&#x02281;"/>
+  <entity name="nsucceq" value="&#x02AB0;&#x00338;"/>
+  <entity name="nsup" value="&#x02285;"/>
+  <entity name="nsupe" value="&#x02289;"/>
+  <entity name="nsupE" value="&#x02289;"/>
+  <entity name="nsupset" value="&#x02285;"/>
+  <entity name="nsupseteq" value="&#x02289;"/>
+  <entity name="nsupseteqq" value="&#x02289;"/>
+  <entity name="ntgl" value="&#x02279;"/>
+  <entity name="ntilde" value="&#x000F1;"/>
+  <entity name="Ntilde" value="&#x000D1;"/>
+  <entity name="ntlg" value="&#x02278;"/>
+  <entity name="ntriangleleft" value="&#x022EA;"/>
+  <entity name="ntrianglelefteq" value="&#x022EC;"/>
+  <entity name="ntriangleright" value="&#x022EB;"/>
+  <entity name="ntrianglerighteq" value="&#x022ED;"/>
+  <entity name="nu" value="&#x003BD;"/>
+  <entity name="num" value="&#x00023;"/>
+  <entity name="numero" value="&#x02116;"/>
+  <entity name="numsp" value="&#x02007;"/>
+  <entity name="nvap" value="&#x02249;&#x00338;"/>
+  <entity name="nvdash" value="&#x022AC;"/>
+  <entity name="nvDash" value="&#x022AD;"/>
+  <entity name="nVdash" value="&#x022AE;"/>
+  <entity name="nVDash" value="&#x022AF;"/>
+  <entity name="nvge" value="&#x02271;"/>
+  <entity name="nvgt" value="&#x0226F;"/>
+  <entity name="nvHarr" value="&#x021CE;"/>
+  <entity name="nvinfin" value="&#x029DE;"/>
+  <entity name="nvlArr" value="&#x021CD;"/>
+  <entity name="nvle" value="&#x02270;"/>
+  <entity name="nvlt" value="&#x0226E;"/>
+  <entity name="nvltrie" value="&#x022EC;&#x00338;"/>
+  <entity name="nvrArr" value="&#x021CF;"/>
+  <entity name="nvrtrie" value="&#x022ED;&#x00338;"/>
+  <entity name="nvsim" value="&#x02241;&#x00338;"/>
+  <entity name="nwarhk" value="&#x02923;"/>
+  <entity name="nwarr" value="&#x02196;"/>
+  <entity name="nwArr" value="&#x021D6;"/>
+  <entity name="nwarrow" value="&#x02196;"/>
+  <entity name="nwnear" value="&#x02927;"/>
+  <entity name="oacute" value="&#x000F3;"/>
+  <entity name="Oacute" value="&#x000D3;"/>
+  <entity name="oast" value="&#x0229B;"/>
+  <entity name="ocir" value="&#x0229A;"/>
+  <entity name="ocirc" value="&#x000F4;"/>
+  <entity name="Ocirc" value="&#x000D4;"/>
+  <entity name="ocy" value="&#x0043E;"/>
+  <entity name="Ocy" value="&#x0041E;"/>
+  <entity name="odash" value="&#x0229D;"/>
+  <entity name="odblac" value="&#x00151;"/>
+  <entity name="Odblac" value="&#x00150;"/>
+  <entity name="odiv" value="&#x02A38;"/>
+  <entity name="odot" value="&#x02299;"/>
+  <entity name="odsold" value="&#x029BC;"/>
+  <entity name="oelig" value="&#x00153;"/>
+  <entity name="OElig" value="&#x00152;"/>
+  <entity name="ofcir" value="&#x029BF;"/>
+  <entity name="ofr" value="&#x1D52C;"/>
+  <entity name="Ofr" value="&#x1D512;"/>
+  <entity name="ogon" value="&#x002DB;"/>
+  <entity name="ograve" value="&#x000F2;"/>
+  <entity name="Ograve" value="&#x000D2;"/>
+  <entity name="ogt" value="&#x029C1;"/>
+  <entity name="ohbar" value="&#x029B5;"/>
+  <entity name="ohm" value="&#x02126;"/>
+  <entity name="oint" value="&#x0222E;"/>
+  <entity name="olarr" value="&#x021BA;"/>
+  <entity name="olcir" value="&#x029BE;"/>
+  <entity name="olcross" value="&#x029BB;"/>
+  <entity name="olt" value="&#x029C0;"/>
+  <entity name="omacr" value="&#x0014D;"/>
+  <entity name="Omacr" value="&#x0014C;"/>
+  <entity name="omega" value="&#x003C9;"/>
+  <entity name="Omega" value="&#x003A9;"/>
+  <entity name="omid" value="&#x029B6;"/>
+  <entity name="ominus" value="&#x02296;"/>
+  <entity name="oopf" value="&#x1D560;"/>
+  <entity name="Oopf" value="&#x1D546;"/>
+  <entity name="opar" value="&#x029B7;"/>
+  <entity name="OpenCurlyDoubleQuote" value="&#x0201C;"/>
+  <entity name="OpenCurlyQuote" value="&#x02018;"/>
+  <entity name="operp" value="&#x029B9;"/>
+  <entity name="oplus" value="&#x02295;"/>
+  <entity name="or" value="&#x02228;"/>
+  <entity name="Or" value="&#x02A54;"/>
+  <entity name="orarr" value="&#x021BB;"/>
+  <entity name="ord" value="&#x02A5D;"/>
+  <entity name="order" value="&#x02134;"/>
+  <entity name="orderof" value="&#x02134;"/>
+  <entity name="ordf" value="&#x000AA;"/>
+  <entity name="ordm" value="&#x000BA;"/>
+  <entity name="origof" value="&#x022B6;"/>
+  <entity name="oror" value="&#x02A56;"/>
+  <entity name="orslope" value="&#x02A57;"/>
+  <entity name="orv" value="&#x02A5B;"/>
+  <entity name="oS" value="&#x024C8;"/>
+  <entity name="oscr" value="&#x02134;"/>
+  <entity name="Oscr" value="&#x1D4AA;"/>
+  <entity name="oslash" value="&#x000F8;"/>
+  <entity name="Oslash" value="&#x000D8;"/>
+  <entity name="osol" value="&#x02298;"/>
+  <entity name="otilde" value="&#x000F5;"/>
+  <entity name="Otilde" value="&#x000D5;"/>
+  <entity name="otimes" value="&#x02297;"/>
+  <entity name="Otimes" value="&#x02A37;"/>
+  <entity name="otimesas" value="&#x02A36;"/>
+  <entity name="ouml" value="&#x000F6;"/>
+  <entity name="Ouml" value="&#x000D6;"/>
+  <entity name="ovbar" value="&#x0233D;"/>
+  <entity name="OverBar" value="&#x000AF;"/>
+  <entity name="OverBrace" value="&#x0FE37;"/>
+  <entity name="OverBracket" value="&#x023B4;"/>
+  <entity name="OverParenthesis" value="&#x0FE35;"/>
+  <entity name="par" value="&#x02225;"/>
+  <entity name="para" value="&#x000B6;"/>
+  <entity name="parallel" value="&#x02225;"/>
+  <entity name="parsim" value="&#x02AF3;"/>
+  <entity name="parsl" value="&#x02225;&#x0FE00;"/>
+  <entity name="part" value="&#x02202;"/>
+  <entity name="PartialD" value="&#x02202;"/>
+  <entity name="pcy" value="&#x0043F;"/>
+  <entity name="Pcy" value="&#x0041F;"/>
+  <entity name="percnt" value="&#x00025;"/>
+  <entity name="period" value="&#x0002E;"/>
+  <entity name="permil" value="&#x02030;"/>
+  <entity name="perp" value="&#x022A5;"/>
+  <entity name="pertenk" value="&#x02031;"/>
+  <entity name="pfr" value="&#x1D52D;"/>
+  <entity name="Pfr" value="&#x1D513;"/>
+  <entity name="phi" value="&#x003C6;"/>
+  <entity name="Phi" value="&#x003A6;"/>
+  <entity name="phiv" value="&#x003D5;"/>
+  <entity name="phmmat" value="&#x02133;"/>
+  <entity name="phone" value="&#x0260E;"/>
+  <entity name="pi" value="&#x003C0;"/>
+  <entity name="Pi" value="&#x003A0;"/>
+  <entity name="pitchfork" value="&#x022D4;"/>
+  <entity name="piv" value="&#x003D6;"/>
+  <entity name="planck" value="&#x0210F;&#x0FE00;"/>
+  <entity name="planckh" value="&#x0210E;"/>
+  <entity name="plankv" value="&#x0210F;"/>
+  <entity name="plus" value="&#x0002B;"/>
+  <entity name="plusacir" value="&#x02A23;"/>
+  <entity name="plusb" value="&#x0229E;"/>
+  <entity name="pluscir" value="&#x02A22;"/>
+  <entity name="plusdo" value="&#x02214;"/>
+  <entity name="plusdu" value="&#x02A25;"/>
+  <entity name="pluse" value="&#x02A72;"/>
+  <entity name="PlusMinus" value="&#x000B1;"/>
+  <entity name="plusmn" value="&#x000B1;"/>
+  <entity name="plussim" value="&#x02A26;"/>
+  <entity name="plustwo" value="&#x02A27;"/>
+  <entity name="pm" value="&#x000B1;"/>
+  <entity name="Poincareplane" value="&#x0210C;"/>
+  <entity name="pointint" value="&#x02A15;"/>
+  <entity name="popf" value="&#x1D561;"/>
+  <entity name="Popf" value="&#x02119;"/>
+  <entity name="pound" value="&#x000A3;"/>
+  <entity name="pr" value="&#x0227A;"/>
+  <entity name="Pr" value="&#x02ABB;"/>
+  <entity name="prap" value="&#x0227E;"/>
+  <entity name="prcue" value="&#x0227C;"/>
+  <entity name="pre" value="&#x02AAF;"/>
+  <entity name="prE" value="&#x02AAF;"/>
+  <entity name="prec" value="&#x0227A;"/>
+  <entity name="precapprox" value="&#x0227E;"/>
+  <entity name="preccurlyeq" value="&#x0227C;"/>
+  <entity name="Precedes" value="&#x0227A;"/>
+  <entity name="PrecedesEqual" value="&#x02AAF;"/>
+  <entity name="PrecedesSlantEqual" value="&#x0227C;"/>
+  <entity name="PrecedesTilde" value="&#x0227E;"/>
+  <entity name="preceq" value="&#x02AAF;"/>
+  <entity name="precnapprox" value="&#x022E8;"/>
+  <entity name="precneqq" value="&#x02AB5;"/>
+  <entity name="precnsim" value="&#x022E8;"/>
+  <entity name="precsim" value="&#x0227E;"/>
+  <entity name="prime" value="&#x02032;"/>
+  <entity name="Prime" value="&#x02033;"/>
+  <entity name="primes" value="&#x02119;"/>
+  <entity name="prnap" value="&#x022E8;"/>
+  <entity name="prnE" value="&#x02AB5;"/>
+  <entity name="prnsim" value="&#x022E8;"/>
+  <entity name="prod" value="&#x0220F;"/>
+  <entity name="Product" value="&#x0220F;"/>
+  <entity name="profalar" value="&#x0232E;"/>
+  <entity name="profline" value="&#x02312;"/>
+  <entity name="profsurf" value="&#x02313;"/>
+  <entity name="prop" value="&#x0221D;"/>
+  <entity name="Proportion" value="&#x02237;"/>
+  <entity name="Proportional" value="&#x0221D;"/>
+  <entity name="propto" value="&#x0221D;"/>
+  <entity name="prsim" value="&#x0227E;"/>
+  <entity name="prurel" value="&#x022B0;"/>
+  <entity name="pscr" value="&#x1D4C5;"/>
+  <entity name="Pscr" value="&#x1D4AB;"/>
+  <entity name="psi" value="&#x003C8;"/>
+  <entity name="Psi" value="&#x003A8;"/>
+  <entity name="puncsp" value="&#x02008;"/>
+  <entity name="qfr" value="&#x1D52E;"/>
+  <entity name="Qfr" value="&#x1D514;"/>
+  <entity name="qint" value="&#x02A0C;"/>
+  <entity name="qopf" value="&#x1D562;"/>
+  <entity name="Qopf" value="&#x0211A;"/>
+  <entity name="qprime" value="&#x02057;"/>
+  <entity name="qscr" value="&#x1D4C6;"/>
+  <entity name="Qscr" value="&#x1D4AC;"/>
+  <entity name="quaternions" value="&#x0210D;"/>
+  <entity name="quatint" value="&#x02A16;"/>
+  <entity name="quest" value="&#x0003F;"/>
+  <entity name="questeq" value="&#x0225F;"/>
+  <entity name="quot" value="&#x00022;"/>
+  <entity name="rAarr" value="&#x021DB;"/>
+  <entity name="race" value="&#x029DA;"/>
+  <entity name="racute" value="&#x00155;"/>
+  <entity name="Racute" value="&#x00154;"/>
+  <entity name="radic" value="&#x0221A;"/>
+  <entity name="raemptyv" value="&#x029B3;"/>
+  <entity name="rang" value="&#x0232A;"/>
+  <entity name="Rang" value="&#x0300B;"/>
+  <entity name="rangd" value="&#x02992;"/>
+  <entity name="range" value="&#x029A5;"/>
+  <entity name="rangle" value="&#x0232A;"/>
+  <entity name="raquo" value="&#x000BB;"/>
+  <entity name="rarr" value="&#x02192;"/>
+  <entity name="rArr" value="&#x021D2;"/>
+  <entity name="Rarr" value="&#x021A0;"/>
+  <entity name="rarrap" value="&#x02975;"/>
+  <entity name="rarrb" value="&#x021E5;"/>
+  <entity name="rarrbfs" value="&#x02920;"/>
+  <entity name="rarrc" value="&#x02933;"/>
+  <entity name="rarrfs" value="&#x0291E;"/>
+  <entity name="rarrhk" value="&#x021AA;"/>
+  <entity name="rarrlp" value="&#x021AC;"/>
+  <entity name="rarrpl" value="&#x02945;"/>
+  <entity name="rarrsim" value="&#x02974;"/>
+  <entity name="rarrtl" value="&#x021A3;"/>
+  <entity name="Rarrtl" value="&#x02916;"/>
+  <entity name="rarrw" value="&#x0219D;"/>
+  <entity name="ratail" value="&#x021A3;"/>
+  <entity name="rAtail" value="&#x0291C;"/>
+  <entity name="ratio" value="&#x02236;"/>
+  <entity name="rationals" value="&#x0211A;"/>
+  <entity name="rbarr" value="&#x0290D;"/>
+  <entity name="rBarr" value="&#x0290F;"/>
+  <entity name="RBarr" value="&#x02910;"/>
+  <entity name="rbbrk" value="&#x03015;"/>
+  <entity name="rbrace" value="&#x0007D;"/>
+  <entity name="rbrack" value="&#x0005D;"/>
+  <entity name="rbrke" value="&#x0298C;"/>
+  <entity name="rbrksld" value="&#x0298E;"/>
+  <entity name="rbrkslu" value="&#x02990;"/>
+  <entity name="rcaron" value="&#x00159;"/>
+  <entity name="Rcaron" value="&#x00158;"/>
+  <entity name="rcedil" value="&#x00157;"/>
+  <entity name="Rcedil" value="&#x00156;"/>
+  <entity name="rceil" value="&#x02309;"/>
+  <entity name="rcub" value="&#x0007D;"/>
+  <entity name="rcy" value="&#x00440;"/>
+  <entity name="Rcy" value="&#x00420;"/>
+  <entity name="rdca" value="&#x02937;"/>
+  <entity name="rdldhar" value="&#x02969;"/>
+  <entity name="rdquo" value="&#x0201D;"/>
+  <entity name="rdquor" value="&#x0201D;"/>
+  <entity name="rdsh" value="&#x021B3;"/>
+  <entity name="Re" value="&#x0211C;"/>
+  <entity name="real" value="&#x0211C;"/>
+  <entity name="realine" value="&#x0211B;"/>
+  <entity name="realpart" value="&#x0211C;"/>
+  <entity name="reals" value="&#x0211D;"/>
+  <entity name="rect" value="&#x025AD;"/>
+  <entity name="reg" value="&#x000AE;"/>
+  <entity name="ReverseElement" value="&#x0220B;"/>
+  <entity name="ReverseEquilibrium" value="&#x021CB;"/>
+  <entity name="ReverseUpEquilibrium" value="&#x0296F;"/>
+  <entity name="rfisht" value="&#x0297D;"/>
+  <entity name="rfloor" value="&#x0230B;"/>
+  <entity name="rfr" value="&#x1D52F;"/>
+  <entity name="Rfr" value="&#x0211C;"/>
+  <entity name="rHar" value="&#x02964;"/>
+  <entity name="rhard" value="&#x021C1;"/>
+  <entity name="rharu" value="&#x021C0;"/>
+  <entity name="rharul" value="&#x0296C;"/>
+  <entity name="rho" value="&#x003C1;"/>
+  <entity name="rhov" value="&#x003F1;"/>
+  <entity name="RightAngleBracket" value="&#x0232A;"/>
+  <entity name="rightarrow" value="&#x02192;"/>
+  <entity name="Rightarrow" value="&#x021D2;"/>
+  <entity name="RightArrow" value="&#x02192;"/>
+  <entity name="RightArrowBar" value="&#x021E5;"/>
+  <entity name="RightArrowLeftArrow" value="&#x021C4;"/>
+  <entity name="rightarrowtail" value="&#x021A3;"/>
+  <entity name="RightCeiling" value="&#x02309;"/>
+  <entity name="RightDoubleBracket" value="&#x0301B;"/>
+  <entity name="RightDownTeeVector" value="&#x0295D;"/>
+  <entity name="RightDownVector" value="&#x021C2;"/>
+  <entity name="RightDownVectorBar" value="&#x02955;"/>
+  <entity name="RightFloor" value="&#x0230B;"/>
+  <entity name="rightharpoondown" value="&#x021C1;"/>
+  <entity name="rightharpoonup" value="&#x021C0;"/>
+  <entity name="rightleftarrows" value="&#x021C4;"/>
+  <entity name="rightleftharpoons" value="&#x021CC;"/>
+  <entity name="rightrightarrows" value="&#x021C9;"/>
+  <entity name="rightsquigarrow" value="&#x0219D;"/>
+  <entity name="RightTee" value="&#x022A2;"/>
+  <entity name="RightTeeArrow" value="&#x021A6;"/>
+  <entity name="RightTeeVector" value="&#x0295B;"/>
+  <entity name="rightthreetimes" value="&#x022CC;"/>
+  <entity name="RightTriangle" value="&#x022B3;"/>
+  <entity name="RightTriangleBar" value="&#x029D0;"/>
+  <entity name="RightTriangleEqual" value="&#x022B5;"/>
+  <entity name="RightUpDownVector" value="&#x0294F;"/>
+  <entity name="RightUpTeeVector" value="&#x0295C;"/>
+  <entity name="RightUpVector" value="&#x021BE;"/>
+  <entity name="RightUpVectorBar" value="&#x02954;"/>
+  <entity name="RightVector" value="&#x021C0;"/>
+  <entity name="RightVectorBar" value="&#x02953;"/>
+  <entity name="ring" value="&#x002DA;"/>
+  <entity name="risingdotseq" value="&#x02253;"/>
+  <entity name="rlarr" value="&#x021C4;"/>
+  <entity name="rlhar" value="&#x021CC;"/>
+  <entity name="rmoust" value="&#x023B1;"/>
+  <entity name="rmoustache" value="&#x023B1;"/>
+  <entity name="rnmid" value="&#x02AEE;"/>
+  <entity name="roang" value="&#x0F559;"/>
+  <entity name="roarr" value="&#x021FE;"/>
+  <entity name="robrk" value="&#x0301B;"/>
+  <entity name="ropar" value="&#x03019;"/>
+  <entity name="ropf" value="&#x1D563;"/>
+  <entity name="Ropf" value="&#x0211D;"/>
+  <entity name="roplus" value="&#x02A2E;"/>
+  <entity name="rotimes" value="&#x02A35;"/>
+  <entity name="RoundImplies" value="&#x02970;"/>
+  <entity name="rpar" value="&#x00029;"/>
+  <entity name="rpargt" value="&#x02994;"/>
+  <entity name="rppolint" value="&#x02A12;"/>
+  <entity name="rrarr" value="&#x021C9;"/>
+  <entity name="Rrightarrow" value="&#x021DB;"/>
+  <entity name="rscr" value="&#x1D4C7;"/>
+  <entity name="Rscr" value="&#x0211B;"/>
+  <entity name="rsh" value="&#x021B1;"/>
+  <entity name="Rsh" value="&#x021B1;"/>
+  <entity name="rsqb" value="&#x0005D;"/>
+  <entity name="rsquo" value="&#x02019;"/>
+  <entity name="rsquor" value="&#x02019;"/>
+  <entity name="rthree" value="&#x022CC;"/>
+  <entity name="rtimes" value="&#x022CA;"/>
+  <entity name="rtri" value="&#x025B9;"/>
+  <entity name="rtrie" value="&#x022B5;"/>
+  <entity name="rtrif" value="&#x025B8;"/>
+  <entity name="rtriltri" value="&#x029CE;"/>
+  <entity name="RuleDelayed" value="&#x029F4;"/>
+  <entity name="ruluhar" value="&#x02968;"/>
+  <entity name="rx" value="&#x0211E;"/>
+  <entity name="sacute" value="&#x0015B;"/>
+  <entity name="Sacute" value="&#x0015A;"/>
+  <entity name="sc" value="&#x0227B;"/>
+  <entity name="Sc" value="&#x02ABC;"/>
+  <entity name="scap" value="&#x0227F;"/>
+  <entity name="scaron" value="&#x00161;"/>
+  <entity name="Scaron" value="&#x00160;"/>
+  <entity name="sccue" value="&#x0227D;"/>
+  <entity name="sce" value="&#x0227D;"/>
+  <entity name="scE" value="&#x0227E;"/>
+  <entity name="scedil" value="&#x0015F;"/>
+  <entity name="Scedil" value="&#x0015E;"/>
+  <entity name="scirc" value="&#x0015D;"/>
+  <entity name="Scirc" value="&#x0015C;"/>
+  <entity name="scnap" value="&#x022E9;"/>
+  <entity name="scnE" value="&#x02AB6;"/>
+  <entity name="scnsim" value="&#x022E9;"/>
+  <entity name="scpolint" value="&#x02A13;"/>
+  <entity name="scsim" value="&#x0227F;"/>
+  <entity name="scy" value="&#x00441;"/>
+  <entity name="Scy" value="&#x00421;"/>
+  <entity name="sdot" value="&#x022C5;"/>
+  <entity name="sdotb" value="&#x022A1;"/>
+  <entity name="sdote" value="&#x02A66;"/>
+  <entity name="searhk" value="&#x02925;"/>
+  <entity name="searr" value="&#x02198;"/>
+  <entity name="seArr" value="&#x021D8;"/>
+  <entity name="searrow" value="&#x02198;"/>
+  <entity name="sect" value="&#x000A7;"/>
+  <entity name="semi" value="&#x0003B;"/>
+  <entity name="seswar" value="&#x02929;"/>
+  <entity name="setminus" value="&#x02216;"/>
+  <entity name="setmn" value="&#x02216;"/>
+  <entity name="sext" value="&#x02736;"/>
+  <entity name="sfr" value="&#x1D530;"/>
+  <entity name="Sfr" value="&#x1D516;"/>
+  <entity name="sharp" value="&#x0266F;"/>
+  <entity name="shchcy" value="&#x00449;"/>
+  <entity name="SHCHcy" value="&#x00429;"/>
+  <entity name="shcy" value="&#x00448;"/>
+  <entity name="SHcy" value="&#x00428;"/>
+  <entity name="ShortDownArrow" value="&#x02304;&#x0FE00;"/>
+  <entity name="ShortLeftArrow" value="&#x02190;&#x0FE00;"/>
+  <entity name="shortmid" value="&#x02223;&#x0FE00;"/>
+  <entity name="shortparallel" value="&#x02225;&#x0FE00;"/>
+  <entity name="ShortRightArrow" value="&#x02192;&#x0FE00;"/>
+  <entity name="ShortUpArrow" value="&#x02303;&#x0FE00;"/>
+  <entity name="shy" value="&#x000AD;"/>
+  <entity name="sigma" value="&#x003C3;"/>
+  <entity name="Sigma" value="&#x003A3;"/>
+  <entity name="sigmav" value="&#x003C2;"/>
+  <entity name="sim" value="&#x0223C;"/>
+  <entity name="simdot" value="&#x02A6A;"/>
+  <entity name="sime" value="&#x02243;"/>
+  <entity name="simeq" value="&#x02243;"/>
+  <entity name="simg" value="&#x02A9E;"/>
+  <entity name="simgE" value="&#x02AA0;"/>
+  <entity name="siml" value="&#x02A9D;"/>
+  <entity name="simlE" value="&#x02A9F;"/>
+  <entity name="simne" value="&#x02246;"/>
+  <entity name="simplus" value="&#x02A24;"/>
+  <entity name="simrarr" value="&#x02972;"/>
+  <entity name="slarr" value="&#x02190;&#x0FE00;"/>
+  <entity name="SmallCircle" value="&#x02218;"/>
+  <entity name="smallsetminus" value="&#x02216;&#x0FE00;"/>
+  <entity name="smashp" value="&#x02A33;"/>
+  <entity name="smeparsl" value="&#x029E4;"/>
+  <entity name="smid" value="&#x02223;&#x0FE00;"/>
+  <entity name="smile" value="&#x02323;"/>
+  <entity name="smt" value="&#x02AAA;"/>
+  <entity name="smte" value="&#x02AAC;"/>
+  <entity name="smtes" value="&#x02AAC;&#x0FE00;"/>
+  <entity name="softcy" value="&#x0044C;"/>
+  <entity name="SOFTcy" value="&#x0042C;"/>
+  <entity name="sol" value="&#x0002F;"/>
+  <entity name="solb" value="&#x029C4;"/>
+  <entity name="solbar" value="&#x0233F;"/>
+  <entity name="sopf" value="&#x1D564;"/>
+  <entity name="Sopf" value="&#x1D54A;"/>
+  <entity name="spades" value="&#x02660;"/>
+  <entity name="spadesuit" value="&#x02660;"/>
+  <entity name="spar" value="&#x02225;&#x0FE00;"/>
+  <entity name="sqcap" value="&#x02293;"/>
+  <entity name="sqcaps" value="&#x02293;&#x0FE00;"/>
+  <entity name="sqcup" value="&#x02294;"/>
+  <entity name="sqcups" value="&#x02294;&#x0FE00;"/>
+  <entity name="Sqrt" value="&#x0221A;"/>
+  <entity name="sqsub" value="&#x0228F;"/>
+  <entity name="sqsube" value="&#x02291;"/>
+  <entity name="sqsubset" value="&#x0228F;"/>
+  <entity name="sqsubseteq" value="&#x02291;"/>
+  <entity name="sqsup" value="&#x02290;"/>
+  <entity name="sqsupe" value="&#x02292;"/>
+  <entity name="sqsupset" value="&#x02290;"/>
+  <entity name="sqsupseteq" value="&#x02292;"/>
+  <entity name="squ" value="&#x025A1;"/>
+  <entity name="square" value="&#x025A1;"/>
+  <entity name="Square" value="&#x025A1;"/>
+  <entity name="SquareIntersection" value="&#x02293;"/>
+  <entity name="SquareSubset" value="&#x0228F;"/>
+  <entity name="SquareSubsetEqual" value="&#x02291;"/>
+  <entity name="SquareSuperset" value="&#x02290;"/>
+  <entity name="SquareSupersetEqual" value="&#x02292;"/>
+  <entity name="SquareUnion" value="&#x02294;"/>
+  <entity name="squarf" value="&#x025AA;"/>
+  <entity name="squf" value="&#x025AA;"/>
+  <entity name="srarr" value="&#x02192;&#x0FE00;"/>
+  <entity name="sscr" value="&#x1D4C8;"/>
+  <entity name="Sscr" value="&#x1D4AE;"/>
+  <entity name="ssetmn" value="&#x02216;&#x0FE00;"/>
+  <entity name="sstarf" value="&#x022C6;"/>
+  <entity name="star" value="&#x022C6;"/>
+  <entity name="Star" value="&#x022C6;"/>
+  <entity name="starf" value="&#x02605;"/>
+  <entity name="straightepsilon" value="&#x003B5;"/>
+  <entity name="straightphi" value="&#x003C6;"/>
+  <entity name="Sub" value="&#x022D0;"/>
+  <entity name="subdot" value="&#x02ABD;"/>
+  <entity name="sube" value="&#x02286;"/>
+  <entity name="subE" value="&#x02286;"/>
+  <entity name="subedot" value="&#x02AC3;"/>
+  <entity name="submult" value="&#x02AC1;"/>
+  <entity name="subne" value="&#x0228A;"/>
+  <entity name="subnE" value="&#x0228A;"/>
+  <entity name="subplus" value="&#x02ABF;"/>
+  <entity name="subrarr" value="&#x02979;"/>
+  <entity name="subset" value="&#x02282;"/>
+  <entity name="Subset" value="&#x022D0;"/>
+  <entity name="subseteq" value="&#x02286;"/>
+  <entity name="subseteqq" value="&#x02286;"/>
+  <entity name="SubsetEqual" value="&#x02286;"/>
+  <entity name="subsetneq" value="&#x0228A;"/>
+  <entity name="subsetneqq" value="&#x0228A;"/>
+  <entity name="subsim" value="&#x02AC7;"/>
+  <entity name="subsub" value="&#x02AD5;"/>
+  <entity name="subsup" value="&#x02AD3;"/>
+  <entity name="succ" value="&#x0227B;"/>
+  <entity name="succapprox" value="&#x0227F;"/>
+  <entity name="succcurlyeq" value="&#x0227D;"/>
+  <entity name="Succeeds" value="&#x0227B;"/>
+  <entity name="SucceedsEqual" value="&#x0227D;"/>
+  <entity name="SucceedsSlantEqual" value="&#x0227D;"/>
+  <entity name="SucceedsTilde" value="&#x0227F;"/>
+  <entity name="succeq" value="&#x0227D;"/>
+  <entity name="succnapprox" value="&#x022E9;"/>
+  <entity name="succneqq" value="&#x02AB6;"/>
+  <entity name="succnsim" value="&#x022E9;"/>
+  <entity name="succsim" value="&#x0227F;"/>
+  <entity name="SuchThat" value="&#x0220B;"/>
+  <entity name="sum" value="&#x02211;"/>
+  <entity name="Sum" value="&#x02211;"/>
+  <entity name="sung" value="&#x0266A;"/>
+  <entity name="Sup" value="&#x022D1;"/>
+  <entity name="sup1" value="&#x000B9;"/>
+  <entity name="sup2" value="&#x000B2;"/>
+  <entity name="sup3" value="&#x000B3;"/>
+  <entity name="supdot" value="&#x02ABE;"/>
+  <entity name="supdsub" value="&#x02AD8;"/>
+  <entity name="supe" value="&#x02287;"/>
+  <entity name="supE" value="&#x02287;"/>
+  <entity name="supedot" value="&#x02AC4;"/>
+  <entity name="Superset" value="&#x02283;"/>
+  <entity name="SupersetEqual" value="&#x02287;"/>
+  <entity name="suphsol" value="&#x02283;&#x0002F;"/>
+  <entity name="suphsub" value="&#x02AD7;"/>
+  <entity name="suplarr" value="&#x0297B;"/>
+  <entity name="supmult" value="&#x02AC2;"/>
+  <entity name="supne" value="&#x0228B;"/>
+  <entity name="supnE" value="&#x0228B;"/>
+  <entity name="supplus" value="&#x02AC0;"/>
+  <entity name="supset" value="&#x02283;"/>
+  <entity name="Supset" value="&#x022D1;"/>
+  <entity name="supseteq" value="&#x02287;"/>
+  <entity name="supseteqq" value="&#x02287;"/>
+  <entity name="supsetneq" value="&#x0228B;"/>
+  <entity name="supsetneqq" value="&#x0228B;"/>
+  <entity name="supsim" value="&#x02AC8;"/>
+  <entity name="supsub" value="&#x02AD4;"/>
+  <entity name="supsup" value="&#x02AD6;"/>
+  <entity name="swarhk" value="&#x02926;"/>
+  <entity name="swarr" value="&#x02199;"/>
+  <entity name="swArr" value="&#x021D9;"/>
+  <entity name="swarrow" value="&#x02199;"/>
+  <entity name="swnwar" value="&#x0292A;"/>
+  <entity name="szlig" value="&#x000DF;"/>
+  <entity name="Tab" value="&#x00009;"/>
+  <entity name="target" value="&#x02316;"/>
+  <entity name="tau" value="&#x003C4;"/>
+  <entity name="tbrk" value="&#x023B4;"/>
+  <entity name="tcaron" value="&#x00165;"/>
+  <entity name="Tcaron" value="&#x00164;"/>
+  <entity name="tcedil" value="&#x00163;"/>
+  <entity name="Tcedil" value="&#x00162;"/>
+  <entity name="tcy" value="&#x00442;"/>
+  <entity name="Tcy" value="&#x00422;"/>
+  <entity name="tdot" value="&#x020DB;"/>
+  <entity name="telrec" value="&#x02315;"/>
+  <entity name="tfr" value="&#x1D531;"/>
+  <entity name="Tfr" value="&#x1D517;"/>
+  <entity name="there4" value="&#x02234;"/>
+  <entity name="therefore" value="&#x02234;"/>
+  <entity name="Therefore" value="&#x02234;"/>
+  <entity name="theta" value="&#x003B8;"/>
+  <entity name="Theta" value="&#x00398;"/>
+  <entity name="thetav" value="&#x003D1;"/>
+  <entity name="thickapprox" value="&#x02248;&#x0FE00;"/>
+  <entity name="thicksim" value="&#x0223C;&#x0FE00;"/>
+  <entity name="ThickSpace" value="&#x02009;&#x0200A;&#x0200A;"/>
+  <entity name="thinsp" value="&#x02009;"/>
+  <entity name="ThinSpace" value="&#x02009;"/>
+  <entity name="thkap" value="&#x02248;&#x0FE00;"/>
+  <entity name="thksim" value="&#x0223C;&#x0FE00;"/>
+  <entity name="thorn" value="&#x000FE;"/>
+  <entity name="THORN" value="&#x000DE;"/>
+  <entity name="tilde" value="&#x002DC;"/>
+  <entity name="Tilde" value="&#x0223C;"/>
+  <entity name="TildeEqual" value="&#x02243;"/>
+  <entity name="TildeFullEqual" value="&#x02245;"/>
+  <entity name="TildeTilde" value="&#x02248;"/>
+  <entity name="times" value="&#x000D7;"/>
+  <entity name="timesb" value="&#x022A0;"/>
+  <entity name="timesbar" value="&#x02A31;"/>
+  <entity name="timesd" value="&#x02A30;"/>
+  <entity name="tint" value="&#x0222D;"/>
+  <entity name="toea" value="&#x02928;"/>
+  <entity name="top" value="&#x022A4;"/>
+  <entity name="topbot" value="&#x02336;"/>
+  <entity name="topcir" value="&#x02AF1;"/>
+  <entity name="topf" value="&#x1D565;"/>
+  <entity name="Topf" value="&#x1D54B;"/>
+  <entity name="topfork" value="&#x02ADA;"/>
+  <entity name="tosa" value="&#x02929;"/>
+  <entity name="tprime" value="&#x02034;"/>
+  <entity name="trade" value="&#x02122;"/>
+  <entity name="triangle" value="&#x025B5;"/>
+  <entity name="triangledown" value="&#x025BF;"/>
+  <entity name="triangleleft" value="&#x025C3;"/>
+  <entity name="trianglelefteq" value="&#x022B4;"/>
+  <entity name="triangleq" value="&#x0225C;"/>
+  <entity name="triangleright" value="&#x025B9;"/>
+  <entity name="trianglerighteq" value="&#x022B5;"/>
+  <entity name="tridot" value="&#x025EC;"/>
+  <entity name="trie" value="&#x0225C;"/>
+  <entity name="triminus" value="&#x02A3A;"/>
+  <entity name="TripleDot" value="&#x020DB;"/>
+  <entity name="triplus" value="&#x02A39;"/>
+  <entity name="trisb" value="&#x029CD;"/>
+  <entity name="tritime" value="&#x02A3B;"/>
+  <entity name="tscr" value="&#x1D4C9;"/>
+  <entity name="Tscr" value="&#x1D4AF;"/>
+  <entity name="tscy" value="&#x00446;"/>
+  <entity name="TScy" value="&#x00426;"/>
+  <entity name="tshcy" value="&#x0045B;"/>
+  <entity name="TSHcy" value="&#x0040B;"/>
+  <entity name="tstrok" value="&#x00167;"/>
+  <entity name="Tstrok" value="&#x00166;"/>
+  <entity name="twixt" value="&#x0226C;"/>
+  <entity name="twoheadleftarrow" value="&#x0219E;"/>
+  <entity name="twoheadrightarrow" value="&#x021A0;"/>
+  <entity name="uacute" value="&#x000FA;"/>
+  <entity name="Uacute" value="&#x000DA;"/>
+  <entity name="uarr" value="&#x02191;"/>
+  <entity name="uArr" value="&#x021D1;"/>
+  <entity name="Uarr" value="&#x0219F;"/>
+  <entity name="Uarrocir" value="&#x02949;"/>
+  <entity name="ubrcy" value="&#x0045E;"/>
+  <entity name="Ubrcy" value="&#x0040E;"/>
+  <entity name="ubreve" value="&#x0016D;"/>
+  <entity name="Ubreve" value="&#x0016C;"/>
+  <entity name="ucirc" value="&#x000FB;"/>
+  <entity name="Ucirc" value="&#x000DB;"/>
+  <entity name="ucy" value="&#x00443;"/>
+  <entity name="Ucy" value="&#x00423;"/>
+  <entity name="udarr" value="&#x021C5;"/>
+  <entity name="udblac" value="&#x00171;"/>
+  <entity name="Udblac" value="&#x00170;"/>
+  <entity name="udhar" value="&#x0296E;"/>
+  <entity name="ufisht" value="&#x0297E;"/>
+  <entity name="ufr" value="&#x1D532;"/>
+  <entity name="Ufr" value="&#x1D518;"/>
+  <entity name="ugrave" value="&#x000F9;"/>
+  <entity name="Ugrave" value="&#x000D9;"/>
+  <entity name="uHar" value="&#x02963;"/>
+  <entity name="uharl" value="&#x021BF;"/>
+  <entity name="uharr" value="&#x021BE;"/>
+  <entity name="uhblk" value="&#x02580;"/>
+  <entity name="ulcorn" value="&#x0231C;"/>
+  <entity name="ulcorner" value="&#x0231C;"/>
+  <entity name="ulcrop" value="&#x0230F;"/>
+  <entity name="ultri" value="&#x025F8;"/>
+  <entity name="umacr" value="&#x0016B;"/>
+  <entity name="Umacr" value="&#x0016A;"/>
+  <entity name="uml" value="&#x000A8;"/>
+  <entity name="UnderBar" value="&#x00332;"/>
+  <entity name="UnderBrace" value="&#x0FE38;"/>
+  <entity name="UnderBracket" value="&#x023B5;"/>
+  <entity name="UnderParenthesis" value="&#x0FE36;"/>
+  <entity name="Union" value="&#x022C3;"/>
+  <entity name="UnionPlus" value="&#x0228E;"/>
+  <entity name="uogon" value="&#x00173;"/>
+  <entity name="Uogon" value="&#x00172;"/>
+  <entity name="uopf" value="&#x1D566;"/>
+  <entity name="Uopf" value="&#x1D54C;"/>
+  <entity name="uparrow" value="&#x02191;"/>
+  <entity name="Uparrow" value="&#x021D1;"/>
+  <entity name="UpArrow" value="&#x02191;"/>
+  <entity name="UpArrowBar" value="&#x02912;"/>
+  <entity name="UpArrowDownArrow" value="&#x021C5;"/>
+  <entity name="updownarrow" value="&#x02195;"/>
+  <entity name="Updownarrow" value="&#x021D5;"/>
+  <entity name="UpDownArrow" value="&#x02195;"/>
+  <entity name="UpEquilibrium" value="&#x0296E;"/>
+  <entity name="upharpoonleft" value="&#x021BF;"/>
+  <entity name="upharpoonright" value="&#x021BE;"/>
+  <entity name="uplus" value="&#x0228E;"/>
+  <entity name="UpperLeftArrow" value="&#x02196;"/>
+  <entity name="UpperRightArrow" value="&#x02197;"/>
+  <entity name="upsi" value="&#x003C5;"/>
+  <entity name="Upsi" value="&#x003D2;"/>
+  <entity name="upsilon" value="&#x003C5;"/>
+  <entity name="Upsilon" value="&#x003D2;"/>
+  <entity name="UpTee" value="&#x022A5;"/>
+  <entity name="UpTeeArrow" value="&#x021A5;"/>
+  <entity name="upuparrows" value="&#x021C8;"/>
+  <entity name="urcorn" value="&#x0231D;"/>
+  <entity name="urcorner" value="&#x0231D;"/>
+  <entity name="urcrop" value="&#x0230E;"/>
+  <entity name="uring" value="&#x0016F;"/>
+  <entity name="Uring" value="&#x0016E;"/>
+  <entity name="urtri" value="&#x025F9;"/>
+  <entity name="uscr" value="&#x1D4CA;"/>
+  <entity name="Uscr" value="&#x1D4B0;"/>
+  <entity name="utdot" value="&#x022F0;"/>
+  <entity name="utilde" value="&#x00169;"/>
+  <entity name="Utilde" value="&#x00168;"/>
+  <entity name="utri" value="&#x025B5;"/>
+  <entity name="utrif" value="&#x025B4;"/>
+  <entity name="uuarr" value="&#x021C8;"/>
+  <entity name="uuml" value="&#x000FC;"/>
+  <entity name="Uuml" value="&#x000DC;"/>
+  <entity name="uwangle" value="&#x029A7;"/>
+  <entity name="vangrt" value="&#x022BE;"/>
+  <entity name="varepsilon" value="&#x0025B;"/>
+  <entity name="varkappa" value="&#x003F0;"/>
+  <entity name="varnothing" value="&#x02205;"/>
+  <entity name="varphi" value="&#x003D5;"/>
+  <entity name="varpi" value="&#x003D6;"/>
+  <entity name="varpropto" value="&#x0221D;"/>
+  <entity name="varr" value="&#x02195;"/>
+  <entity name="vArr" value="&#x021D5;"/>
+  <entity name="varrho" value="&#x003F1;"/>
+  <entity name="varsigma" value="&#x003C2;"/>
+  <entity name="varsubsetneq" value="&#x0228A;&#x0FE00;"/>
+  <entity name="varsubsetneqq" value="&#x0228A;&#x0FE00;"/>
+  <entity name="varsupsetneq" value="&#x0228B;&#x0FE00;"/>
+  <entity name="varsupsetneqq" value="&#x0228B;&#x0FE00;"/>
+  <entity name="vartheta" value="&#x003D1;"/>
+  <entity name="vartriangleleft" value="&#x022B2;"/>
+  <entity name="vartriangleright" value="&#x022B3;"/>
+  <entity name="vBar" value="&#x02AE8;"/>
+  <entity name="Vbar" value="&#x02AEB;"/>
+  <entity name="vBarv" value="&#x02AE9;"/>
+  <entity name="vcy" value="&#x00432;"/>
+  <entity name="Vcy" value="&#x00412;"/>
+  <entity name="vdash" value="&#x022A2;"/>
+  <entity name="vDash" value="&#x022A8;"/>
+  <entity name="Vdash" value="&#x022A9;"/>
+  <entity name="VDash" value="&#x022AB;"/>
+  <entity name="Vdashl" value="&#x02AE6;"/>
+  <entity name="vee" value="&#x02228;"/>
+  <entity name="Vee" value="&#x022C1;"/>
+  <entity name="veebar" value="&#x022BB;"/>
+  <entity name="veeeq" value="&#x0225A;"/>
+  <entity name="vellip" value="&#x022EE;"/>
+  <entity name="verbar" value="&#x0007C;"/>
+  <entity name="Verbar" value="&#x02016;"/>
+  <entity name="vert" value="&#x0007C;"/>
+  <entity name="Vert" value="&#x02016;"/>
+  <entity name="VerticalBar" value="&#x02223;"/>
+  <entity name="VerticalLine" value="&#x0007C;"/>
+  <entity name="VerticalSeparator" value="&#x02758;"/>
+  <entity name="VerticalTilde" value="&#x02240;"/>
+  <entity name="VeryThinSpace" value="&#x0200A;"/>
+  <entity name="vfr" value="&#x1D533;"/>
+  <entity name="Vfr" value="&#x1D519;"/>
+  <entity name="vltri" value="&#x022B2;"/>
+  <entity name="vnsub" value="&#x02284;"/>
+  <entity name="vnsup" value="&#x02285;"/>
+  <entity name="vopf" value="&#x1D567;"/>
+  <entity name="Vopf" value="&#x1D54D;"/>
+  <entity name="vprop" value="&#x0221D;"/>
+  <entity name="vrtri" value="&#x022B3;"/>
+  <entity name="vscr" value="&#x1D4CB;"/>
+  <entity name="Vscr" value="&#x1D4B1;"/>
+  <entity name="vsubne" value="&#x0228A;&#x0FE00;"/>
+  <entity name="vsubnE" value="&#x0228A;&#x0FE00;"/>
+  <entity name="vsupne" value="&#x0228B;&#x0FE00;"/>
+  <entity name="vsupnE" value="&#x0228B;&#x0FE00;"/>
+  <entity name="Vvdash" value="&#x022AA;"/>
+  <entity name="vzigzag" value="&#x0299A;"/>
+  <entity name="wcirc" value="&#x00175;"/>
+  <entity name="Wcirc" value="&#x00174;"/>
+  <entity name="wedbar" value="&#x02A5F;"/>
+  <entity name="wedge" value="&#x02227;"/>
+  <entity name="Wedge" value="&#x022C0;"/>
+  <entity name="wedgeq" value="&#x02259;"/>
+  <entity name="weierp" value="&#x02118;"/>
+  <entity name="wfr" value="&#x1D534;"/>
+  <entity name="Wfr" value="&#x1D51A;"/>
+  <entity name="wopf" value="&#x1D568;"/>
+  <entity name="Wopf" value="&#x1D54E;"/>
+  <entity name="wp" value="&#x02118;"/>
+  <entity name="wr" value="&#x02240;"/>
+  <entity name="wreath" value="&#x02240;"/>
+  <entity name="wscr" value="&#x1D4CC;"/>
+  <entity name="Wscr" value="&#x1D4B2;"/>
+  <entity name="xcap" value="&#x022C2;"/>
+  <entity name="xcirc" value="&#x025EF;"/>
+  <entity name="xcup" value="&#x022C3;"/>
+  <entity name="xdtri" value="&#x025BD;"/>
+  <entity name="xfr" value="&#x1D535;"/>
+  <entity name="Xfr" value="&#x1D51B;"/>
+  <entity name="xharr" value="&#x0F578;"/>
+  <entity name="xhArr" value="&#x0F57B;"/>
+  <entity name="xi" value="&#x003BE;"/>
+  <entity name="Xi" value="&#x0039E;"/>
+  <entity name="xlarr" value="&#x0F576;"/>
+  <entity name="xlArr" value="&#x0F579;"/>
+  <entity name="xmap" value="&#x0F57D;"/>
+  <entity name="xnis" value="&#x022FB;"/>
+  <entity name="xodot" value="&#x02299;"/>
+  <entity name="xopf" value="&#x1D569;"/>
+  <entity name="Xopf" value="&#x1D54F;"/>
+  <entity name="xoplus" value="&#x02295;"/>
+  <entity name="xotime" value="&#x02297;"/>
+  <entity name="xrarr" value="&#x0F577;"/>
+  <entity name="xrArr" value="&#x0F57A;"/>
+  <entity name="xscr" value="&#x1D4CD;"/>
+  <entity name="Xscr" value="&#x1D4B3;"/>
+  <entity name="xsqcup" value="&#x02294;"/>
+  <entity name="xuplus" value="&#x0228E;"/>
+  <entity name="xutri" value="&#x025B3;"/>
+  <entity name="xvee" value="&#x022C1;"/>
+  <entity name="xwedge" value="&#x022C0;"/>
+  <entity name="yacute" value="&#x000FD;"/>
+  <entity name="Yacute" value="&#x000DD;"/>
+  <entity name="yacy" value="&#x0044F;"/>
+  <entity name="YAcy" value="&#x0042F;"/>
+  <entity name="ycirc" value="&#x00177;"/>
+  <entity name="Ycirc" value="&#x00176;"/>
+  <entity name="ycy" value="&#x0044B;"/>
+  <entity name="Ycy" value="&#x0042B;"/>
+  <entity name="yen" value="&#x000A5;"/>
+  <entity name="yfr" value="&#x1D536;"/>
+  <entity name="Yfr" value="&#x1D51C;"/>
+  <entity name="yicy" value="&#x00457;"/>
+  <entity name="YIcy" value="&#x00407;"/>
+  <entity name="yopf" value="&#x1D56A;"/>
+  <entity name="Yopf" value="&#x1D550;"/>
+  <entity name="yscr" value="&#x1D4CE;"/>
+  <entity name="Yscr" value="&#x1D4B4;"/>
+  <entity name="yucy" value="&#x0044E;"/>
+  <entity name="YUcy" value="&#x0042E;"/>
+  <entity name="yuml" value="&#x000FF;"/>
+  <entity name="Yuml" value="&#x00178;"/>
+  <entity name="zacute" value="&#x0017A;"/>
+  <entity name="Zacute" value="&#x00179;"/>
+  <entity name="zcaron" value="&#x0017E;"/>
+  <entity name="Zcaron" value="&#x0017D;"/>
+  <entity name="zcy" value="&#x00437;"/>
+  <entity name="Zcy" value="&#x00417;"/>
+  <entity name="zdot" value="&#x0017C;"/>
+  <entity name="Zdot" value="&#x0017B;"/>
+  <entity name="zeetrf" value="&#x02128;"/>
+  <entity name="ZeroWidthSpace" value="&#x0200B;"/>
+  <entity name="zeta" value="&#x003B6;"/>
+  <entity name="zfr" value="&#x1D537;"/>
+  <entity name="Zfr" value="&#x02128;"/>
+  <entity name="zhcy" value="&#x00436;"/>
+  <entity name="ZHcy" value="&#x00416;"/>
+  <entity name="zigrarr" value="&#x021DD;"/>
+  <entity name="zopf" value="&#x1D56B;"/>
+  <entity name="Zopf" value="&#x02124;"/>
+  <entity name="zscr" value="&#x1D4CF;"/>
+  <entity name="Zscr" value="&#x1D4B5;"/>
+</entities-table>

diff --git a/helm/ocaml/utf8_macros/data/extra-entities.xml b/helm/ocaml/utf8_macros/data/extra-entities.xml
new file mode 100644 (file)
index 0000000..73b12ad
--- /dev/null
+++ b/helm/ocaml/utf8_macros/data/extra-entities.xml
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+
+<entities-table>
+  <entity name="def" value="&#x0225d;"/>  <!-- ≝ -->
+  <entity name="neq" value="&#x02260;"/>  <!-- ≠ -->
+  <entity name="leq" value="&#x02264;"/>  <!-- ≤ -->
+  <entity name="geq" value="&#x02265;"/>  <!-- ≥ -->
+  <entity name="nleq" value="&#x02270;"/> <!-- ≰ -->
+  <entity name="ngeq" value="&#x02271;"/> <!-- ≱ -->
+  <entity name="to" value="&#x02192;"/>   <!-- → -->
+  <entity name="divides" value="&#x02223;"/>  <!-- ∣ -->
+  <entity name="ndivides" value="&#x02224;"/>  <!-- ∤ -->
+  <entity name="circ" value="&#x02218;"/>  <!-- ∤ -->
+</entities-table>
+
+<!-- vim: set encoding=utf8: -->

diff --git a/helm/ocaml/utf8_macros/make_table.ml b/helm/ocaml/utf8_macros/make_table.ml
new file mode 100644 (file)
index 0000000..4722af1
--- /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 (file)
index 0000000..dda7d4c
--- /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 (file)
index 0000000..8f98bfd
--- /dev/null
+++ b/helm/ocaml/utf8_macros/test.ml
@@ -0,0 +1,3 @@
+(* $Id$ *)
+
+prerr_endline <:unicode<lambda>>

diff --git a/helm/ocaml/utf8_macros/utf8Macro.ml b/helm/ocaml/utf8_macros/utf8Macro.ml
new file mode 100644 (file)
index 0000000..e5fca10
--- /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 (file)
index 0000000..d92f60b
--- /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 (file)
index 0000000..8b4a02e
--- /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 (file)
index 0000000..39f37df
--- /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 (file)
index 0000000..f43c77f
--- /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 (file)
index 0000000..1f4e508
--- /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 (file)
index 0000000..7f580a5
--- /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 (file)
index 0000000..5e63bcf
--- /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 (file)
index 0000000..9ff03ea
--- /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 (file)
index 0000000..5ef59bd
--- /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 (file)
index 0000000..6ca7bd9
--- /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 (file)
index 0000000..84c042e
--- /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 (file)
index 0000000..f8cc41c
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 ("</" ^ (pprefix p) ^ n ^ ">\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 "<?xml version=\"1.0\" ?>\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 (file)
index 0000000..4feca75
--- /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 <sacerdot@cs.unibo.it>               *)
+(*                                 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 (file)
index 0000000..4f57e12
--- /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 (file)
index 0000000..c13481c
--- /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 <line, column> *)
+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 <line, column> pair *)
+val get_position: xml_parser -> position
+

diff --git a/helm/ocaml/xmldiff/.depend b/helm/ocaml/xmldiff/.depend
new file mode 100644 (file)
index 0000000..e2832de
--- /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 (file)
index 0000000..6249206
--- /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 (file)
index 0000000..6f68438
--- /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 (file)
index 0000000..cf084af
--- /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